From 53771d71d21096e7493efbbcc206124809f9223d Mon Sep 17 00:00:00 2001 From: omichel Date: Thu, 16 Feb 2023 14:39:26 +0100 Subject: [PATCH] Added working version (for any simulation lenght) able of printing timings --- .../ASM/asmbkg.F90 | 164 + .../ASM/asminc.F90 | 1076 +++++ .../ASM/asmpar.F90 | 29 + .../BDY/bdy_oce.F90 | 175 + .../BDY/bdydta.F90 | 729 ++++ .../BDY/bdydyn.F90 | 126 + .../BDY/bdydyn2d.F90 | 343 ++ .../BDY/bdydyn3d.F90 | 418 ++ .../BDY/bdyice.F90 | 480 +++ .../BDY/bdyini.F90 | 2019 ++++++++++ .../BDY/bdylib.F90 | 518 +++ .../BDY/bdytides.F90 | 476 +++ .../BDY/bdytra.F90 | 186 + .../BDY/bdyvol.F90 | 229 ++ cfgs/OCE_MIXED_TIMINGS_REFERENCE/C1D/c1d.F90 | 66 + .../C1D/dtauvd.F90 | 224 ++ .../C1D/dyndmp.F90 | 218 ++ .../CRS/README.rst | 153 + cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crs.F90 | 318 ++ .../CRS/crsdom.F90 | 2270 +++++++++++ .../CRS/crsdomwri.F90 | 203 + .../CRS/crsfld.F90 | 243 ++ .../CRS/crsini.F90 | 248 ++ .../CRS/crslbclnk.F90 | 89 + .../DIA/dia25h.F90 | 322 ++ .../DIA/diaar5.F90 | 422 ++ .../DIA/diacfl.F90 | 161 + .../DIA/diadct.F90 | 1266 ++++++ .../DIA/diadetide.F90 | 113 + .../DIA/diahsb.F90 | 446 +++ .../DIA/diahth.F90 | 372 ++ .../DIA/diamlr.F90 | 428 ++ .../DIA/dianam.F90 | 136 + .../DIA/diaptr.F90 | 804 ++++ .../DIA/diawri.F90 | 1246 ++++++ .../DIU/diu_bulk.F90 | 262 ++ .../DIU/diu_coolskin.F90 | 143 + .../DIU/diu_layers.F90 | 51 + .../DIU/solfrac_mod.F90 | 56 + .../DIU/step_diu.F90 | 82 + .../DOM/closea.F90 | 263 ++ .../DOM/daymod.F90 | 414 ++ .../DOM/depth_e3.F90 | 163 + .../DOM/dom_oce.F90 | 359 ++ .../DOM/domain.F90 | 765 ++++ .../DOM/domhgr.F90 | 249 ++ .../DOM/dommsk.F90 | 233 ++ .../DOM/domqco.F90 | 295 ++ .../DOM/domtile.F90 | 254 ++ .../DOM/domutl.F90 | 183 + .../DOM/domvvl.F90 | 1105 ++++++ .../DOM/domwri.F90 | 243 ++ .../DOM/domzgr.F90 | 448 +++ .../DOM/domzgr_substitute.h90 | 53 + .../DOM/dtatsd.F90 | 278 ++ .../DOM/istate.F90 | 171 + .../DOM/phycst.F90 | 141 + .../DYN/divhor.F90 | 108 + .../DYN/dynadv.F90 | 148 + .../DYN/dynadv_cen2.F90 | 144 + .../DYN/dynadv_ubs.F90 | 257 ++ .../DYN/dynatf.F90 | 369 ++ .../DYN/dynatf_qco.F90 | 284 ++ .../DYN/dynhpg.F90 | 1435 +++++++ .../DYN/dynkeg.F90 | 153 + .../DYN/dynldf.F90 | 116 + .../DYN/dynldf_iso.F90 | 423 ++ .../DYN/dynldf_iso_lf.F90 | 401 ++ .../DYN/dynldf_lap_blp.F90 | 230 ++ .../DYN/dynldf_lap_blp_lf.F90 | 225 ++ .../DYN/dynspg.F90 | 244 ++ .../DYN/dynspg_exp.F90 | 88 + .../DYN/dynspg_ts.F90 | 1505 +++++++ .../DYN/dynvor.F90 | 1080 +++++ .../DYN/dynzad.F90 | 128 + .../DYN/dynzdf.F90 | 454 +++ .../DYN/sshwzv.F90 | 439 +++ .../DYN/wet_dry.F90 | 396 ++ .../FLO/flo4rk.F90 | 450 +++ .../FLO/flo_oce.F90 | 66 + .../FLO/floats.F90 | 141 + .../FLO/floblk.F90 | 386 ++ .../FLO/flodom.F90 | 467 +++ .../FLO/florst.F90 | 124 + .../FLO/flowri.F90 | 278 ++ .../ICB/icb_oce.F90 | 215 + .../ICB/icbclv.F90 | 179 + .../ICB/icbdia.F90 | 621 +++ .../ICB/icbdyn.F90 | 439 +++ .../ICB/icbini.F90 | 528 +++ .../ICB/icblbc.F90 | 828 ++++ .../ICB/icbrst.F90 | 428 ++ .../ICB/icbstp.F90 | 177 + .../ICB/icbthm.F90 | 297 ++ .../ICB/icbtrj.F90 | 287 ++ .../ICB/icbutl.F90 | 983 +++++ .../IOM/in_out_manager.F90 | 194 + cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/iom.F90 | 2830 +++++++++++++ .../IOM/iom_def.F90 | 72 + .../IOM/iom_nf90.F90 | 738 ++++ .../IOM/prtctl.F90 | 488 +++ .../IOM/restart.F90 | 440 +++ .../ISF/isf_oce.F90 | 271 ++ .../ISF/isfcav.F90 | 269 ++ .../ISF/isfcavgam.F90 | 253 ++ .../ISF/isfcavmlt.F90 | 314 ++ .../ISF/isfcpl.F90 | 778 ++++ .../ISF/isfdiags.F90 | 116 + .../ISF/isfdynatf.F90 | 91 + .../ISF/isfhdiv.F90 | 145 + .../ISF/isfload.F90 | 133 + .../ISF/isfpar.F90 | 196 + .../ISF/isfparmlt.F90 | 237 ++ .../ISF/isfrst.F90 | 99 + .../ISF/isfstp.F90 | 315 ++ .../ISF/isftbl.F90 | 275 ++ .../ISF/isfutils.F90 | 163 + .../LBC/halo_mng.F90 | 194 + .../LBC/lbc_lnk_call_generic.h90 | 129 + .../LBC/lbc_lnk_neicoll_generic.h90 | 271 ++ .../LBC/lbc_lnk_pt2pt_generic.h90 | 301 ++ .../LBC/lbc_nfd_ext_generic.h90 | 118 + .../LBC/lbc_nfd_generic.h90 | 389 ++ .../LBC/lbclnk.F90 | 205 + .../LBC/lbcnfd.F90 | 107 + .../LBC/lib_mpp.F90 | 1744 +++++++++ .../LBC/mpp_allreduce_generic.h90 | 89 + .../LBC/mpp_lbc_north_icb_generic.h90 | 114 + .../LBC/mpp_lnk_icb_generic.h90 | 183 + .../LBC/mpp_loc_generic.h90 | 139 + .../LBC/mpp_nfd_generic.h90 | 396 ++ .../LBC/mppini.F90 | 1453 +++++++ .../LDF/ldfc1d_c2d.F90 | 158 + .../LDF/ldfdyn.F90 | 503 +++ .../LDF/ldfslp.F90 | 736 ++++ .../LDF/ldftra.F90 | 900 +++++ .../OBS/ddatetoymdhms.h90 | 43 + .../OBS/diaobs.F90 | 1137 ++++++ .../OBS/find_obs_proc.h90 | 60 + .../OBS/greg2jul.h90 | 89 + .../OBS/grt_cir_dis.h90 | 39 + .../OBS/grt_cir_dis_saa.h90 | 31 + .../OBS/jul2greg.h90 | 115 + .../OBS/julian.F90 | 33 + .../OBS/linquad.h90 | 58 + .../OBS/maxdist.h90 | 76 + .../OBS/mpp_map.F90 | 85 + .../OBS/obs_averg_h2d.F90 | 821 ++++ .../OBS/obs_const.F90 | 22 + .../OBS/obs_conv.F90 | 45 + .../OBS/obs_conv_functions.h90 | 294 ++ .../OBS/obs_fbm.F90 | 1998 ++++++++++ .../OBS/obs_grd_bruteforce.h90 | 349 ++ .../OBS/obs_grid.F90 | 1184 ++++++ .../OBS/obs_inter_h2d.F90 | 58 + .../OBS/obs_inter_sup.F90 | 385 ++ .../OBS/obs_inter_z1d.F90 | 35 + .../OBS/obs_level_search.h90 | 51 + .../OBS/obs_mpp.F90 | 444 +++ .../OBS/obs_oper.F90 | 780 ++++ .../OBS/obs_prep.F90 | 1405 +++++++ .../OBS/obs_profiles.F90 | 39 + .../OBS/obs_profiles_def.F90 | 927 +++++ .../OBS/obs_read_altbias.F90 | 203 + .../OBS/obs_read_prof.F90 | 824 ++++ .../OBS/obs_read_surf.F90 | 506 +++ .../OBS/obs_readmdt.F90 | 260 ++ .../OBS/obs_rot_vel.F90 | 228 ++ .../OBS/obs_sort.F90 | 146 + .../OBS/obs_sstbias.F90 | 242 ++ .../OBS/obs_surf_def.F90 | 529 +++ .../OBS/obs_types.F90 | 267 ++ .../OBS/obs_utils.F90 | 209 + .../OBS/obs_write.F90 | 632 +++ .../OBS/obsinter_h2d.h90 | 1359 +++++++ .../OBS/obsinter_z1d.h90 | 193 + .../OBS/str_c_to_for.h90 | 39 + cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/abl.F90 | 31 + .../SBC/cpl_oasis3.F90 | 580 +++ .../SBC/cyclone.F90 | 271 ++ .../SBC/fldread.F90 | 1592 ++++++++ .../SBC/geo2ocean.F90 | 463 +++ .../SBC/ocealb.F90 | 48 + .../SBC/sbc_ice.F90 | 203 + .../SBC/sbc_oce.F90 | 235 ++ .../SBC/sbc_phy.F90 | 1277 ++++++ .../SBC/sbcabl.F90 | 51 + .../SBC/sbcapr.F90 | 171 + .../SBC/sbcblk.F90 | 1417 +++++++ .../SBC/sbcblk_algo_andreas.F90 | 337 ++ .../SBC/sbcblk_algo_coare3p0.F90 | 508 +++ .../SBC/sbcblk_algo_coare3p6.F90 | 500 +++ .../SBC/sbcblk_algo_ecmwf.F90 | 489 +++ .../SBC/sbcblk_algo_ice_an05.F90 | 389 ++ .../SBC/sbcblk_algo_ice_cdn.F90 | 295 ++ .../SBC/sbcblk_algo_ice_lg15.F90 | 289 ++ .../SBC/sbcblk_algo_ice_lu12.F90 | 185 + .../SBC/sbcblk_algo_ncar.F90 | 368 ++ .../SBC/sbcblk_skin_coare.F90 | 313 ++ .../SBC/sbcblk_skin_ecmwf.F90 | 310 ++ .../SBC/sbcclo.F90 | 352 ++ .../SBC/sbccpl.F90 | 2789 +++++++++++++ .../SBC/sbcdcy.F90 | 269 ++ .../SBC/sbcflx.F90 | 189 + .../SBC/sbcfwb.F90 | 256 ++ .../SBC/sbcice_cice.F90 | 1056 +++++ .../SBC/sbcice_if.F90 | 148 + .../SBC/sbcmod.F90 | 635 +++ .../SBC/sbcrnf.F90 | 542 +++ .../SBC/sbcssm.F90 | 260 ++ .../SBC/sbcssr.F90 | 256 ++ .../SBC/sbcwave.F90 | 534 +++ .../STO/stopar.F90 | 917 +++++ .../STO/stopts.F90 | 142 + .../STO/storng.F90 | 408 ++ cfgs/OCE_MIXED_TIMINGS_REFERENCE/TDE/tide.h90 | 172 + .../TDE/tide_mod.F90 | 762 ++++ .../TRA/eosbn2.F90 | 1818 +++++++++ .../TRA/traadv.F90 | 315 ++ .../TRA/traadv_cen.F90 | 196 + .../TRA/traadv_cen_lf.F90 | 188 + .../TRA/traadv_fct.F90 | 1011 +++++ .../TRA/traadv_mus.F90 | 245 ++ .../TRA/traadv_qck.F90 | 407 ++ .../TRA/traadv_qck_lf.F90 | 375 ++ .../TRA/traadv_ubs.F90 | 361 ++ .../TRA/traadv_ubs_lf.F90 | 367 ++ .../TRA/traatf.F90 | 385 ++ .../TRA/traatf_qco.F90 | 369 ++ .../TRA/trabbc.F90 | 196 + .../TRA/trabbl.F90 | 543 +++ .../TRA/tradmp.F90 | 243 ++ .../TRA/traisf.F90 | 156 + .../TRA/traldf.F90 | 128 + .../TRA/traldf_iso.F90 | 408 ++ .../TRA/traldf_lap_blp.F90 | 260 ++ .../TRA/traldf_triad.F90 | 506 +++ .../TRA/tramle.F90 | 373 ++ .../TRA/tranpc.F90 | 327 ++ .../TRA/traqsr.F90 | 453 +++ .../TRA/trasbc.F90 | 226 ++ .../TRA/trazdf.F90 | 267 ++ .../TRA/zpshde.F90 | 493 +++ .../TRD/trd_oce.F90 | 83 + .../TRD/trddyn.F90 | 182 + .../TRD/trdglo.F90 | 547 +++ .../TRD/trdini.F90 | 111 + .../TRD/trdken.F90 | 249 ++ .../TRD/trdmxl.F90 | 869 ++++ .../TRD/trdmxl_oce.F90 | 135 + .../TRD/trdmxl_rst.F90 | 190 + .../TRD/trdpen.F90 | 149 + .../TRD/trdtra.F90 | 373 ++ .../TRD/trdtrc.F90 | 25 + .../TRD/trdvor.F90 | 545 +++ .../TRD/trdvor_oce.F90 | 34 + .../USR/README.rst | 283 ++ .../USR/usrdef_fmask.F90 | 160 + .../USR/usrdef_hgr.F90 | 175 + .../USR/usrdef_istate.F90 | 105 + .../USR/usrdef_nam.F90 | 112 + .../USR/usrdef_sbc.F90 | 236 ++ .../USR/usrdef_zgr.F90 | 246 ++ .../ZDF/zdf_oce.F90 | 77 + .../ZDF/zdfddm.F90 | 167 + .../ZDF/zdfdrg.F90 | 456 +++ .../ZDF/zdfevd.F90 | 141 + .../ZDF/zdfgls.F90 | 1280 ++++++ .../ZDF/zdfiwm.F90 | 439 +++ .../ZDF/zdfmfc.F90 | 487 +++ .../ZDF/zdfmxl.F90 | 165 + .../ZDF/zdfosm.F90 | 3484 +++++++++++++++++ .../ZDF/zdfphy.F90 | 405 ++ .../ZDF/zdfric.F90 | 230 ++ .../ZDF/zdfsh2.F90 | 106 + .../ZDF/zdfswm.F90 | 97 + .../ZDF/zdftke.F90 | 889 +++++ .../do_loop_substitute.h90 | 80 + cfgs/OCE_MIXED_TIMINGS_REFERENCE/exampl.mod | Bin 0 -> 365 bytes cfgs/OCE_MIXED_TIMINGS_REFERENCE/lib_cray.f90 | 34 + .../lib_fortran.F90 | 651 +++ .../lib_fortran_generic.h90 | 139 + .../module_example.F90 | 197 + cfgs/OCE_MIXED_TIMINGS_REFERENCE/nemo.f90 | 21 + cfgs/OCE_MIXED_TIMINGS_REFERENCE/nemogcm.F90 | 632 +++ cfgs/OCE_MIXED_TIMINGS_REFERENCE/oce.F90 | 149 + cfgs/OCE_MIXED_TIMINGS_REFERENCE/par_kind.F90 | 42 + cfgs/OCE_MIXED_TIMINGS_REFERENCE/par_oce.F90 | 107 + .../single_precision_substitute.h90 | 8 + cfgs/OCE_MIXED_TIMINGS_REFERENCE/step.F90 | 452 +++ cfgs/OCE_MIXED_TIMINGS_REFERENCE/step_oce.F90 | 123 + cfgs/OCE_MIXED_TIMINGS_REFERENCE/stpctl.F90 | 331 ++ cfgs/OCE_MIXED_TIMINGS_REFERENCE/stpmlf.F90 | 576 +++ cfgs/OCE_MIXED_TIMINGS_REFERENCE/timing.F90 | 877 +++++ cfgs/OCE_MIXED_TIMINGS_REFERENCE/trc_oce.F90 | 260 ++ 295 files changed, 119770 insertions(+) create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ASM/asmbkg.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ASM/asminc.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ASM/asmpar.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdy_oce.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydta.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydyn.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydyn2d.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydyn3d.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdyice.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdyini.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdylib.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdytides.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdytra.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdyvol.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/C1D/c1d.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/C1D/dtauvd.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/C1D/dyndmp.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/README.rst create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crs.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsdom.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsdomwri.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsfld.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsini.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crslbclnk.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/dia25h.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diaar5.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diacfl.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diadct.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diadetide.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diahsb.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diahth.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diamlr.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/dianam.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diaptr.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diawri.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/diu_bulk.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/diu_coolskin.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/diu_layers.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/solfrac_mod.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/step_diu.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/closea.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/daymod.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/depth_e3.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/dom_oce.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domain.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domhgr.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/dommsk.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domqco.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domtile.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domutl.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domvvl.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domwri.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domzgr.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domzgr_substitute.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/dtatsd.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/istate.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/phycst.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/divhor.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynadv.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynadv_cen2.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynadv_ubs.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynatf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynatf_qco.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynhpg.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynkeg.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynldf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynldf_iso.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynldf_iso_lf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynldf_lap_blp.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynldf_lap_blp_lf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynspg.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynspg_exp.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynspg_ts.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynvor.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynzad.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynzdf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/sshwzv.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/wet_dry.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flo4rk.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flo_oce.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/floats.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/floblk.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flodom.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/florst.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flowri.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icb_oce.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbclv.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbdia.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbdyn.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbini.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icblbc.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbrst.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbstp.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbthm.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbtrj.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbutl.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/in_out_manager.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/iom.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/iom_def.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/iom_nf90.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/prtctl.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/restart.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isf_oce.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcav.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcavgam.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcavmlt.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcpl.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfdiags.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfdynatf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfhdiv.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfload.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfpar.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfparmlt.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfrst.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfstp.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isftbl.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfutils.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/halo_mng.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_lnk_call_generic.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_lnk_neicoll_generic.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_lnk_pt2pt_generic.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_nfd_ext_generic.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_nfd_generic.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbclnk.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbcnfd.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lib_mpp.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_allreduce_generic.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_lbc_north_icb_generic.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_lnk_icb_generic.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_loc_generic.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_nfd_generic.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mppini.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldfc1d_c2d.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldfdyn.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldfslp.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldftra.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/ddatetoymdhms.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/diaobs.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/find_obs_proc.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/greg2jul.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/grt_cir_dis.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/grt_cir_dis_saa.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/jul2greg.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/julian.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/linquad.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/maxdist.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/mpp_map.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_averg_h2d.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_const.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_conv.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_conv_functions.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_fbm.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_grd_bruteforce.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_grid.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_inter_h2d.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_inter_sup.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_inter_z1d.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_level_search.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_mpp.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_oper.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_prep.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_profiles.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_profiles_def.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_read_altbias.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_read_prof.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_read_surf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_readmdt.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_rot_vel.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_sort.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_sstbias.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_surf_def.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_types.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_utils.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_write.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obsinter_h2d.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obsinter_z1d.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/str_c_to_for.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/abl.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/cpl_oasis3.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/cyclone.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/fldread.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/geo2ocean.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/ocealb.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbc_ice.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbc_oce.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbc_phy.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcabl.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcapr.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_andreas.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_coare3p0.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_coare3p6.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ecmwf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_an05.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_cdn.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_lg15.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_lu12.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ncar.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_skin_coare.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_skin_ecmwf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcclo.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbccpl.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcdcy.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcflx.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcfwb.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcice_cice.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcice_if.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcmod.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcrnf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcssm.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcssr.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcwave.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/STO/stopar.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/STO/stopts.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/STO/storng.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TDE/tide.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TDE/tide_mod.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/eosbn2.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_cen.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_cen_lf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_fct.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_mus.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_qck.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_qck_lf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_ubs.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_ubs_lf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traatf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traatf_qco.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trabbc.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trabbl.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/tradmp.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traisf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traldf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traldf_iso.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traldf_lap_blp.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traldf_triad.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/tramle.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/tranpc.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traqsr.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trasbc.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trazdf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/zpshde.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trd_oce.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trddyn.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdglo.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdini.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdken.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdmxl.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdmxl_oce.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdmxl_rst.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdpen.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdtra.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdtrc.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdvor.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdvor_oce.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/README.rst create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_fmask.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_hgr.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_istate.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_nam.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_sbc.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_zgr.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdf_oce.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfddm.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfdrg.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfevd.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfgls.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfiwm.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfmfc.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfmxl.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfosm.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfphy.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfric.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfsh2.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfswm.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdftke.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/do_loop_substitute.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/exampl.mod create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/lib_cray.f90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/lib_fortran.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/lib_fortran_generic.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/module_example.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/nemo.f90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/nemogcm.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/oce.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/par_kind.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/par_oce.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/single_precision_substitute.h90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/step.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/step_oce.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/stpctl.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/stpmlf.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/timing.F90 create mode 100644 cfgs/OCE_MIXED_TIMINGS_REFERENCE/trc_oce.F90 diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ASM/asmbkg.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ASM/asmbkg.F90 new file mode 100644 index 0000000..ddf3a34 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ASM/asmbkg.F90 @@ -0,0 +1,164 @@ +MODULE asmbkg + !!====================================================================== + !! *** MODULE asmtrj -> asmbkg *** + !! Assimilation trajectory interface: Write to file the background state and the model state trajectory + !!====================================================================== + !! History : ! 2007-03 (M. Martin) Met. Office version + !! ! 2007-04 (A. Weaver) asm_trj_wri, original code + !! ! 2007-03 (K. Mogensen) Adapt to NEMOVAR and use IOM instead of IOIPSL + !! ! 2007-04 (A. Weaver) Name change (formally asmbkg.F90). Distinguish + !! background states in Jb term and at analysis time. + !! Include state trajectory routine (currently empty) + !! ! 2007-07 (A. Weaver) Add tke_rst and flt_rst for case nitbkg=0 + !! ! 2009-03 (F. Vigilant) Add hmlp (zdfmxl) for no tracer nmldp=2 + !! ! 2009-06 (F. Vigilant) asm_trj_wri: special case when kt=nit000-1 + !! ! 2009-07 (F. Vigilant) asm_trj_wri: add computation of eiv at restart + !! ! 2010-01 (A. Vidard) split asm_trj_wri into tam_trj_wri and asm_bkg_wri + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! asm_bkg_wri : Write out the background state + !! asm_trj_wri : Write out the model state trajectory (used with 4D-Var) + !!---------------------------------------------------------------------- + USE oce ! Dynamics and active tracers defined in memory + USE sbc_oce ! Ocean surface boundary conditions + USE zdf_oce ! Vertical mixing variables + USE zdfddm ! Double diffusion mixing parameterization + USE ldftra ! Lateral diffusion: eddy diffusivity coefficients + USE ldfslp ! Lateral diffusion: slopes of neutral surfaces + USE tradmp ! Tracer damping + USE zdftke ! TKE vertical physics + USE eosbn2 ! Equation of state (eos_bn2 routine) + USE zdfmxl ! Mixed layer depth + USE dom_oce , ONLY : ndastp, l_istiled + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE asmpar ! Parameters for the assmilation interface + USE zdfmxl ! mixed layer depth +#if defined key_si3 + USE ice +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC asm_bkg_wri !: Write out the background state + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: asmbkg.F90 15417 2021-10-20 14:16:29Z lovato $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE asm_bkg_wri( kt, Kmm ) + !!----------------------------------------------------------------------- + !! *** ROUTINE asm_bkg_wri *** + !! + !! ** Purpose : Write to file the background state for later use in the + !! inner loop of data assimilation or for direct initialization + !! in the outer loop. + !! + !! ** Method : Write out the background state for use in the Jb term + !! in the cost function and for use with direct initialization + !! at analysis time. + !!----------------------------------------------------------------------- + INTEGER, INTENT( IN ) :: kt ! Current time-step + INTEGER, INTENT( IN ) :: Kmm ! time level index + ! + CHARACTER (LEN=50) :: cl_asmbkg + CHARACTER (LEN=50) :: cl_asmdin + LOGICAL :: llok ! Check if file exists + INTEGER :: inum ! File unit number + REAL(wp) :: zdate ! Date + !!----------------------------------------------------------------------- + + + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + ! !------------------------------------------- + IF( kt == nitbkg_r ) THEN ! Write out background at time step nitbkg_r + ! !-----------------------------------======== + ! + WRITE(cl_asmbkg, FMT='(A,".nc")' ) TRIM( c_asmbkg ) + cl_asmbkg = TRIM( cl_asmbkg ) + INQUIRE( FILE = cl_asmbkg, EXIST = llok ) + ! + IF( .NOT. llok ) THEN + IF(lwp) WRITE(numout,*) ' Setting up assimilation background file '// TRIM( c_asmbkg ) + ! + ! ! Define the output file + CALL iom_open( c_asmbkg, inum, ldwrt = .TRUE. ) + ! + IF( nitbkg_r == nit000 - 1 ) THEN ! Treat special case when nitbkg = 0 + zdate = REAL( ndastp ) + IF( ln_zdftke ) THEN ! read turbulent kinetic energy ( en ) + IF(lwp) WRITE(numout,*) ' Reading TKE (en) from restart...' + CALL tke_rst( nit000, 'READ' ) + ENDIF + ELSE + zdate = REAL( ndastp ) + ENDIF + ! + ! ! Write the information + CALL iom_rstput( kt, nitbkg_r, inum, 'rdastp' , zdate ) + CALL iom_rstput( kt, nitbkg_r, inum, 'un' , uu(:,:,:,Kmm) ) + CALL iom_rstput( kt, nitbkg_r, inum, 'vn' , vv(:,:,:,Kmm) ) + CALL iom_rstput( kt, nitbkg_r, inum, 'tn' , ts(:,:,:,jp_tem,Kmm) ) + CALL iom_rstput( kt, nitbkg_r, inum, 'sn' , ts(:,:,:,jp_sal,Kmm) ) + CALL iom_rstput( kt, nitbkg_r, inum, 'sshn' , ssh(:,:,Kmm) ) + IF( ln_zdftke ) CALL iom_rstput( kt, nitbkg_r, inum, 'en' , en ) + ! + CALL iom_close( inum ) + ENDIF + ! + ENDIF + + ! !------------------------------------------- + IF( kt == nitdin_r ) THEN ! Write out background at time step nitdin_r + ! !-----------------------------------======== + ! + WRITE(cl_asmdin, FMT='(A,".nc")' ) TRIM( c_asmdin ) + cl_asmdin = TRIM( cl_asmdin ) + INQUIRE( FILE = cl_asmdin, EXIST = llok ) + ! + IF( .NOT. llok ) THEN + IF(lwp) WRITE(numout,*) ' Setting up assimilation background file '// TRIM( c_asmdin ) + ! + ! ! Define the output file + CALL iom_open( c_asmdin, inum, ldwrt = .TRUE. ) + ! + IF( nitdin_r == nit000 - 1 ) THEN ! Treat special case when nitbkg = 0 + + zdate = REAL( ndastp ) + ELSE + zdate = REAL( ndastp ) + ENDIF + ! + ! ! Write the information + CALL iom_rstput( kt, nitdin_r, inum, 'rdastp' , zdate ) + CALL iom_rstput( kt, nitdin_r, inum, 'un' , uu(:,:,:,Kmm) ) + CALL iom_rstput( kt, nitdin_r, inum, 'vn' , vv(:,:,:,Kmm) ) + CALL iom_rstput( kt, nitdin_r, inum, 'tn' , ts(:,:,:,jp_tem,Kmm) ) + CALL iom_rstput( kt, nitdin_r, inum, 'sn' , ts(:,:,:,jp_sal,Kmm) ) + CALL iom_rstput( kt, nitdin_r, inum, 'sshn' , ssh(:,:,Kmm) ) +#if defined key_si3 + IF( nn_ice == 2 ) THEN + IF( ALLOCATED(at_i) ) THEN + CALL iom_rstput( kt, nitdin_r, inum, 'iceconc', at_i(:,:) ) + ELSE + CALL ctl_warn('asm_bkg_wri: Ice concentration not written to background ', & + & 'as ice variable at_i not allocated on this timestep') + ENDIF + ENDIF +#endif + ! + CALL iom_close( inum ) + ENDIF + ! + ENDIF + ENDIF ! check for last tile + ! + END SUBROUTINE asm_bkg_wri + + !!====================================================================== +END MODULE asmbkg \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ASM/asminc.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ASM/asminc.F90 new file mode 100644 index 0000000..e87b12b --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ASM/asminc.F90 @@ -0,0 +1,1076 @@ +MODULE asminc + !!====================================================================== + !! *** MODULE asminc *** + !! Assimilation increment : Apply an increment generated by data + !! assimilation + !!====================================================================== + !! History : ! 2007-03 (M. Martin) Met Office version + !! ! 2007-04 (A. Weaver) calc_date original code + !! ! 2007-04 (A. Weaver) Merge with OPAVAR/NEMOVAR + !! NEMO 3.3 ! 2010-05 (D. Lea) Update to work with NEMO v3.2 + !! - ! 2010-05 (D. Lea) add calc_month_len routine based on day_init + !! 3.4 ! 2012-10 (A. Weaver and K. Mogensen) Fix for direct initialization + !! ! 2014-09 (D. Lea) Local calc_date removed use routine from OBS + !! ! 2015-11 (D. Lea) Handle non-zero initial time of day + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! asm_inc_init : Initialize the increment arrays and IAU weights + !! tra_asm_inc : Apply the tracer (T and S) increments + !! dyn_asm_inc : Apply the dynamic (u and v) increments + !! ssh_asm_inc : Apply the SSH increment + !! ssh_asm_div : Apply divergence associated with SSH increment + !! seaice_asm_inc : Apply the seaice increment + !!---------------------------------------------------------------------- + USE oce ! Dynamics and active tracers defined in memory + USE par_oce ! Ocean space and time domain variables + USE dom_oce ! Ocean space and time domain + USE domvvl ! domain: variable volume level + USE ldfdyn ! lateral diffusion: eddy viscosity coefficients + USE eosbn2 ! Equation of state - in situ and potential density + USE zpshde ! Partial step : Horizontal Derivative + USE asmpar ! Parameters for the assmilation interface + USE asmbkg ! + USE c1d ! 1D initialization + USE sbc_oce ! Surface boundary condition variables. + USE diaobs , ONLY : calc_date ! Compute the calendar date on a given step +#if defined key_si3 + USE ice , ONLY : hm_i, at_i, at_i_b +#endif + ! + USE in_out_manager ! I/O manager + USE iom ! Library to read input files + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC asm_inc_init !: Initialize the increment arrays and IAU weights + PUBLIC tra_asm_inc !: Apply the tracer (T and S) increments + PUBLIC dyn_asm_inc !: Apply the dynamic (u and v) increments + PUBLIC ssh_asm_inc !: Apply the SSH increment + PUBLIC ssh_asm_div !: Apply the SSH divergence + PUBLIC seaice_asm_inc !: Apply the seaice increment + +#if defined key_asminc + LOGICAL, PUBLIC, PARAMETER :: lk_asminc = .TRUE. !: Logical switch for assimilation increment interface +#else + LOGICAL, PUBLIC, PARAMETER :: lk_asminc = .FALSE. !: No assimilation increments +#endif + LOGICAL, PUBLIC :: ln_bkgwri !: No output of the background state fields + LOGICAL, PUBLIC :: ln_asmiau !: No applying forcing with an assimilation increment + LOGICAL, PUBLIC :: ln_asmdin !: No direct initialization + LOGICAL, PUBLIC :: ln_trainc !: No tracer (T and S) assimilation increments + LOGICAL, PUBLIC :: ln_dyninc !: No dynamics (u and v) assimilation increments + LOGICAL, PUBLIC :: ln_sshinc !: No sea surface height assimilation increment + LOGICAL, PUBLIC :: ln_seaiceinc !: No sea ice concentration increment + LOGICAL, PUBLIC :: ln_salfix !: Apply minimum salinity check + LOGICAL, PUBLIC :: ln_temnofreeze = .FALSE. !: Don't allow the temperature to drop below freezing + INTEGER, PUBLIC :: nn_divdmp !: Apply divergence damping filter nn_divdmp times + + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: t_bkg , s_bkg !: Background temperature and salinity + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: u_bkg , v_bkg !: Background u- & v- velocity components + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: t_bkginc, s_bkginc !: Increment to the background T & S + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: u_bkginc, v_bkginc !: Increment to the u- & v-components + REAL(wp), PUBLIC, DIMENSION(:) , ALLOCATABLE :: wgtiau !: IAU weights for each time step +#if defined key_asminc + REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: ssh_iau !: IAU-weighted sea surface height increment +#endif + ! !!! time steps relative to the cycle interval [0,nitend-nit000-1] + INTEGER , PUBLIC :: nitbkg !: Time step of the background state used in the Jb term + INTEGER , PUBLIC :: nitdin !: Time step of the background state for direct initialization + INTEGER , PUBLIC :: nitiaustr !: Time step of the start of the IAU interval + INTEGER , PUBLIC :: nitiaufin !: Time step of the end of the IAU interval + ! + INTEGER , PUBLIC :: niaufn !: Type of IAU weighing function: = 0 Constant weighting + ! !: = 1 Linear hat-like, centred in middle of IAU interval + REAL(wp), PUBLIC :: salfixmin !: Ensure that the salinity is larger than this value if (ln_salfix) + + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ssh_bkg, ssh_bkginc ! Background sea surface height and its increment + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: seaice_bkginc ! Increment to the background sea ice conc +#if defined key_cice && defined key_asminc + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ndaice_da ! ice increment tendency into CICE +#endif + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: asminc.F90 15058 2021-06-25 09:15:15Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE asm_inc_init( Kbb, Kmm, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE asm_inc_init *** + !! + !! ** Purpose : Initialize the assimilation increment and IAU weights. + !! + !! ** Method : Initialize the assimilation increment and IAU weights. + !! + !! ** Action : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Krhs ! time level indices + ! + INTEGER :: ji, jj, jk, jt ! dummy loop indices + INTEGER :: imid, inum ! local integers + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: iiauper ! Number of time steps in the IAU period + INTEGER :: icycper ! Number of time steps in the cycle + REAL(KIND=wp) :: ditend_date ! Date YYYYMMDD.HHMMSS of final time step + REAL(KIND=wp) :: ditbkg_date ! Date YYYYMMDD.HHMMSS of background time step for Jb term + REAL(KIND=wp) :: ditdin_date ! Date YYYYMMDD.HHMMSS of background time step for DI + REAL(KIND=wp) :: ditiaustr_date ! Date YYYYMMDD.HHMMSS of IAU interval start time step + REAL(KIND=wp) :: ditiaufin_date ! Date YYYYMMDD.HHMMSS of IAU interval final time step + + REAL(wp) :: znorm ! Normalization factor for IAU weights + REAL(wp) :: ztotwgt ! Value of time-integrated IAU weights (should be equal to one) + REAL(wp) :: z_inc_dateb ! Start date of interval on which increment is valid + REAL(wp) :: z_inc_datef ! End date of interval on which increment is valid + REAL(wp) :: zdate_bkg ! Date in background state file for DI + REAL(wp) :: zdate_inc ! Time axis in increments file + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zhdiv ! 2D workspace + !! + NAMELIST/nam_asminc/ ln_bkgwri, & + & ln_trainc, ln_dyninc, ln_sshinc, & + & ln_asmdin, ln_asmiau, & + & nitbkg, nitdin, nitiaustr, nitiaufin, niaufn, & + & ln_salfix, salfixmin, nn_divdmp + !!---------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! Read Namelist nam_asminc : assimilation increment interface + !----------------------------------------------------------------------- + ln_seaiceinc = .FALSE. + ln_temnofreeze = .FALSE. + + READ ( numnam_ref, nam_asminc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_asminc in reference namelist' ) + READ ( numnam_cfg, nam_asminc, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_asminc in configuration namelist' ) + IF(lwm) WRITE ( numond, nam_asminc ) + + ! Control print + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'asm_inc_init : Assimilation increment initialization :' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namasm : set assimilation increment parameters' + WRITE(numout,*) ' Logical switch for writing out background state ln_bkgwri = ', ln_bkgwri + WRITE(numout,*) ' Logical switch for applying tracer increments ln_trainc = ', ln_trainc + WRITE(numout,*) ' Logical switch for applying velocity increments ln_dyninc = ', ln_dyninc + WRITE(numout,*) ' Logical switch for applying SSH increments ln_sshinc = ', ln_sshinc + WRITE(numout,*) ' Logical switch for Direct Initialization (DI) ln_asmdin = ', ln_asmdin + WRITE(numout,*) ' Logical switch for applying sea ice increments ln_seaiceinc = ', ln_seaiceinc + WRITE(numout,*) ' Logical switch for Incremental Analysis Updating (IAU) ln_asmiau = ', ln_asmiau + WRITE(numout,*) ' Timestep of background in [0,nitend-nit000-1] nitbkg = ', nitbkg + WRITE(numout,*) ' Timestep of background for DI in [0,nitend-nit000-1] nitdin = ', nitdin + WRITE(numout,*) ' Timestep of start of IAU interval in [0,nitend-nit000-1] nitiaustr = ', nitiaustr + WRITE(numout,*) ' Timestep of end of IAU interval in [0,nitend-nit000-1] nitiaufin = ', nitiaufin + WRITE(numout,*) ' Type of IAU weighting function niaufn = ', niaufn + WRITE(numout,*) ' Logical switch for ensuring that the sa > salfixmin ln_salfix = ', ln_salfix + WRITE(numout,*) ' Minimum salinity after applying the increments salfixmin = ', salfixmin + ENDIF + + nitbkg_r = nitbkg + nit000 - 1 ! Background time referenced to nit000 + nitdin_r = nitdin + nit000 - 1 ! Background time for DI referenced to nit000 + nitiaustr_r = nitiaustr + nit000 - 1 ! Start of IAU interval referenced to nit000 + nitiaufin_r = nitiaufin + nit000 - 1 ! End of IAU interval referenced to nit000 + + iiauper = nitiaufin_r - nitiaustr_r + 1 ! IAU interval length + icycper = nitend - nit000 + 1 ! Cycle interval length + + CALL calc_date( nitend , ditend_date ) ! Date of final time step + CALL calc_date( nitbkg_r , ditbkg_date ) ! Background time for Jb referenced to ndate0 + CALL calc_date( nitdin_r , ditdin_date ) ! Background time for DI referenced to ndate0 + CALL calc_date( nitiaustr_r, ditiaustr_date ) ! IAU start time referenced to ndate0 + CALL calc_date( nitiaufin_r, ditiaufin_date ) ! IAU end time referenced to ndate0 + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Time steps referenced to current cycle:' + WRITE(numout,*) ' iitrst = ', nit000 - 1 + WRITE(numout,*) ' nit000 = ', nit000 + WRITE(numout,*) ' nitend = ', nitend + WRITE(numout,*) ' nitbkg_r = ', nitbkg_r + WRITE(numout,*) ' nitdin_r = ', nitdin_r + WRITE(numout,*) ' nitiaustr_r = ', nitiaustr_r + WRITE(numout,*) ' nitiaufin_r = ', nitiaufin_r + WRITE(numout,*) + WRITE(numout,*) ' Dates referenced to current cycle:' + WRITE(numout,*) ' ndastp = ', ndastp + WRITE(numout,*) ' ndate0 = ', ndate0 + WRITE(numout,*) ' nn_time0 = ', nn_time0 + WRITE(numout,*) ' ditend_date = ', ditend_date + WRITE(numout,*) ' ditbkg_date = ', ditbkg_date + WRITE(numout,*) ' ditdin_date = ', ditdin_date + WRITE(numout,*) ' ditiaustr_date = ', ditiaustr_date + WRITE(numout,*) ' ditiaufin_date = ', ditiaufin_date + ENDIF + + + IF ( ( ln_asmdin ).AND.( ln_asmiau ) ) & + & CALL ctl_stop( ' ln_asmdin and ln_asmiau :', & + & ' Choose Direct Initialization OR Incremental Analysis Updating') + + IF ( ( ( .NOT. ln_asmdin ).AND.( .NOT. ln_asmiau ) ) & + .AND.( ( ln_trainc ).OR.( ln_dyninc ).OR.( ln_sshinc ) .OR. ( ln_seaiceinc) )) & + & CALL ctl_stop( ' One or more of ln_trainc, ln_dyninc, ln_sshinc and ln_seaiceinc is set to .true.', & + & ' but ln_asmdin and ln_asmiau are both set to .false. :', & + & ' Inconsistent options') + + IF ( ( niaufn /= 0 ).AND.( niaufn /= 1 ) ) & + & CALL ctl_stop( ' niaufn /= 0 or niaufn /=1 :', & + & ' Type IAU weighting function is invalid') + + IF ( ( .NOT. ln_trainc ).AND.( .NOT. ln_dyninc ).AND.( .NOT. ln_sshinc ).AND.( .NOT. ln_seaiceinc ) & + & ) & + & CALL ctl_warn( ' ln_trainc, ln_dyninc, ln_sshinc and ln_seaiceinc are set to .false. :', & + & ' The assimilation increments are not applied') + + IF ( ( ln_asmiau ).AND.( nitiaustr == nitiaufin ) ) & + & CALL ctl_stop( ' nitiaustr = nitiaufin :', & + & ' IAU interval is of zero length') + + IF ( ( ln_asmiau ).AND.( ( nitiaustr_r < nit000 ).OR.( nitiaufin_r > nitend ) ) ) & + & CALL ctl_stop( ' nitiaustr or nitiaufin :', & + & ' IAU starting or final time step is outside the cycle interval', & + & ' Valid range nit000 to nitend') + + IF ( ( nitbkg_r < nit000 - 1 ).OR.( nitbkg_r > nitend ) ) & + & CALL ctl_stop( ' nitbkg :', & + & ' Background time step is outside the cycle interval') + + IF ( ( nitdin_r < nit000 - 1 ).OR.( nitdin_r > nitend ) ) & + & CALL ctl_stop( ' nitdin :', & + & ' Background time step for Direct Initialization is outside', & + & ' the cycle interval') + + IF ( nstop > 0 ) RETURN ! if there are any errors then go no further + + !-------------------------------------------------------------------- + ! Initialize the Incremental Analysis Updating weighting function + !-------------------------------------------------------------------- + + IF( ln_asmiau ) THEN + ! + ALLOCATE( wgtiau( icycper ) ) + ! + wgtiau(:) = 0._wp + ! + ! !--------------------------------------------------------- + IF( niaufn == 0 ) THEN ! Constant IAU forcing + ! !--------------------------------------------------------- + DO jt = 1, iiauper + wgtiau(jt+nitiaustr-1) = 1.0 / REAL( iiauper ) + END DO + ! !--------------------------------------------------------- + ELSEIF ( niaufn == 1 ) THEN ! Linear hat-like, centred in middle of IAU interval + ! !--------------------------------------------------------- + ! Compute the normalization factor + znorm = 0._wp + IF( MOD( iiauper, 2 ) == 0 ) THEN ! Even number of time steps in IAU interval + imid = iiauper / 2 + DO jt = 1, imid + znorm = znorm + REAL( jt ) + END DO + znorm = 2.0 * znorm + ELSE ! Odd number of time steps in IAU interval + imid = ( iiauper + 1 ) / 2 + DO jt = 1, imid - 1 + znorm = znorm + REAL( jt ) + END DO + znorm = 2.0 * znorm + REAL( imid ) + ENDIF + znorm = 1.0 / znorm + ! + DO jt = 1, imid - 1 + wgtiau(jt+nitiaustr-1) = REAL( jt ) * znorm + END DO + DO jt = imid, iiauper + wgtiau(jt+nitiaustr-1) = REAL( iiauper - jt + 1 ) * znorm + END DO + ! + ENDIF + + ! Test that the integral of the weights over the weighting interval equals 1 + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'asm_inc_init : IAU weights' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' time step IAU weight' + WRITE(numout,*) ' ========= =====================' + ztotwgt = 0.0 + DO jt = 1, icycper + ztotwgt = ztotwgt + wgtiau(jt) + WRITE(numout,*) ' ', jt, ' ', wgtiau(jt) + END DO + WRITE(numout,*) ' ===================================' + WRITE(numout,*) ' Time-integrated weight = ', ztotwgt + WRITE(numout,*) ' ===================================' + ENDIF + + ENDIF + + !-------------------------------------------------------------------- + ! Allocate and initialize the increment arrays + !-------------------------------------------------------------------- + + ALLOCATE( t_bkginc (jpi,jpj,jpk) ) ; t_bkginc (:,:,:) = 0._wp + ALLOCATE( s_bkginc (jpi,jpj,jpk) ) ; s_bkginc (:,:,:) = 0._wp + ALLOCATE( u_bkginc (jpi,jpj,jpk) ) ; u_bkginc (:,:,:) = 0._wp + ALLOCATE( v_bkginc (jpi,jpj,jpk) ) ; v_bkginc (:,:,:) = 0._wp + ALLOCATE( ssh_bkginc (jpi,jpj) ) ; ssh_bkginc (:,:) = 0._wp + ALLOCATE( seaice_bkginc(jpi,jpj) ) ; seaice_bkginc(:,:) = 0._wp +#if defined key_asminc + ALLOCATE( ssh_iau (jpi,jpj) ) ; ssh_iau (:,:) = 0._wp +#endif +#if defined key_cice && defined key_asminc + ALLOCATE( ndaice_da (jpi,jpj) ) ; ndaice_da (:,:) = 0._wp +#endif + ! + IF ( ln_trainc .OR. ln_dyninc .OR. & !-------------------------------------- + & ln_sshinc .OR. ln_seaiceinc ) THEN ! Read the increments from file + ! !-------------------------------------- + CALL iom_open( c_asminc, inum ) + ! + CALL iom_get( inum, 'time' , zdate_inc ) + CALL iom_get( inum, 'z_inc_dateb', z_inc_dateb ) + CALL iom_get( inum, 'z_inc_datef', z_inc_datef ) + z_inc_dateb = zdate_inc + z_inc_datef = zdate_inc + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'asm_inc_init : Assimilation increments valid between dates ', z_inc_dateb,' and ', z_inc_datef + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + IF ( ( z_inc_dateb < ndastp + nn_time0*0.0001_wp ) .OR. & + & ( z_inc_datef > ditend_date ) ) & + & CALL ctl_warn( ' Validity time of assimilation increments is ', & + & ' outside the assimilation interval' ) + + IF ( ( ln_asmdin ).AND.( zdate_inc /= ditdin_date ) ) & + & CALL ctl_warn( ' Validity time of assimilation increments does ', & + & ' not agree with Direct Initialization time' ) + + IF ( ln_trainc ) THEN + CALL iom_get( inum, jpdom_auto, 'bckint', t_bkginc, 1 ) + CALL iom_get( inum, jpdom_auto, 'bckins', s_bkginc, 1 ) + ! Apply the masks + t_bkginc(:,:,:) = t_bkginc(:,:,:) * tmask(:,:,:) + s_bkginc(:,:,:) = s_bkginc(:,:,:) * tmask(:,:,:) + ! Set missing increments to 0.0 rather than 1e+20 + ! to allow for differences in masks + WHERE( ABS( t_bkginc(:,:,:) ) > 1.0e+10 ) t_bkginc(:,:,:) = 0.0 + WHERE( ABS( s_bkginc(:,:,:) ) > 1.0e+10 ) s_bkginc(:,:,:) = 0.0 + ENDIF + + IF ( ln_dyninc ) THEN + CALL iom_get( inum, jpdom_auto, 'bckinu', u_bkginc, 1 ) + CALL iom_get( inum, jpdom_auto, 'bckinv', v_bkginc, 1 ) + ! Apply the masks + u_bkginc(:,:,:) = u_bkginc(:,:,:) * umask(:,:,:) + v_bkginc(:,:,:) = v_bkginc(:,:,:) * vmask(:,:,:) + ! Set missing increments to 0.0 rather than 1e+20 + ! to allow for differences in masks + WHERE( ABS( u_bkginc(:,:,:) ) > 1.0e+10 ) u_bkginc(:,:,:) = 0.0 + WHERE( ABS( v_bkginc(:,:,:) ) > 1.0e+10 ) v_bkginc(:,:,:) = 0.0 + ENDIF + + IF ( ln_sshinc ) THEN + CALL iom_get( inum, jpdom_auto, 'bckineta', ssh_bkginc, 1 ) + ! Apply the masks + ssh_bkginc(:,:) = ssh_bkginc(:,:) * tmask(:,:,1) + ! Set missing increments to 0.0 rather than 1e+20 + ! to allow for differences in masks + WHERE( ABS( ssh_bkginc(:,:) ) > 1.0e+10 ) ssh_bkginc(:,:) = 0.0 + ENDIF + + IF ( ln_seaiceinc ) THEN + CALL iom_get( inum, jpdom_auto, 'bckinseaice', seaice_bkginc, 1 ) + ! Apply the masks + seaice_bkginc(:,:) = seaice_bkginc(:,:) * tmask(:,:,1) + ! Set missing increments to 0.0 rather than 1e+20 + ! to allow for differences in masks + WHERE( ABS( seaice_bkginc(:,:) ) > 1.0e+10 ) seaice_bkginc(:,:) = 0.0 + ENDIF + ! + CALL iom_close( inum ) + ! + ENDIF + ! + ! !-------------------------------------- + IF ( ln_dyninc .AND. nn_divdmp > 0 ) THEN ! Apply divergence damping filter + ! !-------------------------------------- + ALLOCATE( zhdiv(jpi,jpj) ) + ! + DO jt = 1, nn_divdmp + ! + DO jk = 1, jpkm1 ! zhdiv = e1e1 * div + zhdiv(:,:) = 0._wp + DO_2D( 0, 0, 0, 0 ) + zhdiv(ji,jj) = ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * u_bkginc(ji ,jj,jk) & + & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * u_bkginc(ji-1,jj,jk) & + & + e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * v_bkginc(ji,jj ,jk) & + & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * v_bkginc(ji,jj-1,jk) ) & + & / e3t(ji,jj,jk,Kmm) + END_2D + CALL lbc_lnk( 'asminc', zhdiv, 'T', 1.0_wp ) ! lateral boundary cond. (no sign change) + ! + DO_2D( 0, 0, 0, 0 ) + u_bkginc(ji,jj,jk) = u_bkginc(ji,jj,jk) & + & + 0.2_wp * ( zhdiv(ji+1,jj) - zhdiv(ji ,jj) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) + v_bkginc(ji,jj,jk) = v_bkginc(ji,jj,jk) & + & + 0.2_wp * ( zhdiv(ji,jj+1) - zhdiv(ji,jj ) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) + END_2D + END DO + ! + END DO + ! + DEALLOCATE( zhdiv ) + ! + ENDIF + ! + ! !----------------------------------------------------- + IF ( ln_asmdin ) THEN ! Allocate and initialize the background state arrays + ! !----------------------------------------------------- + ! + ALLOCATE( t_bkg (jpi,jpj,jpk) ) ; t_bkg (:,:,:) = 0._wp + ALLOCATE( s_bkg (jpi,jpj,jpk) ) ; s_bkg (:,:,:) = 0._wp + ALLOCATE( u_bkg (jpi,jpj,jpk) ) ; u_bkg (:,:,:) = 0._wp + ALLOCATE( v_bkg (jpi,jpj,jpk) ) ; v_bkg (:,:,:) = 0._wp + ALLOCATE( ssh_bkg(jpi,jpj) ) ; ssh_bkg(:,:) = 0._wp + ! + ! + !-------------------------------------------------------------------- + ! Read from file the background state at analysis time + !-------------------------------------------------------------------- + ! + CALL iom_open( c_asmdin, inum ) + ! + CALL iom_get( inum, 'rdastp', zdate_bkg ) + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ==>>> Assimilation background state valid at : ', zdate_bkg + WRITE(numout,*) + ENDIF + ! + IF ( zdate_bkg /= ditdin_date ) & + & CALL ctl_warn( ' Validity time of assimilation background state does', & + & ' not agree with Direct Initialization time' ) + ! + IF ( ln_trainc ) THEN + CALL iom_get( inum, jpdom_auto, 'tn', t_bkg ) + CALL iom_get( inum, jpdom_auto, 'sn', s_bkg ) + t_bkg(:,:,:) = t_bkg(:,:,:) * tmask(:,:,:) + s_bkg(:,:,:) = s_bkg(:,:,:) * tmask(:,:,:) + ENDIF + ! + IF ( ln_dyninc ) THEN + CALL iom_get( inum, jpdom_auto, 'un', u_bkg, cd_type = 'U', psgn = 1._dp ) + CALL iom_get( inum, jpdom_auto, 'vn', v_bkg, cd_type = 'V', psgn = 1._dp ) + u_bkg(:,:,:) = u_bkg(:,:,:) * umask(:,:,:) + v_bkg(:,:,:) = v_bkg(:,:,:) * vmask(:,:,:) + ENDIF + ! + IF ( ln_sshinc ) THEN + CALL iom_get( inum, jpdom_auto, 'sshn', ssh_bkg ) + ssh_bkg(:,:) = ssh_bkg(:,:) * tmask(:,:,1) + ENDIF + ! + CALL iom_close( inum ) + ! + ENDIF + ! + IF(lwp) WRITE(numout,*) ' ==>>> Euler time step switch is ', l_1st_euler + ! + IF( lk_asminc ) THEN !== data assimilation ==! + IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1, Kmm ) ! Output background fields + IF( ln_asmdin ) THEN ! Direct initialization + IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1, Kbb, Kmm, ts , Krhs ) ! Tracers + IF( ln_dyninc ) CALL dyn_asm_inc( nit000 - 1, Kbb, Kmm, uu, vv, Krhs ) ! Dynamics + IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1, Kbb, Kmm ) ! SSH + ENDIF + ENDIF + ! + END SUBROUTINE asm_inc_init + + + SUBROUTINE tra_asm_inc( kt, Kbb, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_asm_inc *** + !! + !! ** Purpose : Apply the tracer (T and S) assimilation increments + !! + !! ** Method : Direct initialization or Incremental Analysis Updating + !! + !! ** Action : + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! Current time step + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! Time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk + INTEGER :: it + REAL(wp) :: zincwgt ! IAU weight for current time step + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: fzptnz ! 3d freezing point values + !!---------------------------------------------------------------------- + ! + ! freezing point calculation taken from oc_fz_pt (but calculated for all depths) + ! used to prevent the applied increments taking the temperature below the local freezing point + IF( ln_temnofreeze ) THEN + DO jk = 1, jpkm1 + CALL eos_fzp( CASTSP(pts(:,:,jk,jp_sal,Kmm)), fzptnz(:,:,jk), gdept(:,:,jk,Kmm) ) + END DO + ENDIF + ! + ! !-------------------------------------- + IF ( ln_asmiau ) THEN ! Incremental Analysis Updating + ! !-------------------------------------- + ! + IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN + ! + it = kt - nit000 + 1 + zincwgt = wgtiau(it) / rn_Dt ! IAU weight for the current time step + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! Update the tracer tendencies + DO jk = 1, jpkm1 + IF (ln_temnofreeze) THEN + ! Do not apply negative increments if the temperature will fall below freezing + WHERE(t_bkginc(A2D(0),jk) > 0.0_wp .OR. & + & pts(A2D(0),jk,jp_tem,Kmm) + pts(A2D(0),jk,jp_tem,Krhs) + t_bkginc(A2D(0),jk) * wgtiau(it) > fzptnz(:,:,jk) ) + pts(A2D(0),jk,jp_tem,Krhs) = pts(A2D(0),jk,jp_tem,Krhs) + t_bkginc(A2D(0),jk) * zincwgt + END WHERE + ELSE + DO_2D( 0, 0, 0, 0 ) + pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) + t_bkginc(ji,jj,jk) * zincwgt + END_2D + ENDIF + IF (ln_salfix) THEN + ! Do not apply negative increments if the salinity will fall below a specified + ! minimum value salfixmin + WHERE(s_bkginc(A2D(0),jk) > 0.0_wp .OR. & + & pts(A2D(0),jk,jp_sal,Kmm) + pts(A2D(0),jk,jp_sal,Krhs) + s_bkginc(A2D(0),jk) * wgtiau(it) > salfixmin ) + pts(A2D(0),jk,jp_sal,Krhs) = pts(A2D(0),jk,jp_sal,Krhs) + s_bkginc(A2D(0),jk) * zincwgt + END WHERE + ELSE + DO_2D( 0, 0, 0, 0 ) + pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) + s_bkginc(ji,jj,jk) * zincwgt + END_2D + ENDIF + END DO + ! + ENDIF + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF ( kt == nitiaufin_r + 1 ) THEN ! For bias crcn to work + DEALLOCATE( t_bkginc ) + DEALLOCATE( s_bkginc ) + ENDIF + ENDIF + ! !-------------------------------------- + ELSEIF ( ln_asmdin ) THEN ! Direct Initialization + ! !-------------------------------------- + ! + IF ( kt == nitdin_r ) THEN + ! + l_1st_euler = .TRUE. ! Force Euler forward step + ! + ! Initialize the now fields with the background + increment + IF (ln_temnofreeze) THEN + ! Do not apply negative increments if the temperature will fall below freezing + WHERE( t_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_tem,Kmm) + t_bkginc(:,:,:) > fzptnz(:,:,:) ) + pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:) + END WHERE + ELSE + pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:) + ENDIF + IF (ln_salfix) THEN + ! Do not apply negative increments if the salinity will fall below a specified + ! minimum value salfixmin + WHERE( s_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_sal,Kmm) + s_bkginc(:,:,:) > salfixmin ) + pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:) + END WHERE + ELSE + pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:) + ENDIF + + pts(:,:,:,:,Kbb) = pts(:,:,:,:,Kmm) ! Update before fields + + CALL eos( pts(:,:,:,:,Kbb), rhd, rhop, gdept_0(:,:,:) ) ! Before potential and in situ densities +!!gm fabien +! CALL eos( pts(:,:,:,:,Kbb), rhd, rhop ) ! Before potential and in situ densities +!!gm + + IF( ln_zps .AND. .NOT. ln_c1d .AND. .NOT. ln_isfcav) & + & CALL zps_hde ( kt, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, & ! Partial steps: before horizontal gradient + & rhd, gru , grv ) ! of t, s, rd at the last ocean level + IF( ln_zps .AND. .NOT. ln_c1d .AND. ln_isfcav) & + & CALL zps_hde_isf( nit000, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF) + & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the last ocean level + + DEALLOCATE( t_bkginc ) + DEALLOCATE( s_bkginc ) + DEALLOCATE( t_bkg ) + DEALLOCATE( s_bkg ) + ENDIF + ! + ENDIF + ! Perhaps the following call should be in step + IF ( ln_seaiceinc ) CALL seaice_asm_inc ( kt ) ! apply sea ice concentration increment + ! + END SUBROUTINE tra_asm_inc + + + SUBROUTINE dyn_asm_inc( kt, Kbb, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_asm_inc *** + !! + !! ** Purpose : Apply the dynamics (u and v) assimilation increments. + !! + !! ** Method : Direct initialization or Incremental Analysis Updating. + !! + !! ** Action : + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk + INTEGER :: it + REAL(wp) :: zincwgt ! IAU weight for current time step + !!---------------------------------------------------------------------- + ! + ! !-------------------------------------------- + IF ( ln_asmiau ) THEN ! Incremental Analysis Updating + ! !-------------------------------------------- + ! + IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN + ! + it = kt - nit000 + 1 + zincwgt = wgtiau(it) / rn_Dt ! IAU weight for the current time step + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_asm_inc : Dynamics IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! Update the dynamic tendencies + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + u_bkginc(ji,jj,jk) * zincwgt + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + v_bkginc(ji,jj,jk) * zincwgt + END_3D + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF ( kt == nitiaufin_r ) THEN + DEALLOCATE( u_bkginc ) + DEALLOCATE( v_bkginc ) + ENDIF + ENDIF + ! + ENDIF + ! !----------------------------------------- + ELSEIF ( ln_asmdin ) THEN ! Direct Initialization + ! !----------------------------------------- + ! + IF ( kt == nitdin_r ) THEN + ! + l_1st_euler = .TRUE. ! Force Euler forward step + ! + ! Initialize the now fields with the background + increment + puu(:,:,:,Kmm) = u_bkg(:,:,:) + u_bkginc(:,:,:) + pvv(:,:,:,Kmm) = v_bkg(:,:,:) + v_bkginc(:,:,:) + ! + puu(:,:,:,Kbb) = puu(:,:,:,Kmm) ! Update before fields + pvv(:,:,:,Kbb) = pvv(:,:,:,Kmm) + ! + DEALLOCATE( u_bkg ) + DEALLOCATE( v_bkg ) + DEALLOCATE( u_bkginc ) + DEALLOCATE( v_bkginc ) + ENDIF + ! + ENDIF + ! + END SUBROUTINE dyn_asm_inc + + + SUBROUTINE ssh_asm_inc( kt, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ssh_asm_inc *** + !! + !! ** Purpose : Apply the sea surface height assimilation increment. + !! + !! ** Method : Direct initialization or Incremental Analysis Updating. + !! + !! ** Action : + !!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: kt ! Current time step + INTEGER, INTENT(IN) :: Kbb, Kmm ! Current time step + ! + INTEGER :: it + INTEGER :: ji, jj, jk + REAL(wp) :: zincwgt ! IAU weight for current time step + !!---------------------------------------------------------------------- + ! + ! !----------------------------------------- + IF ( ln_asmiau ) THEN ! Incremental Analysis Updating + ! !----------------------------------------- + ! + IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN + ! + it = kt - nit000 + 1 + zincwgt = wgtiau(it) / rn_Dt ! IAU weight for the current time step + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'ssh_asm_inc : SSH IAU at time step = ', & + & kt,' with IAU weight = ', wgtiau(it) + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! Save the tendency associated with the IAU weighted SSH increment + ! (applied in dynspg.*) +#if defined key_asminc + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + ssh_iau(ji,jj) = ssh_bkginc(ji,jj) * zincwgt + END_2D +#endif + ! + ELSE IF( kt == nitiaufin_r+1 ) THEN + ! + ! test on ssh_bkginc needed as ssh_asm_inc is called twice by time step + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF (ALLOCATED(ssh_bkginc)) DEALLOCATE( ssh_bkginc ) + ENDIF + ! +#if defined key_asminc + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + ssh_iau(ji,jj) = 0._wp + END_2D +#endif + ! + ENDIF + ! !----------------------------------------- + ELSEIF ( ln_asmdin ) THEN ! Direct Initialization + ! !----------------------------------------- + ! + IF ( kt == nitdin_r ) THEN + ! + l_1st_euler = .TRUE. ! Force Euler forward step + ! + ssh(:,:,Kmm) = ssh_bkg(:,:) + ssh_bkginc(:,:) ! Initialize the now fields the background + increment + ! + ssh(:,:,Kbb) = ssh(:,:,Kmm) ! Update before fields +#if ! defined key_qco + e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) +#endif +!!gm why not e3u(:,:,:,Kbb), e3v(:,:,:,Kbb), gdept(:,:,:,Kbb) ???? + ! + DEALLOCATE( ssh_bkg ) + DEALLOCATE( ssh_bkginc ) + ! + ENDIF + ! + ENDIF + ! + END SUBROUTINE ssh_asm_inc + + + SUBROUTINE ssh_asm_div( kt, Kbb, Kmm, phdivn ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ssh_asm_div *** + !! + !! ** Purpose : ssh increment with z* is incorporated via a correction of the local divergence + !! across all the water column + !! + !! ** Method : + !! CAUTION : sshiau is positive (inflow) decreasing the + !! divergence and expressed in m/s + !! + !! ** Action : phdivn decreased by the ssh increment + !!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: kt ! ocean time-step index + INTEGER, INTENT(IN) :: Kbb, Kmm ! time level indices + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phdivn ! horizontal divergence + !! + INTEGER :: ji, jj, jk ! dummy loop index + REAL(wp), DIMENSION(:,:) , POINTER :: ztim ! local array + !!---------------------------------------------------------------------- + ! +#if defined key_asminc + CALL ssh_asm_inc( kt, Kbb, Kmm ) !== (calculate increments) + ! + IF( ln_linssh ) THEN + DO_2D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls ) + phdivn(ji,jj,1) = phdivn(ji,jj,1) - ssh_iau(ji,jj) / e3t(ji,jj,1,Kmm) * tmask(ji,jj,1) + END_2D + ELSE + ALLOCATE( ztim(A2D(nn_hls)) ) + DO_2D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls ) + ztim(ji,jj) = ssh_iau(ji,jj) / ( ht(ji,jj) + 1.0 - ssmask(ji,jj) ) + DO jk = 1, jpkm1 + phdivn(ji,jj,jk) = phdivn(ji,jj,jk) - ztim(ji,jj) * tmask(ji,jj,jk) + END DO + END_2D + ! + DEALLOCATE(ztim) + ENDIF +#endif + ! + END SUBROUTINE ssh_asm_div + + + SUBROUTINE seaice_asm_inc( kt, kindic ) + !!---------------------------------------------------------------------- + !! *** ROUTINE seaice_asm_inc *** + !! + !! ** Purpose : Apply the sea ice assimilation increment. + !! + !! ** Method : Direct initialization or Incremental Analysis Updating. + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! Current time step + INTEGER, INTENT(in), OPTIONAL :: kindic ! flag for disabling the deallocation + ! + INTEGER :: ji, jj + INTEGER :: it + REAL(wp) :: zincwgt ! IAU weight for current time step +#if defined key_si3 + REAL(wp), DIMENSION(A2D(nn_hls)) :: zofrld, zohicif, zseaicendg, zhicifinc + REAL(wp) :: zhicifmin = 0.5_wp ! ice minimum depth in metres +#endif + !!---------------------------------------------------------------------- + ! + ! !----------------------------------------- + IF ( ln_asmiau ) THEN ! Incremental Analysis Updating + ! !----------------------------------------- + ! + IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN + ! + it = kt - nit000 + 1 + zincwgt = wgtiau(it) ! IAU weight for the current time step + ! note this is not a tendency so should not be divided by rn_Dt (as with the tracer and other increments) + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! Sea-ice : SI3 case + ! +#if defined key_si3 + DO_2D( 0, 0, 0, 0 ) + zofrld (ji,jj) = 1._wp - at_i(ji,jj) + zohicif(ji,jj) = hm_i(ji,jj) + ! + at_i (ji,jj) = 1. - MIN( MAX( 1.-at_i (ji,jj) - seaice_bkginc(ji,jj) * zincwgt, 0.0_wp), 1.0_wp) + at_i_b(ji,jj) = 1. - MIN( MAX( 1.-at_i_b(ji,jj) - seaice_bkginc(ji,jj) * zincwgt, 0.0_wp), 1.0_wp) + fr_i(ji,jj) = at_i(ji,jj) ! adjust ice fraction + ! + zseaicendg(ji,jj) = zofrld(ji,jj) - (1. - at_i(ji,jj)) ! find out actual sea ice nudge applied + END_2D + ! + ! Nudge sea ice depth to bring it up to a required minimum depth + WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(A2D(0)) < zhicifmin ) + zhicifinc(:,:) = (zhicifmin - hm_i(A2D(0))) * zincwgt + ELSEWHERE + zhicifinc(:,:) = 0.0_wp + END WHERE + ! + ! nudge ice depth + DO_2D( 0, 0, 0, 0 ) + hm_i (ji,jj) = hm_i (ji,jj) + zhicifinc(ji,jj) + END_2D + ! + ! seaice salinity balancing (to add) +#endif + ! +#if defined key_cice && defined key_asminc + ! Sea-ice : CICE case. Pass ice increment tendency into CICE + DO_2D( 0, 0, 0, 0 ) + ndaice_da(ji,jj) = seaice_bkginc(ji,jj) * zincwgt / rn_Dt + END_2D +#endif + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF ( kt == nitiaufin_r ) THEN + DEALLOCATE( seaice_bkginc ) + ENDIF + ENDIF + ! + ELSE + ! +#if defined key_cice && defined key_asminc + DO_2D( 0, 0, 0, 0 ) + ndaice_da(ji,jj) = 0._wp ! Sea-ice : CICE case. Zero ice increment tendency into CICE + END_2D +#endif + ! + ENDIF + ! !----------------------------------------- + ELSEIF ( ln_asmdin ) THEN ! Direct Initialization + ! !----------------------------------------- + ! + IF ( kt == nitdin_r ) THEN + ! + l_1st_euler = .TRUE. ! Force Euler forward step + ! + ! Sea-ice : SI3 case + ! +#if defined key_si3 + DO_2D( 0, 0, 0, 0 ) + zofrld (ji,jj) = 1._wp - at_i(ji,jj) + zohicif(ji,jj) = hm_i(ji,jj) + ! + ! Initialize the now fields the background + increment + at_i(ji,jj) = 1. - MIN( MAX( 1.-at_i(ji,jj) - seaice_bkginc(ji,jj), 0.0_wp), 1.0_wp) + at_i_b(ji,jj) = at_i(ji,jj) + fr_i(ji,jj) = at_i(ji,jj) ! adjust ice fraction + ! + zseaicendg(ji,jj) = zofrld(ji,jj) - (1. - at_i(ji,jj)) ! find out actual sea ice nudge applied + END_2D + ! + ! Nudge sea ice depth to bring it up to a required minimum depth + WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(A2D(0)) < zhicifmin ) + zhicifinc(:,:) = zhicifmin - hm_i(A2D(0)) + ELSEWHERE + zhicifinc(:,:) = 0.0_wp + END WHERE + ! + ! nudge ice depth + DO_2D( 0, 0, 0, 0 ) + hm_i(ji,jj) = hm_i (ji,jj) + zhicifinc(ji,jj) + END_2D + ! + ! seaice salinity balancing (to add) +#endif + ! +#if defined key_cice && defined key_asminc + ! Sea-ice : CICE case. Pass ice increment tendency into CICE + DO_2D( 0, 0, 0, 0 ) + ndaice_da(ji,jj) = seaice_bkginc(ji,jj) / rn_Dt + END_2D +#endif + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF ( .NOT. PRESENT(kindic) ) THEN + DEALLOCATE( seaice_bkginc ) + END IF + ENDIF + ! + ELSE + ! +#if defined key_cice && defined key_asminc + DO_2D( 0, 0, 0, 0 ) + ndaice_da(ji,jj) = 0._wp ! Sea-ice : CICE case. Zero ice increment tendency into CICE + END_2D +#endif + ! + ENDIF + +!#if defined defined key_si3 || defined key_cice +! +! IF (ln_seaicebal ) THEN +! !! balancing salinity increments +! !! simple case from limflx.F90 (doesn't include a mass flux) +! !! assumption is that as ice concentration is reduced or increased +! !! the snow and ice depths remain constant +! !! note that snow is being created where ice concentration is being increased +! !! - could be more sophisticated and +! !! not do this (but would need to alter h_snow) +! +! usave(:,:,:)=sb(:,:,:) ! use array as a temporary store +! +! DO jj = 1, jpj +! DO ji = 1, jpi +! ! calculate change in ice and snow mass per unit area +! ! positive values imply adding salt to the ocean (results from ice formation) +! ! fwf : ice formation and melting +! +! zfons = ( -nfresh_da(ji,jj)*soce + nfsalt_da(ji,jj) )*rn_Dt +! +! ! change salinity down to mixed layer depth +! mld=hmld_kara(ji,jj) +! +! ! prevent small mld +! ! less than 10m can cause salinity instability +! IF (mld < 10) mld=10 +! +! ! set to bottom of a level +! DO jk = jpk-1, 2, -1 +! IF ((mld > gdepw(ji,jj,jk,Kmm)) .and. (mld < gdepw(ji,jj,jk+1,Kmm))) THEN +! mld=gdepw(ji,jj,jk+1,Kmm) +! jkmax=jk +! ENDIF +! ENDDO +! +! ! avoid applying salinity balancing in shallow water or on land +! ! +! +! ! dsal_ocn (psu kg m^-2) / (kg m^-3 * m) +! +! dsal_ocn=0.0_wp +! sal_thresh=5.0_wp ! minimum salinity threshold for salinity balancing +! +! if (tmask(ji,jj,1) > 0 .AND. tmask(ji,jj,jkmax) > 0 ) & +! dsal_ocn = zfons / (rhop(ji,jj,1) * mld) +! +! ! put increments in for levels in the mixed layer +! ! but prevent salinity below a threshold value +! +! DO jk = 1, jkmax +! +! IF (dsal_ocn > 0.0_wp .or. sb(ji,jj,jk)+dsal_ocn > sal_thresh) THEN +! sb(ji,jj,jk) = sb(ji,jj,jk) + dsal_ocn +! sn(ji,jj,jk) = sn(ji,jj,jk) + dsal_ocn +! ENDIF +! +! ENDDO +! +! ! ! salt exchanges at the ice/ocean interface +! ! zpmess = zfons / rDt_ice ! rDt_ice is ice timestep +! ! +! !! Adjust fsalt. A +ve fsalt means adding salt to ocean +! !! fsalt(ji,jj) = fsalt(ji,jj) + zpmess ! adjust fsalt +! !! +! !! emps(ji,jj) = emps(ji,jj) + zpmess ! or adjust emps (see icestp1d) +! !! ! E-P (kg m-2 s-2) +! ! emp(ji,jj) = emp(ji,jj) + zpmess ! E-P (kg m-2 s-2) +! ENDDO !ji +! ENDDO !jj! +! +! ENDIF !ln_seaicebal +! +!#endif + ! + ENDIF + ! + END SUBROUTINE seaice_asm_inc + + !!====================================================================== +END MODULE asminc diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ASM/asmpar.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ASM/asmpar.F90 new file mode 100644 index 0000000..1a13a00 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ASM/asmpar.F90 @@ -0,0 +1,29 @@ +MODULE asmpar + !!====================================================================== + !! *** MODULE asmpar *** + !! Assimilation increment : Parameters for assimilation interface + !!====================================================================== + + IMPLICIT NONE + PRIVATE + + CHARACTER(LEN=40), PUBLIC, PARAMETER :: c_asmbkg = 'assim_background_state_Jb' !: Filename for storing the background state + ! ! for use in the Jb term + CHARACTER(LEN=40), PUBLIC, PARAMETER :: c_asmdin = 'assim_background_state_DI' !: Filename for storing the background state + ! ! for direct initialization + CHARACTER(LEN=40), PUBLIC, PARAMETER :: c_asmtrj = 'assim_trj' !: Filename for storing the reference trajectory + CHARACTER(LEN=40), PUBLIC, PARAMETER :: c_asminc = 'assim_background_increments' !: Filename for storing the increments + ! ! to the background state + + INTEGER, PUBLIC :: nitbkg_r !: Background time step referenced to nit000 + INTEGER, PUBLIC :: nitdin_r !: Direct Initialization time step referenced to nit000 + INTEGER, PUBLIC :: nitiaustr_r !: IAU starting time step referenced to nit000 + INTEGER, PUBLIC :: nitiaufin_r !: IAU final time step referenced to nit000 + INTEGER, PUBLIC :: nittrjfrq !: Frequency of trajectory output for 4D-VAR + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: asmpar.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE asmpar \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdy_oce.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdy_oce.F90 new file mode 100644 index 0000000..3cdd3a6 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdy_oce.F90 @@ -0,0 +1,175 @@ +MODULE bdy_oce + !!====================================================================== + !! *** MODULE bdy_oce *** + !! Unstructured Open Boundary Cond. : define related variables + !!====================================================================== + !! History : 1.0 ! 2001-05 (J. Chanut, A. Sellar) Original code + !! 3.0 ! 2008-04 (NEMO team) add in the reference version + !! 3.3 ! 2010-09 (D. Storkey) add ice boundary conditions + !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge + !! 3.6 ! 2014-01 (C. Rousset) add ice boundary conditions for new model + !! 4.0 ! 2018 (C. Rousset) SI3 compatibility + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + + IMPLICIT NONE + PUBLIC + + INTEGER, PUBLIC, PARAMETER :: jp_bdy = 10 !: Maximum number of bdy sets + INTEGER, PUBLIC, PARAMETER :: jpbgrd = 3 !: Number of horizontal grid types used (T, U, V) + + TYPE, PUBLIC :: OBC_INDEX !: Indices and weights which define the open boundary + INTEGER , DIMENSION(jpbgrd) :: nblen + INTEGER , DIMENSION(jpbgrd) :: nblenrim + INTEGER , DIMENSION(jpbgrd) :: nblenrim0 + INTEGER , POINTER, DIMENSION(:,:) :: nbi + INTEGER , POINTER, DIMENSION(:,:) :: nbj + INTEGER , POINTER, DIMENSION(:,:) :: nbr + INTEGER , POINTER, DIMENSION(:,:) :: nbmap + INTEGER , POINTER, DIMENSION(:,:) :: ntreat + REAL(wp), POINTER, DIMENSION(:,:) :: nbw + REAL(wp), POINTER, DIMENSION(:,:) :: nbd + REAL(wp), POINTER, DIMENSION(:,:) :: nbdout + REAL(wp), POINTER, DIMENSION(:,:) :: flagu + REAL(wp), POINTER, DIMENSION(:,:) :: flagv + END TYPE OBC_INDEX + + !! Logicals in OBC_DATA structure are true if the chosen algorithm requires this + !! field as external data. If true the data can come from external files + !! or model initial conditions. If false then no "external" data array + !! is required for this field. + + TYPE, PUBLIC :: OBC_DATA !: Storage for external data + INTEGER , DIMENSION(2) :: nread + LOGICAL :: lneed_ssh + LOGICAL :: lneed_dyn2d + LOGICAL :: lneed_dyn3d + LOGICAL :: lneed_tra + LOGICAL :: lneed_ice + REAL(wp), POINTER, DIMENSION(:) :: ssh + REAL(wp), POINTER, DIMENSION(:) :: u2d + REAL(wp), POINTER, DIMENSION(:) :: v2d + REAL(wp), POINTER, DIMENSION(:,:) :: u3d + REAL(wp), POINTER, DIMENSION(:,:) :: v3d + REAL(wp), POINTER, DIMENSION(:,:) :: tem + REAL(wp), POINTER, DIMENSION(:,:) :: sal + REAL(wp), POINTER, DIMENSION(:,:) :: a_i !: now ice leads fraction climatology + REAL(wp), POINTER, DIMENSION(:,:) :: h_i !: Now ice thickness climatology + REAL(wp), POINTER, DIMENSION(:,:) :: h_s !: now snow thickness + REAL(wp), POINTER, DIMENSION(:,:) :: t_i !: now ice temperature + REAL(wp), POINTER, DIMENSION(:,:) :: t_s !: now snow temperature + REAL(wp), POINTER, DIMENSION(:,:) :: tsu !: now surf temperature + REAL(wp), POINTER, DIMENSION(:,:) :: s_i !: now ice salinity + REAL(wp), POINTER, DIMENSION(:,:) :: aip !: now ice pond concentration + REAL(wp), POINTER, DIMENSION(:,:) :: hip !: now ice pond depth + REAL(wp), POINTER, DIMENSION(:,:) :: hil !: now ice pond lid depth +#if defined key_top + CHARACTER(LEN=20) :: cn_obc !: type of boundary condition to apply + REAL(wp) :: rn_fac !: multiplicative scaling factor + REAL(wp), POINTER, DIMENSION(:,:) :: trc !: now field of the tracer + LOGICAL :: dmp !: obc damping term +#endif + END TYPE OBC_DATA + + !!---------------------------------------------------------------------- + !! Namelist variables + !!---------------------------------------------------------------------- + ! !!** nambdy ** + LOGICAL, PUBLIC :: ln_bdy !: Unstructured Ocean Boundary Condition + + CHARACTER(len=80), DIMENSION(jp_bdy) :: cn_coords_file !: Name of bdy coordinates file + CHARACTER(len=80) :: cn_mask_file !: Name of bdy mask file + ! + LOGICAL, DIMENSION(jp_bdy) :: ln_coords_file !: =T read bdy coordinates from file; + ! !: =F read bdy coordinates from namelist + LOGICAL :: ln_mask_file !: =T read bdymask from file + LOGICAL :: ln_vol !: =T volume correction + ! + INTEGER :: nb_bdy !: number of open boundary sets + INTEGER, DIMENSION(jp_bdy) :: nn_rimwidth !: boundary rim width for Flow Relaxation Scheme + INTEGER :: nn_volctl !: = 0 the total volume will have the variability of the surface Flux E-P + ! ! = 1 the volume will be constant during all the integration. + CHARACTER(len=20), DIMENSION(jp_bdy) :: cn_dyn2d ! Choice of boundary condition for barotropic variables (U,V,SSH) + INTEGER, DIMENSION(jp_bdy) :: nn_dyn2d_dta !: = 0 use the initial state as bdy dta ; + !: = 1 read it in a NetCDF file + !: = 2 read tidal harmonic forcing from a NetCDF file + !: = 3 read external data AND tidal harmonic forcing from NetCDF files + CHARACTER(len=20), DIMENSION(jp_bdy) :: cn_dyn3d ! Choice of boundary condition for baroclinic velocities + INTEGER, DIMENSION(jp_bdy) :: nn_dyn3d_dta !: = 0 use the initial state as bdy dta ; + !: = 1 read it in a NetCDF file + CHARACTER(len=20), DIMENSION(jp_bdy) :: cn_tra ! Choice of boundary condition for active tracers (T and S) + INTEGER, DIMENSION(jp_bdy) :: nn_tra_dta !: = 0 use the initial state as bdy dta ; + !: = 1 read it in a NetCDF file + LOGICAL , DIMENSION(jp_bdy) :: ln_tra_dmp !: =T Tracer damping + LOGICAL , DIMENSION(jp_bdy) :: ln_dyn3d_dmp !: =T Baroclinic velocity damping + REAL(wp), DIMENSION(jp_bdy) :: rn_time_dmp !: Damping time scale in days + REAL(wp), DIMENSION(jp_bdy) :: rn_time_dmp_out !: Damping time scale in days at radiation outflow points + + CHARACTER(len=20), DIMENSION(jp_bdy) :: cn_ice ! Choice of boundary condition for sea ice variables + INTEGER , DIMENSION(jp_bdy) :: nn_ice_dta !: = 0 use the initial state as bdy dta ; + !: = 1 read it in a NetCDF file + ! + ! !!** nambdy_dta ** + REAL(wp), DIMENSION(jp_bdy) :: rice_tem !: temperature of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_sal !: salinity of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_age !: age of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_apnd !: pond conc. of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_hpnd !: pond thick. of incoming sea ice + REAL(wp), DIMENSION(jp_bdy) :: rice_hlid !: pond lid thick. of incoming sea ice + ! + !!---------------------------------------------------------------------- + !! Global variables + !!---------------------------------------------------------------------- + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdytmask !: Mask defining computational domain at T-points + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdyumask !: Mask defining computational domain at U-points + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdyvmask !: Mask defining computational domain at V-points + + REAL(wp) :: bdysurftot !: Lateral surface of unstructured open boundary + + !!---------------------------------------------------------------------- + !! open boundary data variables + !!---------------------------------------------------------------------- + + INTEGER, DIMENSION(jp_bdy) :: nn_dta !: =0 => *all* data is set to initial conditions + !: =1 => some data to be read in from data files +!$AGRIF_DO_NOT_TREAT + TYPE(OBC_INDEX), DIMENSION(jp_bdy), TARGET :: idx_bdy !: bdy indices (local process) + TYPE(OBC_DATA) , DIMENSION(jp_bdy), TARGET :: dta_bdy !: bdy external data (local process) +!$AGRIF_END_DO_NOT_TREAT + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdyolr !: mark needed communication for given boundary, grid and neighbour + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdyolr !: when searching in any direction (only for orlansky) + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdyint !: mark needed communication for given boundary, grid and neighbour + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdyint !: when searching towards the interior of the computational domain + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdyext !: mark needed communication for given boundary, grid and neighbour + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdyext !: when searching towards the exterior of the computational domain + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdy_oce.F90 15354 2021-10-12 13:44:46Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + FUNCTION bdy_oce_alloc() + !!---------------------------------------------------------------------- + USE lib_mpp, ONLY: ctl_stop, mpp_sum + ! + INTEGER :: bdy_oce_alloc + !!---------------------------------------------------------------------- + ! + ALLOCATE( bdytmask(jpi,jpj) , bdyumask(jpi,jpj), bdyvmask(jpi,jpj), & + & STAT=bdy_oce_alloc ) + ! + ! Initialize masks + bdytmask(:,:) = 1._wp + bdyumask(:,:) = 1._wp + bdyvmask(:,:) = 1._wp + ! + CALL mpp_sum ( 'bdy_oce', bdy_oce_alloc ) + IF( bdy_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'bdy_oce_alloc: failed to allocate arrays.' ) + ! + END FUNCTION bdy_oce_alloc + + !!====================================================================== +END MODULE bdy_oce \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydta.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydta.F90 new file mode 100644 index 0000000..354822f --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydta.F90 @@ -0,0 +1,729 @@ +MODULE bdydta + !!====================================================================== + !! *** MODULE bdydta *** + !! Open boundary data : read the data for the unstructured open boundaries. + !!====================================================================== + !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code + !! - ! 2007-01 (D. Storkey) Update to use IOM module + !! - ! 2007-07 (D. Storkey) add bdy_dta_fla + !! 3.0 ! 2008-04 (NEMO team) add in the reference version + !! 3.3 ! 2010-09 (E.O'Dea) modifications for Shelf configurations + !! 3.3 ! 2010-09 (D.Storkey) add ice boundary conditions + !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge + !! 3.6 ! 2012-01 (C. Rousset) add ice boundary conditions for sea ice + !! 4.0 ! 2018 (C. Rousset) SI3 compatibility + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! bdy_dta : read external data along open boundaries from file + !! bdy_dta_init : initialise arrays etc for reading of external data + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbcapr ! atmospheric pressure forcing + USE tide_mod, ONLY: ln_tide ! tidal forcing + USE bdy_oce ! ocean open boundary conditions + USE bdytides ! tidal forcing at boundaries +#if defined key_si3 + USE ice ! sea-ice variables + USE icevar ! redistribute ice input into categories +#endif + ! + USE lib_mpp, ONLY: ctl_stop, ctl_nam + USE fldread ! read input fields + USE iom ! IOM library + USE in_out_manager ! I/O logical units + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_dta ! routine called by step.F90 and dynspg_ts.F90 + PUBLIC bdy_dta_init ! routine called by nemogcm.F90 + + INTEGER , PARAMETER :: jpbdyfld = 17 ! maximum number of files to read + INTEGER , PARAMETER :: jp_bdyssh = 1 ! + INTEGER , PARAMETER :: jp_bdyu2d = 2 ! + INTEGER , PARAMETER :: jp_bdyv2d = 3 ! + INTEGER , PARAMETER :: jp_bdyu3d = 4 ! + INTEGER , PARAMETER :: jp_bdyv3d = 5 ! + INTEGER , PARAMETER :: jp_bdytem = 6 ! + INTEGER , PARAMETER :: jp_bdysal = 7 ! + INTEGER , PARAMETER :: jp_bdya_i = 8 ! + INTEGER , PARAMETER :: jp_bdyh_i = 9 ! + INTEGER , PARAMETER :: jp_bdyh_s = 10 ! + INTEGER , PARAMETER :: jp_bdyt_i = 11 ! + INTEGER , PARAMETER :: jp_bdyt_s = 12 ! + INTEGER , PARAMETER :: jp_bdytsu = 13 ! + INTEGER , PARAMETER :: jp_bdys_i = 14 ! + INTEGER , PARAMETER :: jp_bdyaip = 15 ! + INTEGER , PARAMETER :: jp_bdyhip = 16 ! + INTEGER , PARAMETER :: jp_bdyhil = 17 ! +#if ! defined key_si3 + INTEGER , PARAMETER :: jpl = 1 +#endif + +!$AGRIF_DO_NOT_TREAT + TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:,:), TARGET :: bf ! structure of input fields (file informations, fields read) +!$AGRIF_END_DO_NOT_TREAT + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdydta.F90 15368 2021-10-14 08:25:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_dta( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dta *** + !! + !! ** Purpose : Update external data for open boundary conditions + !! + !! ** Method : Use fldread.F90 + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + INTEGER :: jbdy, jfld, jstart, jend, ib, jl ! dummy loop indices + INTEGER :: ii, ij, ik, igrd, ipl ! local integers + TYPE(OBC_DATA) , POINTER :: dta_alias ! short cut + TYPE(FLD), DIMENSION(:), POINTER :: bf_alias + !!--------------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('bdy_dta') + ! + ! Initialise data arrays once for all from initial conditions where required + !--------------------------------------------------------------------------- + IF( kt == nit000 ) THEN + + ! Calculate depth-mean currents + !----------------------------- + + DO jbdy = 1, nb_bdy + ! + IF( nn_dyn2d_dta(jbdy) == 0 ) THEN + IF( dta_bdy(jbdy)%lneed_ssh ) THEN + igrd = 1 + DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd) ! ssh is allocated and used only on the rim + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_bdy(jbdy)%ssh(ib) = ssh(ii,ij,Kmm) * tmask(ii,ij,1) + END DO + ENDIF + IF( ASSOCIATED(dta_bdy(jbdy)%u2d) ) THEN ! no SIZE with a unassociated pointer. v2d and u2d can differ on subdomain + igrd = 2 + DO ib = 1, SIZE(dta_bdy(jbdy)%u2d) ! u2d is used either over the whole bdy or only on the rim + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_bdy(jbdy)%u2d(ib) = uu_b(ii,ij,Kmm) * umask(ii,ij,1) + END DO + ENDIF + IF( ASSOCIATED(dta_bdy(jbdy)%v2d) ) THEN ! no SIZE with a unassociated pointer. v2d and u2d can differ on subdomain + igrd = 3 + DO ib = 1, SIZE(dta_bdy(jbdy)%v2d) ! v2d is used either over the whole bdy or only on the rim + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_bdy(jbdy)%v2d(ib) = vv_b(ii,ij,Kmm) * vmask(ii,ij,1) + END DO + ENDIF + ENDIF + ! + IF( nn_dyn3d_dta(jbdy) == 0 ) THEN + IF( dta_bdy(jbdy)%lneed_dyn3d ) THEN + igrd = 2 + DO ib = 1, idx_bdy(jbdy)%nblen(igrd) + DO ik = 1, jpkm1 + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_bdy(jbdy)%u3d(ib,ik) = ( uu(ii,ij,ik,Kmm) - uu_b(ii,ij,Kmm) ) * umask(ii,ij,ik) + END DO + END DO + igrd = 3 + DO ib = 1, idx_bdy(jbdy)%nblen(igrd) + DO ik = 1, jpkm1 + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_bdy(jbdy)%v3d(ib,ik) = ( vv(ii,ij,ik,Kmm) - vv_b(ii,ij,Kmm) ) * vmask(ii,ij,ik) + END DO + END DO + ENDIF + ENDIF + + IF( nn_tra_dta(jbdy) == 0 ) THEN + IF( dta_bdy(jbdy)%lneed_tra ) THEN + igrd = 1 + DO ib = 1, idx_bdy(jbdy)%nblen(igrd) + DO ik = 1, jpkm1 + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_bdy(jbdy)%tem(ib,ik) = ts(ii,ij,ik,jp_tem,Kmm) * tmask(ii,ij,ik) + dta_bdy(jbdy)%sal(ib,ik) = ts(ii,ij,ik,jp_sal,Kmm) * tmask(ii,ij,ik) + END DO + END DO + ENDIF + ENDIF + +#if defined key_si3 + IF( nn_ice_dta(jbdy) == 0 ) THEN ! set ice to initial values + IF( dta_bdy(jbdy)%lneed_ice ) THEN + igrd = 1 + DO jl = 1, jpl + DO ib = 1, idx_bdy(jbdy)%nblen(igrd) + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_bdy(jbdy)%a_i(ib,jl) = a_i (ii,ij,jl) * tmask(ii,ij,1) + dta_bdy(jbdy)%h_i(ib,jl) = h_i (ii,ij,jl) * tmask(ii,ij,1) + dta_bdy(jbdy)%h_s(ib,jl) = h_s (ii,ij,jl) * tmask(ii,ij,1) + dta_bdy(jbdy)%t_i(ib,jl) = SUM(t_i (ii,ij,:,jl)) * r1_nlay_i * tmask(ii,ij,1) + dta_bdy(jbdy)%t_s(ib,jl) = SUM(t_s (ii,ij,:,jl)) * r1_nlay_s * tmask(ii,ij,1) + dta_bdy(jbdy)%tsu(ib,jl) = t_su(ii,ij,jl) * tmask(ii,ij,1) + dta_bdy(jbdy)%s_i(ib,jl) = s_i (ii,ij,jl) * tmask(ii,ij,1) + ! melt ponds + dta_bdy(jbdy)%aip(ib,jl) = a_ip(ii,ij,jl) * tmask(ii,ij,1) + dta_bdy(jbdy)%hip(ib,jl) = h_ip(ii,ij,jl) * tmask(ii,ij,1) + dta_bdy(jbdy)%hil(ib,jl) = h_il(ii,ij,jl) * tmask(ii,ij,1) + END DO + END DO + ENDIF + ENDIF +#endif + END DO ! jbdy + ! + ENDIF ! kt == nit000 + + ! update external data from files + !-------------------------------- + + DO jbdy = 1, nb_bdy + + dta_alias => dta_bdy(jbdy) + bf_alias => bf(:,jbdy) + + ! read/update all bdy data + ! ------------------------ + ! BDY: use pt_offset=0.5 as applied at the end of the step and fldread is referenced at the middle of the step + CALL fld_read( kt, 1, bf_alias, pt_offset = 0.5_wp, Kmm = Kmm ) + ! apply some corrections in some specific cases... + ! -------------------------------------------------- + ! + ! if runoff condition: change river flow we read (in m3/s) into barotropic velocity (m/s) + IF( cn_tra(jbdy) == 'runoff' ) THEN ! runoff + ! + IF( ASSOCIATED(dta_bdy(jbdy)%u2d) ) THEN ! no SIZE with a unassociated pointer. v2d and u2d can differ on subdomain + igrd = 2 ! zonal flow (m3/s) to barotropic zonal velocity (m/s) + DO ib = 1, SIZE(dta_alias%u2d) ! u2d is used either over the whole bdy or only on the rim + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_alias%u2d(ib) = dta_alias%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) ) + END DO + ENDIF + IF( ASSOCIATED(dta_bdy(jbdy)%v2d) ) THEN ! no SIZE with a unassociated pointer. v2d and u2d can differ on subdomain + igrd = 3 ! meridional flow (m3/s) to barotropic meridional velocity (m/s) + DO ib = 1, SIZE(dta_alias%v2d) ! v2d is used either over the whole bdy or only on the rim + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_alias%v2d(ib) = dta_alias%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) ) + END DO + ENDIF + ENDIF + + ! tidal harmonic forcing ONLY: initialise arrays + IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! we did not read ssh, u/v2d + IF( ASSOCIATED(dta_alias%ssh) ) dta_alias%ssh(:) = 0._wp + IF( ASSOCIATED(dta_alias%u2d) ) dta_alias%u2d(:) = 0._wp + IF( ASSOCIATED(dta_alias%v2d) ) dta_alias%v2d(:) = 0._wp + ENDIF + + ! If full velocities in boundary data, then split it into barotropic and baroclinic component + IF( bf_alias(jp_bdyu3d)%ltotvel ) THEN ! if we read 3D total velocity (can be true only if u3d was read) + igrd = 2 ! zonal velocity + DO ib = 1, idx_bdy(jbdy)%nblen(igrd) + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_alias%u2d(ib) = 0._wp ! compute barotrope zonal velocity and put it in u2d + DO ik = 1, jpkm1 + dta_alias%u2d(ib) = dta_alias%u2d(ib) & + & + e3u(ii,ij,ik,Kmm) * umask(ii,ij,ik) * dta_alias%u3d(ib,ik) + END DO + dta_alias%u2d(ib) = dta_alias%u2d(ib) * r1_hu(ii,ij,Kmm) + DO ik = 1, jpkm1 ! compute barocline zonal velocity and put it in u3d + dta_alias%u3d(ib,ik) = dta_alias%u3d(ib,ik) - dta_alias%u2d(ib) + END DO + END DO + ENDIF ! ltotvel + IF( bf_alias(jp_bdyv3d)%ltotvel ) THEN ! if we read 3D total velocity (can be true only if v3d was read) + igrd = 3 ! meridional velocity + DO ib = 1, idx_bdy(jbdy)%nblen(igrd) + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_alias%v2d(ib) = 0._wp ! compute barotrope meridional velocity and put it in v2d + DO ik = 1, jpkm1 + dta_alias%v2d(ib) = dta_alias%v2d(ib) & + & + e3v(ii,ij,ik,Kmm) * vmask(ii,ij,ik) * dta_alias%v3d(ib,ik) + END DO + dta_alias%v2d(ib) = dta_alias%v2d(ib) * r1_hv(ii,ij,Kmm) + DO ik = 1, jpkm1 ! compute barocline meridional velocity and put it in v3d + dta_alias%v3d(ib,ik) = dta_alias%v3d(ib,ik) - dta_alias%v2d(ib) + END DO + END DO + ENDIF ! ltotvel + + ! atm surface pressure : add inverted barometer effect to ssh if it was read + IF ( ln_apr_obc .AND. TRIM(bf_alias(jp_bdyssh)%clrootname) /= 'NOT USED' ) THEN + igrd = 1 + DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd) ! ssh is used only on the rim + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_alias%ssh(ib) = dta_alias%ssh(ib) + ssh_ib(ii,ij) + END DO + ENDIF + +#if defined key_si3 + IF( dta_alias%lneed_ice .AND. idx_bdy(jbdy)%nblen(1) > 0 ) THEN + ! fill temperature and salinity arrays + IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyt_i)%fnow(:,1,:) = rice_tem (jbdy) + IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyt_s)%fnow(:,1,:) = rice_tem (jbdy) + IF( TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) bf_alias(jp_bdytsu)%fnow(:,1,:) = rice_tem (jbdy) + IF( TRIM(bf_alias(jp_bdys_i)%clrootname) == 'NOT USED' ) bf_alias(jp_bdys_i)%fnow(:,1,:) = rice_sal (jbdy) + IF( TRIM(bf_alias(jp_bdyaip)%clrootname) == 'NOT USED' ) & ! rice_apnd is the pond fraction + & bf_alias(jp_bdyaip)%fnow(:,1,:) = rice_apnd(jbdy) * bf_alias(jp_bdya_i)%fnow(:,1,:) ! ( a_ip = rice_apnd*a_i ) + IF( TRIM(bf_alias(jp_bdyhip)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyhip)%fnow(:,1,:) = rice_hpnd(jbdy) + IF( TRIM(bf_alias(jp_bdyhil)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyhil)%fnow(:,1,:) = rice_hlid(jbdy) + + ! if T_i is read and not T_su, set T_su = T_i + IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) & + & bf_alias(jp_bdytsu)%fnow(:,1,:) = bf_alias(jp_bdyt_i)%fnow(:,1,:) + ! if T_s is read and not T_su, set T_su = T_s + IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) & + & bf_alias(jp_bdytsu)%fnow(:,1,:) = bf_alias(jp_bdyt_s)%fnow(:,1,:) + ! if T_i is read and not T_s, set T_s = T_i + IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_s)%clrootname) == 'NOT USED' ) & + & bf_alias(jp_bdyt_s)%fnow(:,1,:) = bf_alias(jp_bdyt_i)%fnow(:,1,:) + ! if T_su is read and not T_s, set T_s = T_su + IF( TRIM(bf_alias(jp_bdytsu)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_s)%clrootname) == 'NOT USED' ) & + & bf_alias(jp_bdyt_s)%fnow(:,1,:) = bf_alias(jp_bdytsu)%fnow(:,1,:) + ! if T_su is read and not T_i, set T_i = (T_su + T_freeze)/2 + IF( TRIM(bf_alias(jp_bdytsu)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) & + & bf_alias(jp_bdyt_i)%fnow(:,1,:) = 0.5_wp * ( bf_alias(jp_bdytsu)%fnow(:,1,:) + 271.15 ) + ! if T_s is read and not T_i, set T_i = (T_s + T_freeze)/2 + IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) & + & bf_alias(jp_bdyt_i)%fnow(:,1,:) = 0.5_wp * ( bf_alias(jp_bdyt_s)%fnow(:,1,:) + 271.15 ) + + ! make sure ponds = 0 if no ponds scheme + IF ( .NOT.ln_pnd ) THEN + bf_alias(jp_bdyaip)%fnow(:,1,:) = 0._wp + bf_alias(jp_bdyhip)%fnow(:,1,:) = 0._wp + bf_alias(jp_bdyhil)%fnow(:,1,:) = 0._wp + ENDIF + IF ( .NOT.ln_pnd_lids ) THEN + bf_alias(jp_bdyhil)%fnow(:,1,:) = 0._wp + ENDIF + + ! convert N-cat fields (input) into jpl-cat (output) + ipl = SIZE(bf_alias(jp_bdya_i)%fnow, 3) + IF( ipl /= jpl ) THEN ! ice: convert N-cat fields (input) into jpl-cat (output) + CALL ice_var_itd( bf_alias(jp_bdyh_i)%fnow(:,1,:), bf_alias(jp_bdyh_s)%fnow(:,1,:), bf_alias(jp_bdya_i)%fnow(:,1,:), & ! in + & dta_alias%h_i , dta_alias%h_s , dta_alias%a_i , & ! out + & bf_alias(jp_bdyt_i)%fnow(:,1,:), bf_alias(jp_bdyt_s)%fnow(:,1,:), & ! in (optional) + & bf_alias(jp_bdytsu)%fnow(:,1,:), bf_alias(jp_bdys_i)%fnow(:,1,:), & ! in - + & bf_alias(jp_bdyaip)%fnow(:,1,:), bf_alias(jp_bdyhip)%fnow(:,1,:), bf_alias(jp_bdyhil)%fnow(:,1,:), & ! in - + & dta_alias%t_i , dta_alias%t_s , & ! out - + & dta_alias%tsu , dta_alias%s_i , & ! out - + & dta_alias%aip , dta_alias%hip , dta_alias%hil ) ! out - + ENDIF + ENDIF +#endif + END DO ! jbdy + + IF ( ln_tide ) THEN + IF (ln_dynspg_ts) THEN ! Fill temporary arrays with slow-varying bdy data + DO jbdy = 1, nb_bdy ! Tidal component added in ts loop + IF ( nn_dyn2d_dta(jbdy) .GE. 2 ) THEN + IF( ASSOCIATED(dta_bdy(jbdy)%ssh) ) dta_bdy_s(jbdy)%ssh(:) = dta_bdy(jbdy)%ssh(:) + IF( ASSOCIATED(dta_bdy(jbdy)%u2d) ) dta_bdy_s(jbdy)%u2d(:) = dta_bdy(jbdy)%u2d(:) + IF( ASSOCIATED(dta_bdy(jbdy)%v2d) ) dta_bdy_s(jbdy)%v2d(:) = dta_bdy(jbdy)%v2d(:) + ENDIF + END DO + ELSE ! Add tides if not split-explicit free surface else this is done in ts loop + ! + CALL bdy_dta_tides( kt=kt, pt_offset = 1._wp ) + ENDIF + ENDIF + ! + IF( ln_timing ) CALL timing_stop('bdy_dta') + ! + END SUBROUTINE bdy_dta + + + SUBROUTINE bdy_dta_init + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dta_init *** + !! + !! ** Purpose : Initialise arrays for reading of external data + !! for open boundary conditions + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER :: jbdy, jfld ! Local integers + INTEGER :: ierror, ios ! + ! + INTEGER :: nbdy_rdstart, nbdy_loc + CHARACTER(LEN=50) :: cerrmsg ! error string + CHARACTER(len=3) :: cl3 ! + CHARACTER(len=100) :: cn_dir ! Root directory for location of data files + LOGICAL :: ln_full_vel ! =T => full velocities in 3D boundary data + ! ! =F => baroclinic velocities in 3D boundary data + LOGICAL :: ln_zinterp ! =T => requires a vertical interpolation of the bdydta + REAL(wp) :: rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd, rn_ice_hlid + INTEGER :: ipk,ipl ! + INTEGER :: idvar ! variable ID + INTEGER :: indims ! number of dimensions of the variable + INTEGER :: iszdim ! number of dimensions of the variable + INTEGER, DIMENSION(4) :: i4dimsz ! size of variable dimensions + INTEGER :: igrd ! index for grid type (1,2,3 = T,U,V) + LOGICAL :: lluld ! is the variable using the unlimited dimension + LOGICAL :: llneed ! + LOGICAL :: llread ! + LOGICAL :: llfullbdy ! + TYPE(FLD_N), DIMENSION(1), TARGET :: bn_tem, bn_sal, bn_u3d, bn_v3d ! must be an array to be used with fld_fill + TYPE(FLD_N), DIMENSION(1), TARGET :: bn_ssh, bn_u2d, bn_v2d ! informations about the fields to be read + TYPE(FLD_N), DIMENSION(1), TARGET :: bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip, bn_hil + TYPE(FLD_N), DIMENSION(:), POINTER :: bn_alias ! must be an array to be used with fld_fill + TYPE(FLD ), DIMENSION(:), POINTER :: bf_alias + ! + NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d, & + & bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip, bn_hil, & + & rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd, rn_ice_hlid, & + & ln_full_vel, ln_zinterp + !!--------------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'bdy_dta_ini : initialization of data at the open boundaries' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + IF(lwp) WRITE(numout,*) '' + + ALLOCATE( bf(jpbdyfld,nb_bdy), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'bdy_dta: unable to allocate bf structure' ) ; RETURN + ENDIF + bf(:,:)%clrootname = 'NOT USED' ! default definition used as a flag in fld_read to do nothing. + bf(:,:)%lzint = .FALSE. ! default definition + bf(:,:)%ltotvel = .FALSE. ! default definition + + ! Read namelists + ! -------------- + nbdy_rdstart = 1 + DO jbdy = 1, nb_bdy + + WRITE(ctmp1, '(a,i2)') 'BDY number ', jbdy + WRITE(ctmp2, '(a,i2)') 'block nambdy_dta number ', jbdy + + ! There is only one nambdy_dta block in namelist_ref -> use it for each bdy so we read from the beginning + READ ( numnam_ref, nambdy_dta, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_dta in reference namelist' ) + + ! by-pass nambdy_dta reading if no input data used in this bdy + IF( ( dta_bdy(jbdy)%lneed_dyn2d .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 ) & + & .OR. ( dta_bdy(jbdy)%lneed_dyn3d .AND. nn_dyn3d_dta(jbdy) == 1 ) & + & .OR. ( dta_bdy(jbdy)%lneed_tra .AND. nn_tra_dta(jbdy) == 1 ) & + & .OR. ( dta_bdy(jbdy)%lneed_ice .AND. nn_ice_dta(jbdy) == 1 ) ) THEN + ! + ! Need to support possibility of reading more than one + ! nambdy_dta from the namelist_cfg internal file. + ! Do this by finding the jbdy'th occurence of nambdy_dta in the + ! character buffer as the starting point. + ! + nbdy_loc = INDEX( numnam_cfg( nbdy_rdstart: ), 'nambdy_dta' ) + IF( nbdy_loc .GT. 0 ) THEN + nbdy_rdstart = nbdy_rdstart + nbdy_loc + ELSE + WRITE(cerrmsg,'(A,I4,A)') 'Error: entry number ',jbdy,' of nambdy_dta not found' + ios = -1 + CALL ctl_nam ( ios , cerrmsg ) + ENDIF + READ ( numnam_cfg( MAX( 1, nbdy_rdstart - 2 ): ), nambdy_dta, IOSTAT = ios, ERR = 902) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy_dta in configuration namelist' ) + IF(lwm) WRITE( numond, nambdy_dta ) + ENDIF + + ! get the number of ice categories in bdy data file (use a_i information to do this) + ipl = jpl ! default definition + IF( dta_bdy(jbdy)%lneed_ice ) THEN ! if we need ice bdy data + IF( nn_ice_dta(jbdy) == 1 ) THEN ! if we get ice bdy data from netcdf file + CALL fld_fill( bf(jp_bdya_i,jbdy:jbdy), bn_a_i, cn_dir, 'bdy_dta', 'a_i'//' '//ctmp1, ctmp2 ) ! use namelist info + CALL fld_def( bf(jp_bdya_i,jbdy) ) + CALL iom_open( bf(jp_bdya_i,jbdy)%clname, bf(jp_bdya_i,jbdy)%num ) + idvar = iom_varid( bf(jp_bdya_i,jbdy)%num, bf(jp_bdya_i,jbdy)%clvar, kndims=indims, kdimsz=i4dimsz, lduld=lluld ) + IF( indims == 4 .OR. ( indims == 3 .AND. .NOT. lluld ) ) THEN ; ipl = i4dimsz(3) ! xylt or xyl + ELSE ; ipl = 1 ! xy or xyt + ENDIF + CALL iom_close( bf(jp_bdya_i,jbdy)%num ) + bf(jp_bdya_i,jbdy)%clrootname = 'NOT USED' ! reset to default value as this subdomain may not need to read this bdy + ENDIF + ENDIF + +#if defined key_si3 + IF( .NOT.ln_pnd ) THEN + rn_ice_apnd = 0. ; rn_ice_hpnd = 0. ; rn_ice_hlid = 0. + CALL ctl_warn( 'rn_ice_apnd & rn_ice_hpnd = 0 & rn_ice_hlid = 0 when no ponds' ) + ENDIF + IF( .NOT.ln_pnd_lids ) THEN + rn_ice_hlid = 0. + ENDIF +#endif + + ! temp, salt, age and ponds of incoming ice + rice_tem (jbdy) = rn_ice_tem + rice_sal (jbdy) = rn_ice_sal + rice_age (jbdy) = rn_ice_age + rice_apnd(jbdy) = rn_ice_apnd + rice_hpnd(jbdy) = rn_ice_hpnd + rice_hlid(jbdy) = rn_ice_hlid + + + DO jfld = 1, jpbdyfld + + ! ===================== + ! ssh + ! ===================== + IF( jfld == jp_bdyssh ) THEN + cl3 = 'ssh' + igrd = 1 ! T point + ipk = 1 ! surface data + llneed = dta_bdy(jbdy)%lneed_ssh ! dta_bdy(jbdy)%ssh will be needed + llread = MOD(nn_dyn2d_dta(jbdy),2) == 1 ! get data from NetCDF file + bf_alias => bf(jp_bdyssh,jbdy:jbdy) ! alias for ssh structure of bdy number jbdy + bn_alias => bn_ssh ! alias for ssh structure of nambdy_dta + iszdim = idx_bdy(jbdy)%nblenrim(igrd) ! length of this bdy on this MPI processus : used only on the rim + ENDIF + ! ===================== + ! dyn2d + ! ===================== + IF( jfld == jp_bdyu2d ) THEN + cl3 = 'u2d' + igrd = 2 ! U point + ipk = 1 ! surface data + llneed = dta_bdy(jbdy)%lneed_dyn2d ! dta_bdy(jbdy)%u2d will be needed + llread = .NOT. ln_full_vel .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 ! don't get u2d from u3d and read NetCDF file + bf_alias => bf(jp_bdyu2d,jbdy:jbdy) ! alias for u2d structure of bdy number jbdy + bn_alias => bn_u2d ! alias for u2d structure of nambdy_dta + llfullbdy = ln_full_vel .OR. cn_dyn2d(jbdy) == 'frs' ! need u2d over the whole bdy or only over the rim? + IF( llfullbdy ) THEN ; iszdim = idx_bdy(jbdy)%nblen(igrd) + ELSE ; iszdim = idx_bdy(jbdy)%nblenrim(igrd) + ENDIF + ENDIF + IF( jfld == jp_bdyv2d ) THEN + cl3 = 'v2d' + igrd = 3 ! V point + ipk = 1 ! surface data + llneed = dta_bdy(jbdy)%lneed_dyn2d ! dta_bdy(jbdy)%v2d will be needed + llread = .NOT. ln_full_vel .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 ! don't get v2d from v3d and read NetCDF file + bf_alias => bf(jp_bdyv2d,jbdy:jbdy) ! alias for v2d structure of bdy number jbdy + bn_alias => bn_v2d ! alias for v2d structure of nambdy_dta + llfullbdy = ln_full_vel .OR. cn_dyn2d(jbdy) == 'frs' ! need v2d over the whole bdy or only over the rim? + IF( llfullbdy ) THEN ; iszdim = idx_bdy(jbdy)%nblen(igrd) + ELSE ; iszdim = idx_bdy(jbdy)%nblenrim(igrd) + ENDIF + ENDIF + ! ===================== + ! dyn3d + ! ===================== + IF( jfld == jp_bdyu3d ) THEN + cl3 = 'u3d' + igrd = 2 ! U point + ipk = jpk ! 3d data + llneed = dta_bdy(jbdy)%lneed_dyn3d .OR. & ! dta_bdy(jbdy)%u3d will be needed + & ( dta_bdy(jbdy)%lneed_dyn2d .AND. ln_full_vel ) ! u3d needed to compute u2d + llread = nn_dyn3d_dta(jbdy) == 1 ! get data from NetCDF file + bf_alias => bf(jp_bdyu3d,jbdy:jbdy) ! alias for u3d structure of bdy number jbdy + bn_alias => bn_u3d ! alias for u3d structure of nambdy_dta + iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus + ENDIF + IF( jfld == jp_bdyv3d ) THEN + cl3 = 'v3d' + igrd = 3 ! V point + ipk = jpk ! 3d data + llneed = dta_bdy(jbdy)%lneed_dyn3d .OR. & ! dta_bdy(jbdy)%v3d will be needed + & ( dta_bdy(jbdy)%lneed_dyn2d .AND. ln_full_vel ) ! v3d needed to compute v2d + llread = nn_dyn3d_dta(jbdy) == 1 ! get data from NetCDF file + bf_alias => bf(jp_bdyv3d,jbdy:jbdy) ! alias for v3d structure of bdy number jbdy + bn_alias => bn_v3d ! alias for v3d structure of nambdy_dta + iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus + ENDIF + + ! ===================== + ! tra + ! ===================== + IF( jfld == jp_bdytem ) THEN + cl3 = 'tem' + igrd = 1 ! T point + ipk = jpk ! 3d data + llneed = dta_bdy(jbdy)%lneed_tra ! dta_bdy(jbdy)%tem will be needed + llread = nn_tra_dta(jbdy) == 1 ! get data from NetCDF file + bf_alias => bf(jp_bdytem,jbdy:jbdy) ! alias for ssh structure of bdy number jbdy + bn_alias => bn_tem ! alias for ssh structure of nambdy_dta + iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus + ENDIF + IF( jfld == jp_bdysal ) THEN + cl3 = 'sal' + igrd = 1 ! T point + ipk = jpk ! 3d data + llneed = dta_bdy(jbdy)%lneed_tra ! dta_bdy(jbdy)%sal will be needed + llread = nn_tra_dta(jbdy) == 1 ! get data from NetCDF file + bf_alias => bf(jp_bdysal,jbdy:jbdy) ! alias for ssh structure of bdy number jbdy + bn_alias => bn_sal ! alias for ssh structure of nambdy_dta + iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus + ENDIF + + ! ===================== + ! ice + ! ===================== + IF( jfld == jp_bdya_i .OR. jfld == jp_bdyh_i .OR. jfld == jp_bdyh_s .OR. & + & jfld == jp_bdyt_i .OR. jfld == jp_bdyt_s .OR. jfld == jp_bdytsu .OR. & + & jfld == jp_bdys_i .OR. jfld == jp_bdyaip .OR. jfld == jp_bdyhip .OR. jfld == jp_bdyhil ) THEN + igrd = 1 ! T point + ipk = ipl ! jpl-cat data + llneed = dta_bdy(jbdy)%lneed_ice ! ice will be needed + llread = nn_ice_dta(jbdy) == 1 ! get data from NetCDF file + iszdim = idx_bdy(jbdy)%nblen(igrd) ! length of this bdy on this MPI processus + ENDIF + IF( jfld == jp_bdya_i ) THEN + cl3 = 'a_i' + bf_alias => bf(jp_bdya_i,jbdy:jbdy) ! alias for a_i structure of bdy number jbdy + bn_alias => bn_a_i ! alias for a_i structure of nambdy_dta + ENDIF + IF( jfld == jp_bdyh_i ) THEN + cl3 = 'h_i' + bf_alias => bf(jp_bdyh_i,jbdy:jbdy) ! alias for h_i structure of bdy number jbdy + bn_alias => bn_h_i ! alias for h_i structure of nambdy_dta + ENDIF + IF( jfld == jp_bdyh_s ) THEN + cl3 = 'h_s' + bf_alias => bf(jp_bdyh_s,jbdy:jbdy) ! alias for h_s structure of bdy number jbdy + bn_alias => bn_h_s ! alias for h_s structure of nambdy_dta + ENDIF + IF( jfld == jp_bdyt_i ) THEN + cl3 = 't_i' + bf_alias => bf(jp_bdyt_i,jbdy:jbdy) ! alias for t_i structure of bdy number jbdy + bn_alias => bn_t_i ! alias for t_i structure of nambdy_dta + ENDIF + IF( jfld == jp_bdyt_s ) THEN + cl3 = 't_s' + bf_alias => bf(jp_bdyt_s,jbdy:jbdy) ! alias for t_s structure of bdy number jbdy + bn_alias => bn_t_s ! alias for t_s structure of nambdy_dta + ENDIF + IF( jfld == jp_bdytsu ) THEN + cl3 = 'tsu' + bf_alias => bf(jp_bdytsu,jbdy:jbdy) ! alias for tsu structure of bdy number jbdy + bn_alias => bn_tsu ! alias for tsu structure of nambdy_dta + ENDIF + IF( jfld == jp_bdys_i ) THEN + cl3 = 's_i' + bf_alias => bf(jp_bdys_i,jbdy:jbdy) ! alias for s_i structure of bdy number jbdy + bn_alias => bn_s_i ! alias for s_i structure of nambdy_dta + ENDIF + IF( jfld == jp_bdyaip ) THEN + cl3 = 'aip' + bf_alias => bf(jp_bdyaip,jbdy:jbdy) ! alias for aip structure of bdy number jbdy + bn_alias => bn_aip ! alias for aip structure of nambdy_dta + ENDIF + IF( jfld == jp_bdyhip ) THEN + cl3 = 'hip' + bf_alias => bf(jp_bdyhip,jbdy:jbdy) ! alias for hip structure of bdy number jbdy + bn_alias => bn_hip ! alias for hip structure of nambdy_dta + ENDIF + IF( jfld == jp_bdyhil ) THEN + cl3 = 'hil' + bf_alias => bf(jp_bdyhil,jbdy:jbdy) ! alias for hil structure of bdy number jbdy + bn_alias => bn_hil ! alias for hil structure of nambdy_dta + ENDIF + + IF( llneed .AND. iszdim > 0 ) THEN ! dta_bdy(jbdy)%xxx will be needed + ! ! -> must be associated with an allocated target + ALLOCATE( bf_alias(1)%fnow( iszdim, 1, ipk ) ) ! allocate the target + ! + IF( llread ) THEN ! get data from NetCDF file + CALL fld_fill( bf_alias, bn_alias, cn_dir, 'bdy_dta', cl3//' '//ctmp1, ctmp2 ) ! use namelist info + IF( bf_alias(1)%ln_tint ) ALLOCATE( bf_alias(1)%fdta( iszdim, 1, ipk, 2 ) ) + bf_alias(1)%imap => idx_bdy(jbdy)%nbmap(1:iszdim,igrd) ! associate the mapping used for this bdy + bf_alias(1)%igrd = igrd ! used only for vertical integration of 3D arrays + bf_alias(1)%ibdy = jbdy ! " " " " " " " " + bf_alias(1)%ltotvel = ln_full_vel ! T if u3d is full velocity + bf_alias(1)%lzint = ln_zinterp ! T if it requires a vertical interpolation + ENDIF + + ! associate the pointer and get rid of the dimensions with a size equal to 1 + IF( jfld == jp_bdyssh ) dta_bdy(jbdy)%ssh => bf_alias(1)%fnow(:,1,1) + IF( jfld == jp_bdyu2d ) dta_bdy(jbdy)%u2d => bf_alias(1)%fnow(:,1,1) + IF( jfld == jp_bdyv2d ) dta_bdy(jbdy)%v2d => bf_alias(1)%fnow(:,1,1) + IF( jfld == jp_bdyu3d ) dta_bdy(jbdy)%u3d => bf_alias(1)%fnow(:,1,:) + IF( jfld == jp_bdyv3d ) dta_bdy(jbdy)%v3d => bf_alias(1)%fnow(:,1,:) + IF( jfld == jp_bdytem ) dta_bdy(jbdy)%tem => bf_alias(1)%fnow(:,1,:) + IF( jfld == jp_bdysal ) dta_bdy(jbdy)%sal => bf_alias(1)%fnow(:,1,:) + IF( jfld == jp_bdya_i ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%a_i => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%a_i(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdyh_i ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%h_i => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%h_i(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdyh_s ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%h_s => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%h_s(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdyt_i ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%t_i => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%t_i(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdyt_s ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%t_s => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%t_s(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdytsu ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%tsu => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%tsu(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdys_i ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%s_i => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%s_i(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdyaip ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%aip => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%aip(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdyhip ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%hip => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%hip(iszdim,jpl) ) + ENDIF + ENDIF + IF( jfld == jp_bdyhil ) THEN + IF( ipk == jpl ) THEN ; dta_bdy(jbdy)%hil => bf_alias(1)%fnow(:,1,:) + ELSE ; ALLOCATE( dta_bdy(jbdy)%hil(iszdim,jpl) ) + ENDIF + ENDIF + ENDIF + + END DO ! jpbdyfld + ! + END DO ! jbdy + ! + END SUBROUTINE bdy_dta_init + + !!============================================================================== +END MODULE bdydta \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydyn.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydyn.F90 new file mode 100644 index 0000000..85077b9 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydyn.F90 @@ -0,0 +1,126 @@ +MODULE bdydyn + !!====================================================================== + !! *** MODULE bdydyn *** + !! Unstructured Open Boundary Cond. : Apply boundary conditions to velocities + !!====================================================================== + !! History : 1.0 ! 2005-02 (J. Chanut, A. Sellar) Original code + !! - ! 2007-07 (D. Storkey) Move Flather implementation to separate routine. + !! 3.0 ! 2008-04 (NEMO team) add in the reference version + !! 3.2 ! 2008-04 (R. Benshila) consider velocity instead of transport + !! 3.3 ! 2010-09 (E.O'Dea) modifications for Shelf configurations + !! 3.3 ! 2010-09 (D.Storkey) add ice boundary conditions + !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge + !!---------------------------------------------------------------------- + !! bdy_dyn : split velocities into barotropic and baroclinic parts + !! and call bdy_dyn2d and bdy_dyn3d to apply boundary + !! conditions + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE bdy_oce ! ocean open boundary conditions + USE bdydyn2d ! open boundary conditions for barotropic solution + USE bdydyn3d ! open boundary conditions for baroclinic velocities + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE in_out_manager ! + USE domvvl ! variable volume + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_dyn ! routine called in dyn_nxt + + !! * Substitutions +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdydyn.F90 13237 2020-07-03 09:12:53Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_dyn( kt, Kbb, puu, pvv, Kaa, dyn3d_only ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn *** + !! + !! ** Purpose : - Wrapper routine for bdy_dyn2d and bdy_dyn3d. + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! Main time step counter + INTEGER , INTENT(in) :: Kbb, Kaa ! Ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + LOGICAL, OPTIONAL , INTENT(in) :: dyn3d_only ! T => only update baroclinic velocities + ! + INTEGER :: jk, ii, ij, ib_bdy, ib, igrd ! Loop counter + LOGICAL :: ll_dyn2d, ll_dyn3d, ll_orlanski + REAL(wp), DIMENSION(jpi,jpj) :: zua2d, zva2d ! after barotropic velocities + !!---------------------------------------------------------------------- + ! + ll_dyn2d = .true. + ll_dyn3d = .true. + ! + IF( PRESENT(dyn3d_only) ) THEN + IF( dyn3d_only ) ll_dyn2d = .false. + ENDIF + ! + ll_orlanski = .false. + DO ib_bdy = 1, nb_bdy + IF ( cn_dyn2d(ib_bdy) == 'orlanski' .OR. cn_dyn2d(ib_bdy) == 'orlanski_npo' & + & .OR. cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo') ll_orlanski = .true. + END DO + + !------------------------------------------------------- + ! Split velocities into barotropic and baroclinic parts + !------------------------------------------------------- + + ! ! "After" velocities: + zua2d(:,:) = 0._wp + zva2d(:,:) = 0._wp + DO jk = 1, jpkm1 + zua2d(:,:) = zua2d(:,:) + e3u(:,:,jk,Kaa) * puu(:,:,jk,Kaa) * umask(:,:,jk) + zva2d(:,:) = zva2d(:,:) + e3v(:,:,jk,Kaa) * pvv(:,:,jk,Kaa) * vmask(:,:,jk) + END DO + zua2d(:,:) = zua2d(:,:) * r1_hu(:,:,Kaa) + zva2d(:,:) = zva2d(:,:) * r1_hv(:,:,Kaa) + + DO jk = 1 , jpkm1 + puu(:,:,jk,Kaa) = ( puu(:,:,jk,Kaa) - zua2d(:,:) ) * umask(:,:,jk) + pvv(:,:,jk,Kaa) = ( pvv(:,:,jk,Kaa) - zva2d(:,:) ) * vmask(:,:,jk) + END DO + + + IF( ll_orlanski ) THEN ! "Before" velocities (Orlanski condition only) + DO jk = 1 , jpkm1 + puu(:,:,jk,Kbb) = ( puu(:,:,jk,Kbb) - uu_b(:,:,Kbb) ) * umask(:,:,jk) + pvv(:,:,jk,Kbb) = ( pvv(:,:,jk,Kbb) - vv_b(:,:,Kbb) ) * vmask(:,:,jk) + END DO + ENDIF + + !------------------------------------------------------- + ! Apply boundary conditions to barotropic and baroclinic + ! parts separately + !------------------------------------------------------- + + IF( ll_dyn2d ) CALL bdy_dyn2d( kt, zua2d, zva2d, uu_b(:,:,Kbb), vv_b(:,:,Kbb), r1_hu(:,:,Kaa), r1_hv(:,:,Kaa), ssh(:,:,Kaa) ) + + IF( ll_dyn3d ) CALL bdy_dyn3d( kt, Kbb, puu, pvv, Kaa ) + + !------------------------------------------------------- + ! Recombine velocities + !------------------------------------------------------- + ! + DO jk = 1 , jpkm1 + puu(:,:,jk,Kaa) = ( puu(:,:,jk,Kaa) + zua2d(:,:) ) * umask(:,:,jk) + pvv(:,:,jk,Kaa) = ( pvv(:,:,jk,Kaa) + zva2d(:,:) ) * vmask(:,:,jk) + END DO + ! + IF ( ll_orlanski ) THEN + DO jk = 1 , jpkm1 + puu(:,:,jk,Kbb) = ( puu(:,:,jk,Kbb) + uu_b(:,:,Kbb) ) * umask(:,:,jk) + pvv(:,:,jk,Kbb) = ( pvv(:,:,jk,Kbb) + vv_b(:,:,Kbb) ) * vmask(:,:,jk) + END DO + END IF + ! + END SUBROUTINE bdy_dyn + + !!====================================================================== +END MODULE bdydyn \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydyn2d.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydyn2d.F90 new file mode 100644 index 0000000..1872bd0 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydyn2d.F90 @@ -0,0 +1,343 @@ +MODULE bdydyn2d + !!====================================================================== + !! *** MODULE bdydyn *** + !! Unstructured Open Boundary Cond. : Apply boundary conditions to barotropic solution + !!====================================================================== + !! History : 3.4 ! 2011 (D. Storkey) new module as part of BDY rewrite + !! 3.5 ! 2012 (S. Mocavero, I. Epicoco) Optimization of BDY communications + !! 3.5 ! 2013-07 (J. Chanut) Compliant with time splitting changes + !!---------------------------------------------------------------------- + !! bdy_dyn2d : Apply open boundary conditions to barotropic variables. + !! bdy_dyn2d_frs : Apply Flow Relaxation Scheme + !! bdy_dyn2d_fla : Apply Flather condition + !! bdy_dyn2d_orlanski : Orlanski Radiation + !! bdy_ssh : Duplicate sea level across open boundaries + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE bdy_oce ! ocean open boundary conditions + USE bdylib ! BDY library routines + USE phycst ! physical constants + USE lib_mpp + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE wet_dry ! Use wet dry to get reference ssh level + USE in_out_manager ! + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_dyn2d ! routine called in dynspg_ts and bdy_dyn + PUBLIC bdy_ssh ! routine called in dynspg_ts or sshwzv + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdydyn2d.F90 15368 2021-10-14 08:25:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_dyn2d( kt, pua2d, pva2d, pub2d, pvb2d, phur, phvr, pssh ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn2d *** + !! + !! ** Purpose : - Apply open boundary conditions for barotropic variables + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! Main time step counter + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pub2d, pvb2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: phur, phvr + REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: pssh + !! + INTEGER :: ib_bdy, ir ! BDY set index, rim index + INTEGER, DIMENSION(3) :: idir3 + INTEGER, DIMENSION(6) :: idir6 + LOGICAL :: llrim0 ! indicate if rim 0 is treated + LOGICAL, DIMENSION(8) :: llsend2, llrecv2, llsend3, llrecv3 ! indicate how communications are to be carried out + !!---------------------------------------------------------------------- + + llsend2(:) = .false. ; llrecv2(:) = .false. + llsend3(:) = .false. ; llrecv3(:) = .false. + DO ir = 1, 0, -1 ! treat rim 1 before rim 0 + IF( ir == 0 ) THEN ; llrim0 = .TRUE. + ELSE ; llrim0 = .FALSE. + END IF + DO ib_bdy=1, nb_bdy + SELECT CASE( cn_dyn2d(ib_bdy) ) + CASE('none') + CYCLE + CASE('frs') ! treat the whole boundary at once + IF( llrim0 ) CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d ) + CASE('flather') + CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d, pssh, phur, phvr, llrim0 ) + CASE('orlanski') + CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & + & pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo=.false. ) + CASE('orlanski_npo') + CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & + & pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo=.true. ) + CASE DEFAULT + CALL ctl_stop( 'bdy_dyn2d : unrecognised option for open boundaries for barotropic variables' ) + END SELECT + ENDDO + ! + IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 + IF( nn_hls == 1 ) THEN + llsend2(:) = .false. ; llrecv2(:) = .false. + llsend3(:) = .false. ; llrecv3(:) = .false. + END IF + DO ib_bdy=1, nb_bdy + SELECT CASE( cn_dyn2d(ib_bdy) ) + CASE('flather') + idir6 = (/ jpwe, jpea, jpsw, jpse, jpnw, jpne /) + llsend2(idir6) = llsend2(idir6) .OR. lsend_bdyint(ib_bdy,2,idir6,ir) ! west/east, U points + idir3 = (/ jpwe, jpsw, jpnw /) + llsend2(idir3) = llsend2(idir3) .OR. lsend_bdyext(ib_bdy,2,idir3,ir) ! nei might search point towards its east bdy + llrecv2(idir6) = llrecv2(idir6) .OR. lrecv_bdyint(ib_bdy,2,idir6,ir) ! west/east, U points + idir3 = (/ jpea, jpse, jpne /) + llrecv2(idir3) = llrecv2(idir3) .OR. lrecv_bdyext(ib_bdy,2,idir3,ir) ! might search point towards bdy on the east + idir6 = (/ jpso, jpno, jpsw, jpse, jpnw, jpne /) + llsend3(idir6) = llsend3(idir6) .OR. lsend_bdyint(ib_bdy,3,idir6,ir) ! north/south, V points + idir3 = (/ jpso, jpsw, jpse /) + llsend3(idir3) = llsend3(idir3) .OR. lsend_bdyext(ib_bdy,3,idir3,ir) ! nei might search point towards its north bdy + llrecv3(idir6) = llrecv3(idir6) .OR. lrecv_bdyint(ib_bdy,3,idir6,ir) ! north/south, V points + idir3 = (/ jpno, jpnw, jpne /) + llrecv3(idir3) = llrecv3(idir3) .OR. lrecv_bdyext(ib_bdy,3,idir3,ir) ! might search point towards bdy on the north + CASE('orlanski', 'orlanski_npo') + llsend2(:) = llsend2(:) .OR. lsend_bdyolr(ib_bdy,2,:,ir) ! possibly every direction, U points + llrecv2(:) = llrecv2(:) .OR. lrecv_bdyolr(ib_bdy,2,:,ir) ! possibly every direction, U points + llsend3(:) = llsend3(:) .OR. lsend_bdyolr(ib_bdy,3,:,ir) ! possibly every direction, V points + llrecv3(:) = llrecv3(:) .OR. lrecv_bdyolr(ib_bdy,3,:,ir) ! possibly every direction, V points + END SELECT + END DO + IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) + END IF + IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) + END IF + ! + END DO ! ir + ! + END SUBROUTINE bdy_dyn2d + + SUBROUTINE bdy_dyn2d_frs( idx, dta, ib_bdy, pua2d, pva2d ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn2d_frs *** + !! + !! ** Purpose : - Apply the Flow Relaxation Scheme for barotropic velocities + !! at open boundaries. + !! + !! References :- Engedahl H., 1995: Use of the flow relaxation scheme in + !! a three-dimensional baroclinic ocean model with realistic + !! topography. Tellus, 365-382. + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data + INTEGER, INTENT(in) :: ib_bdy ! BDY set index + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d + !! + INTEGER :: jb ! dummy loop indices + INTEGER :: ii, ij, igrd ! local integers + REAL(wp) :: zwgt ! boundary weight + !!---------------------------------------------------------------------- + ! + igrd = 2 ! Relaxation of zonal velocity + DO jb = 1, idx%nblen(igrd) + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + zwgt = idx%nbw(jb,igrd) + pua2d(ii,ij) = ( pua2d(ii,ij) + zwgt * ( dta%u2d(jb) - pua2d(ii,ij) ) ) * umask(ii,ij,1) + END DO + ! + igrd = 3 ! Relaxation of meridional velocity + DO jb = 1, idx%nblen(igrd) + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + zwgt = idx%nbw(jb,igrd) + pva2d(ii,ij) = ( pva2d(ii,ij) + zwgt * ( dta%v2d(jb) - pva2d(ii,ij) ) ) * vmask(ii,ij,1) + END DO + ! + END SUBROUTINE bdy_dyn2d_frs + + + SUBROUTINE bdy_dyn2d_fla( idx, dta, ib_bdy, pua2d, pva2d, pssh, phur, phvr, llrim0 ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn2d_fla *** + !! + !! - Apply Flather boundary conditions on normal barotropic velocities + !! + !! ** WARNINGS about FLATHER implementation: + !!1. According to Palma and Matano, 1998 "after ssh" is used. + !! In ROMS and POM implementations, it is "now ssh". In the current + !! implementation (tested only in the EEL-R5 conf.), both cases were unstable. + !! So I use "before ssh" in the following. + !! + !!2. We assume that the normal ssh gradient at the bdy is zero. As a matter of + !! fact, the model ssh just inside the dynamical boundary is used (the outside + !! ssh in the code is not updated). + !! + !! References: Flather, R. A., 1976: A tidal model of the northwest European + !! continental shelf. Mem. Soc. R. Sci. Liege, Ser. 6,10, 141-164. + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data + INTEGER, INTENT(in) :: ib_bdy ! BDY set index + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phur, phvr + REAL(dp), DIMENSION(jpi,jpj), INTENT(in) :: pssh + LOGICAL , INTENT(in) :: llrim0 ! indicate if rim 0 is treated + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) + INTEGER :: jb, igrd ! dummy loop indices + INTEGER :: ii, ij ! 2D addresses + INTEGER :: iiTrim, ijTrim ! T pts i/j-indice on the rim + INTEGER :: iiToce, ijToce, iiUoce, ijVoce ! T, U and V pts i/j-indice of the ocean next to the rim + REAL(wp) :: flagu, flagv ! short cuts + REAL(wp) :: zfla ! Flather correction + REAL(wp) :: z1_2 ! + REAL(wp), DIMENSION(jpi,jpj) :: sshdta ! 2D version of dta%ssh + !!---------------------------------------------------------------------- + + z1_2 = 0.5_wp + + ! ---------------------------------! + ! Flather boundary conditions :! + ! ---------------------------------! + + ! Fill temporary array with ssh data (here we use spgu with the alias sshdta): + igrd = 1 + IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) + END IF + ! + DO jb = ibeg, iend + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + IF( ll_wd ) THEN ; sshdta(ii, ij) = dta%ssh(jb) - ssh_ref + ELSE ; sshdta(ii, ij) = dta%ssh(jb) + ENDIF + END DO + ! + igrd = 2 ! Flather bc on u-velocity + ! ! remember that flagu=-1 if normal velocity direction is outward + ! ! I think we should rather use after ssh ? + IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) + END IF + DO jb = ibeg, iend + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + flagu = idx%flagu(jb,igrd) + IF( flagu == 0. ) THEN + pua2d(ii,ij) = dta%u2d(jb) + ELSE ! T pts j-indice on the rim on the ocean next to the rim on T and U points + IF( flagu == 1. ) THEN ; iiTrim = ii ; iiToce = ii+1 ; iiUoce = ii+1 ; ENDIF + IF( flagu == -1. ) THEN ; iiTrim = ii+1 ; iiToce = ii ; iiUoce = ii-1 ; ENDIF + ! + ! Rare case : rim is parallel to the mpi subdomain border and on the halo : point will be received + IF( iiTrim > jpi .OR. iiToce > jpi .OR. iiUoce > jpi .OR. iiUoce < 1 ) CYCLE + ! + zfla = dta%u2d(jb) - flagu * SQRT( grav * phur(ii, ij) ) * ( pssh(iiToce,ij) - sshdta(iiTrim,ij) ) + ! + ! jchanut tschanges, use characteristics method (Blayo et Debreu, 2005) : + ! mix Flather scheme with velocity of the ocean next to the rim + pua2d(ii,ij) = z1_2 * ( pua2d(iiUoce,ij) + zfla ) + END IF + END DO + ! + igrd = 3 ! Flather bc on v-velocity + ! ! remember that flagv=-1 if normal velocity direction is outward + IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) + END IF + DO jb = ibeg, iend + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + flagv = idx%flagv(jb,igrd) + IF( flagv == 0. ) THEN + pva2d(ii,ij) = dta%v2d(jb) + ELSE ! T pts j-indice on the rim on the ocean next to the rim on T and V points + IF( flagv == 1. ) THEN ; ijTrim = ij ; ijToce = ij+1 ; ijVoce = ij+1 ; ENDIF + IF( flagv == -1. ) THEN ; ijTrim = ij+1 ; ijToce = ij ; ijVoce = ij-1 ; ENDIF + ! + ! Rare case : rim is parallel to the mpi subdomain border and on the halo : point will be received + IF( ijTrim > jpj .OR. ijToce > jpj .OR. ijVoce > jpj .OR. ijVoce < 1 ) CYCLE + ! + zfla = dta%v2d(jb) - flagv * SQRT( grav * phvr(ii, ij) ) * ( pssh(ii,ijToce) - sshdta(ii,ijTrim) ) + ! + ! jchanut tschanges, use characteristics method (Blayo et Debreu, 2005) : + ! mix Flather scheme with velocity of the ocean next to the rim + pva2d(ii,ij) = z1_2 * ( pva2d(ii,ijVoce) + zfla ) + END IF + END DO + ! + END SUBROUTINE bdy_dyn2d_fla + + + SUBROUTINE bdy_dyn2d_orlanski( idx, dta, ib_bdy, pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn2d_orlanski *** + !! + !! - Apply Orlanski radiation condition adaptively: + !! - radiation plus weak nudging at outflow points + !! - no radiation and strong nudging at inflow points + !! + !! + !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data + INTEGER, INTENT(in) :: ib_bdy ! number of current open boundary set + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub2d, pvb2d + LOGICAL, INTENT(in) :: ll_npo ! flag for NPO version + LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated + INTEGER :: ib, igrd ! dummy loop indices + INTEGER :: ii, ij, iibm1, ijbm1 ! indices + !!---------------------------------------------------------------------- + ! + igrd = 2 ! Orlanski bc on u-velocity; + ! + CALL bdy_orlanski_2d( idx, igrd, pub2d, pua2d, dta%u2d, llrim0, ll_npo ) + + igrd = 3 ! Orlanski bc on v-velocity + ! + CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, llrim0, ll_npo ) + ! + END SUBROUTINE bdy_dyn2d_orlanski + + + SUBROUTINE bdy_ssh( zssh ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_ssh *** + !! + !! ** Purpose : Duplicate sea level across open boundaries + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(jpi,jpj,1), INTENT(inout) :: zssh ! Sea level, need 3 dimensions to be used by bdy_nmn + !! + INTEGER :: ib_bdy, ir ! bdy index, rim index + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) + LOGICAL :: llrim0 ! indicate if rim 0 is treated + LOGICAL, DIMENSION(8) :: llsend1, llrecv1 ! indicate how communications are to be carried out + !!---------------------------------------------------------------------- + llsend1(:) = .false. ; llrecv1(:) = .false. + DO ir = 1, 0, -1 ! treat rim 1 before rim 0 + IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END IF + IF( ir == 0 ) THEN ; llrim0 = .TRUE. + ELSE ; llrim0 = .FALSE. + END IF + DO ib_bdy = 1, nb_bdy + CALL bdy_nmn( idx_bdy(ib_bdy), 1, zssh, llrim0 ) ! zssh is masked + llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points + llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points + END DO + IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 + IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdydyn2d', zssh(:,:,1), 'T', 1.0_dp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + END IF + END DO + ! + END SUBROUTINE bdy_ssh + + !!====================================================================== +END MODULE bdydyn2d diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydyn3d.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydyn3d.F90 new file mode 100644 index 0000000..db3d304 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdydyn3d.F90 @@ -0,0 +1,418 @@ +MODULE bdydyn3d + !!====================================================================== + !! *** MODULE bdydyn3d *** + !! Unstructured Open Boundary Cond. : Flow relaxation scheme on baroclinic velocities + !!====================================================================== + !! History : 3.4 ! 2011 (D. Storkey) new module as part of BDY rewrite + !! 3.5 ! 2012 (S. Mocavero, I. Epicoco) Optimization of BDY communications + !!---------------------------------------------------------------------- + !! bdy_dyn3d : apply open boundary conditions to baroclinic velocities + !! bdy_dyn3d_frs : apply Flow Relaxation Scheme + !!---------------------------------------------------------------------- + USE timing ! Timing + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE bdy_oce ! ocean open boundary conditions + USE bdylib ! for orlanski library routines + USE lib_mpp + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE in_out_manager ! + Use phycst + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_dyn3d ! routine called by bdy_dyn + PUBLIC bdy_dyn3d_dmp ! routine called by step + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdydyn3d.F90 15368 2021-10-14 08:25:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_dyn3d( kt, Kbb, puu, pvv, Kaa ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d *** + !! + !! ** Purpose : - Apply open boundary conditions for baroclinic velocities + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! Main time step counter + INTEGER , INTENT( in ) :: Kbb, Kaa ! Time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + ! + INTEGER :: ib_bdy, ir ! BDY set index, rim index + INTEGER, DIMENSION(6) :: idir6 + LOGICAL :: llrim0 ! indicate if rim 0 is treated + LOGICAL, DIMENSION(8) :: llsend2, llrecv2, llsend3, llrecv3 ! indicate how communications are to be carried out + !!---------------------------------------------------------------------- + + llsend2(:) = .false. ; llrecv2(:) = .false. + llsend3(:) = .false. ; llrecv3(:) = .false. + DO ir = 1, 0, -1 ! treat rim 1 before rim 0 + IF( ir == 0 ) THEN ; llrim0 = .TRUE. + ELSE ; llrim0 = .FALSE. + END IF + DO ib_bdy=1, nb_bdy + ! + SELECT CASE( cn_dyn3d(ib_bdy) ) + CASE('none') ; CYCLE + CASE('frs' ) ! treat the whole boundary at once + IF( ir == 0) CALL bdy_dyn3d_frs( puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) + CASE('specified') ! treat the whole rim at once + IF( ir == 0) CALL bdy_dyn3d_spe( puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) + CASE('zero') ! treat the whole rim at once + IF( ir == 0) CALL bdy_dyn3d_zro( puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) + CASE('orlanski' ) ; CALL bdy_dyn3d_orlanski( Kbb, puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.false. ) + CASE('orlanski_npo'); CALL bdy_dyn3d_orlanski( Kbb, puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.true. ) + CASE('zerograd') ; CALL bdy_dyn3d_zgrad( puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy, llrim0 ) + CASE('neumann') ; CALL bdy_dyn3d_nmn( puu, pvv, Kaa, idx_bdy(ib_bdy), ib_bdy, llrim0 ) + CASE DEFAULT ; CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) + END SELECT + END DO + ! + IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 + IF( nn_hls == 1 ) THEN + llsend2(:) = .false. ; llrecv2(:) = .false. + llsend3(:) = .false. ; llrecv3(:) = .false. + END IF + DO ib_bdy=1, nb_bdy + SELECT CASE( cn_dyn3d(ib_bdy) ) + CASE('orlanski', 'orlanski_npo') + llsend2(:) = llsend2(:) .OR. lsend_bdyolr(ib_bdy,2,:,ir) ! possibly every direction, U points + llrecv2(:) = llrecv2(:) .OR. lrecv_bdyolr(ib_bdy,2,:,ir) ! possibly every direction, U points + llsend3(:) = llsend3(:) .OR. lsend_bdyolr(ib_bdy,3,:,ir) ! possibly every direction, V points + llrecv3(:) = llrecv3(:) .OR. lrecv_bdyolr(ib_bdy,3,:,ir) ! possibly every direction, V points + CASE('zerograd') + idir6 = (/ jpso, jpno, jpsw, jpse, jpnw, jpne /) + llsend2(idir6) = llsend2(idir6) .OR. lsend_bdyint(ib_bdy,2,idir6,ir) ! north/south, U points + llrecv2(idir6) = llrecv2(idir6) .OR. lrecv_bdyint(ib_bdy,2,idir6,ir) ! north/south, U points + idir6 = (/ jpwe, jpea, jpsw, jpse, jpnw, jpne /) + llsend3(idir6) = llsend3(idir6) .OR. lsend_bdyint(ib_bdy,3,idir6,ir) ! west/east, V points + llrecv3(idir6) = llrecv3(idir6) .OR. lrecv_bdyint(ib_bdy,3,idir6,ir) ! west/east, V points + CASE('neumann') + llsend2(:) = llsend2(:) .OR. lsend_bdyint(ib_bdy,2,:,ir) ! possibly every direction, U points + llrecv2(:) = llrecv2(:) .OR. lrecv_bdyint(ib_bdy,2,:,ir) ! possibly every direction, U points + llsend3(:) = llsend3(:) .OR. lsend_bdyint(ib_bdy,3,:,ir) ! possibly every direction, V points + llrecv3(:) = llrecv3(:) .OR. lrecv_bdyint(ib_bdy,3,:,ir) ! possibly every direction, V points + END SELECT + END DO + ! + IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdydyn2d', puu(:,:,:,Kaa), 'U', -1.0_dp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) + END IF + IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdydyn2d', pvv(:,:,:,Kaa), 'V', -1.0_dp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) + END IF + END DO ! ir + ! + END SUBROUTINE bdy_dyn3d + + + SUBROUTINE bdy_dyn3d_spe( puu, pvv, Kaa, idx, dta, kt, ib_bdy ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_spe *** + !! + !! ** Purpose : - Apply a specified value for baroclinic velocities + !! at open boundaries. + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: Kaa ! Time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + TYPE(OBC_INDEX) , INTENT( in ) :: idx ! OBC indices + TYPE(OBC_DATA) , INTENT( in ) :: dta ! OBC external data + INTEGER , INTENT( in ) :: kt ! Time step + INTEGER , INTENT( in ) :: ib_bdy ! BDY set index + ! + INTEGER :: jb, jk ! dummy loop indices + INTEGER :: ii, ij, igrd ! local integers + !!---------------------------------------------------------------------- + ! + igrd = 2 ! Relaxation of zonal velocity + DO jb = 1, idx%nblenrim(igrd) + DO jk = 1, jpkm1 + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + puu(ii,ij,jk,Kaa) = dta%u3d(jb,jk) * umask(ii,ij,jk) + END DO + END DO + ! + igrd = 3 ! Relaxation of meridional velocity + DO jb = 1, idx%nblenrim(igrd) + DO jk = 1, jpkm1 + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + pvv(ii,ij,jk,Kaa) = dta%v3d(jb,jk) * vmask(ii,ij,jk) + END DO + END DO + ! + END SUBROUTINE bdy_dyn3d_spe + + + SUBROUTINE bdy_dyn3d_zgrad( puu, pvv, Kaa, idx, dta, kt, ib_bdy, llrim0 ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_zgrad *** + !! + !! ** Purpose : - Enforce a zero gradient of normal velocity + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: Kaa ! Time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + TYPE(OBC_INDEX) , INTENT( in ) :: idx ! OBC indices + TYPE(OBC_DATA) , INTENT( in ) :: dta ! OBC external data + INTEGER , INTENT( in ) :: kt + INTEGER , INTENT( in ) :: ib_bdy ! BDY set index + LOGICAL , INTENT( in ) :: llrim0 ! indicate if rim 0 is treated + !! + INTEGER :: jb, jk ! dummy loop indices + INTEGER :: ii, ij, igrd ! local integers + INTEGER :: flagu, flagv ! short cuts + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) + !!---------------------------------------------------------------------- + ! + igrd = 2 ! Copying tangential velocity into bdy points + IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) + ENDIF + DO jb = ibeg, iend + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + flagu = NINT(idx%flagu(jb,igrd)) + flagv = NINT(idx%flagv(jb,igrd)) + ! + IF( flagu == 0 ) THEN ! north/south bdy + IF( ij+flagv > jpj .OR. ij+flagv < 1 ) CYCLE + ! + DO jk = 1, jpkm1 + puu(ii,ij,jk,Kaa) = puu(ii,ij+flagv,jk,Kaa) * umask(ii,ij+flagv,jk) + END DO + ! + END IF + END DO + ! + igrd = 3 ! Copying tangential velocity into bdy points + IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) + ENDIF + DO jb = ibeg, iend + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + flagu = NINT(idx%flagu(jb,igrd)) + flagv = NINT(idx%flagv(jb,igrd)) + ! + IF( flagv == 0 ) THEN ! west/east bdy + IF( ii+flagu > jpi .OR. ii+flagu < 1 ) CYCLE + ! + DO jk = 1, jpkm1 + pvv(ii,ij,jk,Kaa) = pvv(ii+flagu,ij,jk,Kaa) * vmask(ii+flagu,ij,jk) + END DO + ! + END IF + END DO + ! + END SUBROUTINE bdy_dyn3d_zgrad + + + SUBROUTINE bdy_dyn3d_zro( puu, pvv, Kaa, idx, dta, kt, ib_bdy ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_zro *** + !! + !! ** Purpose : - baroclinic velocities = 0. at open boundaries. + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! time step index + INTEGER , INTENT( in ) :: Kaa ! Time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + TYPE(OBC_INDEX) , INTENT( in ) :: idx ! OBC indices + TYPE(OBC_DATA) , INTENT( in ) :: dta ! OBC external data + INTEGER , INTENT( in ) :: ib_bdy ! BDY set index + ! + INTEGER :: ib, ik ! dummy loop indices + INTEGER :: ii, ij, igrd ! local integers + !!---------------------------------------------------------------------- + ! + igrd = 2 ! Everything is at T-points here + DO ib = 1, idx%nblenrim(igrd) + ii = idx%nbi(ib,igrd) + ij = idx%nbj(ib,igrd) + DO ik = 1, jpkm1 + puu(ii,ij,ik,Kaa) = 0._wp + END DO + END DO + ! + igrd = 3 ! Everything is at T-points here + DO ib = 1, idx%nblenrim(igrd) + ii = idx%nbi(ib,igrd) + ij = idx%nbj(ib,igrd) + DO ik = 1, jpkm1 + pvv(ii,ij,ik,Kaa) = 0._wp + END DO + END DO + ! + END SUBROUTINE bdy_dyn3d_zro + + + SUBROUTINE bdy_dyn3d_frs( puu, pvv, Kaa, idx, dta, kt, ib_bdy ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_frs *** + !! + !! ** Purpose : - Apply the Flow Relaxation Scheme for baroclinic velocities + !! at open boundaries. + !! + !! References :- Engedahl H., 1995: Use of the flow relaxation scheme in + !! a three-dimensional baroclinic ocean model with realistic + !! topography. Tellus, 365-382. + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! time step index + INTEGER , INTENT( in ) :: Kaa ! Time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + TYPE(OBC_INDEX) , INTENT( in ) :: idx ! OBC indices + TYPE(OBC_DATA) , INTENT( in ) :: dta ! OBC external data + INTEGER , INTENT( in ) :: ib_bdy ! BDY set index + ! + INTEGER :: jb, jk ! dummy loop indices + INTEGER :: ii, ij, igrd ! local integers + REAL(wp) :: zwgt ! boundary weight + !!---------------------------------------------------------------------- + ! + igrd = 2 ! Relaxation of zonal velocity + DO jb = 1, idx%nblen(igrd) + DO jk = 1, jpkm1 + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + zwgt = idx%nbw(jb,igrd) + puu(ii,ij,jk,Kaa) = ( puu(ii,ij,jk,Kaa) + zwgt * ( dta%u3d(jb,jk) - puu(ii,ij,jk,Kaa) ) ) * umask(ii,ij,jk) + END DO + END DO + ! + igrd = 3 ! Relaxation of meridional velocity + DO jb = 1, idx%nblen(igrd) + DO jk = 1, jpkm1 + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + zwgt = idx%nbw(jb,igrd) + pvv(ii,ij,jk,Kaa) = ( pvv(ii,ij,jk,Kaa) + zwgt * ( dta%v3d(jb,jk) - pvv(ii,ij,jk,Kaa) ) ) * vmask(ii,ij,jk) + END DO + END DO + ! + END SUBROUTINE bdy_dyn3d_frs + + + SUBROUTINE bdy_dyn3d_orlanski( Kbb, puu, pvv, Kaa, idx, dta, ib_bdy, llrim0, ll_npo ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_orlanski *** + !! + !! - Apply Orlanski radiation to baroclinic velocities. + !! - Wrapper routine for bdy_orlanski_3d + !! + !! + !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: Kbb, Kaa ! Time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + TYPE(OBC_INDEX) , INTENT( in ) :: idx ! OBC indices + TYPE(OBC_DATA) , INTENT( in ) :: dta ! OBC external data + INTEGER , INTENT( in ) :: ib_bdy ! BDY set index + LOGICAL , INTENT( in ) :: llrim0 ! indicate if rim 0 is treated + LOGICAL , INTENT( in ) :: ll_npo ! switch for NPO version + + INTEGER :: jb, igrd ! dummy loop indices + !!---------------------------------------------------------------------- + ! + !! Note that at this stage the puu(:,:,:,Kbb) and puu(:,:,:,Kaa) arrays contain the baroclinic velocities. + ! + igrd = 2 ! Orlanski bc on u-velocity; + ! + CALL bdy_orlanski_3d( idx, igrd, puu(:,:,:,Kbb), puu(:,:,:,Kaa), dta%u3d, ll_npo, llrim0 ) + + igrd = 3 ! Orlanski bc on v-velocity + ! + CALL bdy_orlanski_3d( idx, igrd, pvv(:,:,:,Kbb), pvv(:,:,:,Kaa), dta%v3d, ll_npo, llrim0 ) + ! + END SUBROUTINE bdy_dyn3d_orlanski + + + SUBROUTINE bdy_dyn3d_dmp( kt, Kbb, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_dmp *** + !! + !! ** Purpose : Apply damping for baroclinic velocities at open boundaries. + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! time step + INTEGER , INTENT( in ) :: Kbb, Krhs ! Time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities and trends (to be updated at open boundaries) + ! + INTEGER :: jb, jk ! dummy loop indices + INTEGER :: ib_bdy ! loop index + INTEGER :: ii, ij, igrd ! local integers + REAL(wp) :: zwgt ! boundary weight + !!---------------------------------------------------------------------- + IF( l_istiled .AND. ntile /= 1 ) RETURN ! Do only for the full domain + ! + IF( ln_timing ) CALL timing_start('bdy_dyn3d_dmp') + ! + DO ib_bdy=1, nb_bdy + IF ( ln_dyn3d_dmp(ib_bdy) .and. cn_dyn3d(ib_bdy) /= 'none' ) THEN + igrd = 2 ! Relaxation of zonal velocity + DO jb = 1, idx_bdy(ib_bdy)%nblen(igrd) + ii = idx_bdy(ib_bdy)%nbi(jb,igrd) + ij = idx_bdy(ib_bdy)%nbj(jb,igrd) + zwgt = idx_bdy(ib_bdy)%nbd(jb,igrd) + DO jk = 1, jpkm1 + puu(ii,ij,jk,Krhs) = ( puu(ii,ij,jk,Krhs) + zwgt * ( dta_bdy(ib_bdy)%u3d(jb,jk) - & + puu(ii,ij,jk,Kbb) + uu_b(ii,ij,Kbb)) ) * umask(ii,ij,jk) + END DO + END DO + ! + igrd = 3 ! Relaxation of meridional velocity + DO jb = 1, idx_bdy(ib_bdy)%nblen(igrd) + ii = idx_bdy(ib_bdy)%nbi(jb,igrd) + ij = idx_bdy(ib_bdy)%nbj(jb,igrd) + zwgt = idx_bdy(ib_bdy)%nbd(jb,igrd) + DO jk = 1, jpkm1 + pvv(ii,ij,jk,Krhs) = ( pvv(ii,ij,jk,Krhs) + zwgt * ( dta_bdy(ib_bdy)%v3d(jb,jk) - & + pvv(ii,ij,jk,Kbb) + vv_b(ii,ij,Kbb)) ) * vmask(ii,ij,jk) + END DO + END DO + ENDIF + END DO + ! + IF( ln_timing ) CALL timing_stop('bdy_dyn3d_dmp') + ! + END SUBROUTINE bdy_dyn3d_dmp + + + SUBROUTINE bdy_dyn3d_nmn( puu, pvv, Kaa, idx, ib_bdy, llrim0 ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_nmn *** + !! + !! - Apply Neumann condition to baroclinic velocities. + !! - Wrapper routine for bdy_nmn + !! + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: Kaa ! Time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) :: puu, pvv ! Ocean velocities (to be updated at open boundaries) + TYPE(OBC_INDEX) , INTENT( in ) :: idx ! OBC indices + INTEGER , INTENT( in ) :: ib_bdy ! BDY set index + LOGICAL , INTENT( in ) :: llrim0 ! indicate if rim 0 is treated + INTEGER :: igrd ! dummy indice + !!---------------------------------------------------------------------- + ! + !! Note that at this stage the puu(:,:,:,Kbb) and puu(:,:,:,Kaa) arrays contain the baroclinic velocities. + ! + igrd = 2 ! Neumann bc on u-velocity; + ! + CALL bdy_nmn( idx, igrd, puu(:,:,:,Kaa), llrim0 ) + + igrd = 3 ! Neumann bc on v-velocity + ! + CALL bdy_nmn( idx, igrd, pvv(:,:,:,Kaa), llrim0 ) + ! + END SUBROUTINE bdy_dyn3d_nmn + + !!====================================================================== +END MODULE bdydyn3d diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdyice.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdyice.F90 new file mode 100644 index 0000000..3b49989 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdyice.F90 @@ -0,0 +1,480 @@ +MODULE bdyice + !!====================================================================== + !! *** MODULE bdyice *** + !! Unstructured Open Boundary Cond. : Open boundary conditions for sea-ice (SI3) + !!====================================================================== + !! History : 3.3 ! 2010-09 (D. Storkey) Original code + !! 3.4 ! 2012-01 (C. Rousset) add new sea ice model + !! 4.0 ! 2018 (C. Rousset) SI3 compatibility + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea ice model + !!---------------------------------------------------------------------- + !! bdy_ice : Application of open boundaries to ice + !! bdy_ice_frs : Application of Flow Relaxation Scheme + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE ice ! sea-ice: variables + USE icevar ! sea-ice: operations + USE icecor ! sea-ice: corrections + USE icectl ! sea-ice: control prints + USE phycst ! physical constant + USE eosbn2 ! equation of state + USE par_oce ! ocean parameters + USE dom_oce ! ocean space and time domain variables + USE sbc_oce ! Surface boundary condition: ocean fields + USE bdy_oce ! ocean open boundary conditions + ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE in_out_manager ! write to numout file + USE lib_mpp ! distributed memory computing + USE lib_fortran ! to use key_nosignedzero + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_ice ! routine called in sbcmod + PUBLIC bdy_ice_dyn ! routine called in icedyn_rhg_evp + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdyice.F90 15368 2021-10-14 08:25:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_ice( kt ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_ice *** + !! + !! ** Purpose : Apply open boundary conditions for sea ice + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! Main time step counter + ! + INTEGER :: jbdy, ir ! BDY set index, rim index + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) + LOGICAL :: llrim0 ! indicate if rim 0 is treated + LOGICAL, DIMENSION(8) :: llsend1, llrecv1 ! indicate how communications are to be carried out + !!---------------------------------------------------------------------- + ! controls + IF( ln_timing ) CALL timing_start('bdy_ice_thd') ! timing + ! + CALL ice_var_glo2eqv + ! + llsend1(:) = .false. ; llrecv1(:) = .false. + DO ir = 1, 0, -1 ! treat rim 1 before rim 0 + IF( ir == 0 ) THEN ; llrim0 = .TRUE. + ELSE ; llrim0 = .FALSE. + END IF + DO jbdy = 1, nb_bdy + ! + SELECT CASE( cn_ice(jbdy) ) + CASE('none') ; CYCLE + CASE('frs' ) ; CALL bdy_ice_frs( idx_bdy(jbdy), dta_bdy(jbdy), kt, jbdy, llrim0 ) + CASE DEFAULT + CALL ctl_stop( 'bdy_ice : unrecognised option for open boundaries for ice fields' ) + END SELECT + ! + END DO + ! + ! Update bdy points + IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 + IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END IF + DO jbdy = 1, nb_bdy + IF( cn_ice(jbdy) == 'frs' ) THEN + llsend1(:) = llsend1(:) .OR. lsend_bdyint(jbdy,1,:,ir) ! possibly every direction, T points + llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(jbdy,1,:,ir) ! possibly every direction, T points + END IF + END DO ! jbdy + IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction + ! exchange 3d arrays + CALL lbc_lnk('bdyice', a_i , 'T', 1._wp, h_i , 'T', 1._wp, h_s , 'T', 1._wp, oa_i, 'T', 1._wp & + & , s_i , 'T', 1._wp, t_su, 'T', 1._wp, v_i , 'T', 1._wp, v_s , 'T', 1._wp, sv_i, 'T', 1._wp & + & , a_ip, 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp & + & , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + ! exchange 4d arrays : third dimension = 1 and then third dimension = jpk + CALL lbc_lnk('bdyice', t_s , 'T', 1._wp, e_s , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + CALL lbc_lnk('bdyice', t_i , 'T', 1._wp, e_i , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + END IF + END DO ! ir + ! + CALL ice_cor( kt , 0 ) ! -- In case categories are out of bounds, do a remapping + ! ! i.e. inputs have not the same ice thickness distribution (set by rn_himean) + ! ! than the regional simulation + CALL ice_var_agg(1) + ! + ! controls + IF( ln_icectl ) CALL ice_prt ( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) ! prints + IF( ln_timing ) CALL timing_stop ('bdy_ice_thd') ! timing + ! + END SUBROUTINE bdy_ice + + + SUBROUTINE bdy_ice_frs( idx, dta, kt, jbdy, llrim0 ) + !!------------------------------------------------------------------------------ + !! *** SUBROUTINE bdy_ice_frs *** + !! + !! ** Purpose : Apply the Flow Relaxation Scheme for sea-ice fields + !! + !! Reference : Engedahl H., 1995: Use of the flow relaxation scheme in a three- + !! dimensional baroclinic ocean model with realistic topography. Tellus, 365-382. + !!------------------------------------------------------------------------------ + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data + INTEGER, INTENT(in) :: kt ! main time-step counter + INTEGER, INTENT(in) :: jbdy ! BDY set index + LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated + ! + INTEGER :: jpbound ! 0 = incoming ice + ! ! 1 = outgoing ice + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) + INTEGER :: i_bdy, jgrd ! dummy loop indices + INTEGER :: ji, jj, jk, jl, ib, jb + REAL(wp) :: zwgt, zwgt1 ! local scalar + REAL(wp) :: ztmelts, zdh + REAL(wp), POINTER :: flagu, flagv ! short cuts + !!------------------------------------------------------------------------------ + ! + jgrd = 1 ! Everything is at T-points here + IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(jgrd) + ELSE ; ibeg = idx%nblenrim0(jgrd)+1 ; iend = idx%nblenrim(jgrd) + END IF + ! + DO jl = 1, jpl + DO i_bdy = ibeg, iend + ji = idx%nbi(i_bdy,jgrd) + jj = idx%nbj(i_bdy,jgrd) + zwgt = idx%nbw(i_bdy,jgrd) + zwgt1 = 1.e0 - idx%nbw(i_bdy,jgrd) + a_i (ji,jj, jl) = ( a_i (ji,jj, jl) * zwgt1 + dta%a_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice concentration + h_i (ji,jj, jl) = ( h_i (ji,jj, jl) * zwgt1 + dta%h_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice depth + h_s (ji,jj, jl) = ( h_s (ji,jj, jl) * zwgt1 + dta%h_s(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Snow depth + t_i (ji,jj,:,jl) = dta%t_i(i_bdy,jl) * tmask(ji,jj,1) ! Ice temperature + t_s (ji,jj,:,jl) = dta%t_s(i_bdy,jl) * tmask(ji,jj,1) ! Snow temperature + t_su(ji,jj, jl) = dta%tsu(i_bdy,jl) * tmask(ji,jj,1) ! Surf temperature + s_i (ji,jj, jl) = dta%s_i(i_bdy,jl) * tmask(ji,jj,1) ! Ice salinity + a_ip(ji,jj, jl) = ( a_ip(ji,jj, jl) * zwgt1 + dta%aip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond concentration + h_ip(ji,jj, jl) = ( h_ip(ji,jj, jl) * zwgt1 + dta%hip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond depth + h_il(ji,jj, jl) = ( h_il(ji,jj, jl) * zwgt1 + dta%hil(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond lid depth + ! + sz_i(ji,jj,:,jl) = s_i(ji,jj,jl) + ! + ! make sure ponds = 0 if no ponds scheme + IF( .NOT.ln_pnd ) THEN + a_ip(ji,jj,jl) = 0._wp + h_ip(ji,jj,jl) = 0._wp + h_il(ji,jj,jl) = 0._wp + ENDIF + + IF( .NOT.ln_pnd_lids ) THEN + h_il(ji,jj,jl) = 0._wp + ENDIF + ! + ! ----------------- + ! Pathological case + ! ----------------- + ! In case a) snow load would be in excess or b) ice is coming into a warmer environment that would lead to + ! very large transformation from snow to ice (see icethd_dh.F90) + + ! Then, a) transfer the snow excess into the ice (different from icethd_dh) + zdh = MAX( 0._wp, ( rhos * h_s(ji,jj,jl) + ( rhoi - rho0 ) * h_i(ji,jj,jl) ) * r1_rho0 ) + ! Or, b) transfer all the snow into ice (if incoming ice is likely to melt as it comes into a warmer environment) + !zdh = MAX( 0._wp, h_s(ji,jj,jl) * rhos / rhoi ) + + ! recompute h_i, h_s + h_i(ji,jj,jl) = MIN( hi_max(jl), h_i(ji,jj,jl) + zdh ) + h_s(ji,jj,jl) = MAX( 0._wp, h_s(ji,jj,jl) - zdh * rhoi / rhos ) + ! + ENDDO + ENDDO + + DO jl = 1, jpl + DO i_bdy = ibeg, iend + ji = idx%nbi(i_bdy,jgrd) + jj = idx%nbj(i_bdy,jgrd) + flagu => idx%flagu(i_bdy,jgrd) + flagv => idx%flagv(i_bdy,jgrd) + ! condition on ice thickness depends on the ice velocity + ! if velocity is outward (strictly), then ice thickness, volume... must be equal to adjacent values + jpbound = 0 ; ib = ji ; jb = jj + ! + IF( flagu == 1. ) THEN + IF( ji+1 > jpi ) CYCLE + IF( u_ice(ji ,jj ) < 0. ) jpbound = 1 ; ib = ji+1 + END IF + IF( flagu == -1. ) THEN + IF( ji-1 < 1 ) CYCLE + IF( u_ice(ji-1,jj ) < 0. ) jpbound = 1 ; ib = ji-1 + END IF + IF( flagv == 1. ) THEN + IF( jj+1 > jpj ) CYCLE + IF( v_ice(ji ,jj ) < 0. ) jpbound = 1 ; jb = jj+1 + END IF + IF( flagv == -1. ) THEN + IF( jj-1 < 1 ) CYCLE + IF( v_ice(ji ,jj-1) < 0. ) jpbound = 1 ; jb = jj-1 + END IF + ! + IF( nn_ice_dta(jbdy) == 0 ) jpbound = 0 ; ib = ji ; jb = jj ! case ice boundaries = initial conditions + ! ! do not make state variables dependent on velocity + ! + IF( a_i(ib,jb,jl) > 0._wp ) THEN ! there is ice at the boundary + ! + a_i (ji,jj, jl) = a_i (ib,jb, jl) + h_i (ji,jj, jl) = h_i (ib,jb, jl) + h_s (ji,jj, jl) = h_s (ib,jb, jl) + t_i (ji,jj,:,jl) = t_i (ib,jb,:,jl) + t_s (ji,jj,:,jl) = t_s (ib,jb,:,jl) + t_su(ji,jj, jl) = t_su(ib,jb, jl) + s_i (ji,jj, jl) = s_i (ib,jb, jl) + a_ip(ji,jj, jl) = a_ip(ib,jb, jl) + h_ip(ji,jj, jl) = h_ip(ib,jb, jl) + h_il(ji,jj, jl) = h_il(ib,jb, jl) + ! + sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl) + ! + ! ice age + IF ( jpbound == 0 ) THEN ! velocity is inward + oa_i(ji,jj,jl) = rice_age(jbdy) * a_i(ji,jj,jl) + ELSEIF( jpbound == 1 ) THEN ! velocity is outward + oa_i(ji,jj,jl) = oa_i(ib,jb,jl) + ENDIF + ! + IF( nn_icesal == 1 ) THEN ! if constant salinity + s_i (ji,jj ,jl) = rn_icesal + sz_i(ji,jj,:,jl) = rn_icesal + ENDIF + ! + ! global fields + v_i (ji,jj,jl) = h_i(ji,jj,jl) * a_i(ji,jj,jl) ! volume ice + v_s (ji,jj,jl) = h_s(ji,jj,jl) * a_i(ji,jj,jl) ! volume snw + sv_i(ji,jj,jl) = MIN( s_i(ji,jj,jl) , sss_m(ji,jj) ) * v_i(ji,jj,jl) ! salt content + DO jk = 1, nlay_s + t_s(ji,jj,jk,jl) = MIN( t_s(ji,jj,jk,jl), -0.15_wp + rt0 ) ! Force t_s to be lower than -0.15deg (arbitrary) => likely conservation issue + ! ! otherwise instant melting can occur + e_s(ji,jj,jk,jl) = rhos * ( rcpi * ( rt0 - t_s(ji,jj,jk,jl) ) + rLfus ) ! enthalpy in J/m3 + e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * v_s(ji,jj,jl) * r1_nlay_s ! enthalpy in J/m2 + END DO + t_su(ji,jj,jl) = MIN( t_su(ji,jj,jl), -0.15_wp + rt0 ) ! Force t_su to be lower than -0.15deg (arbitrary) + DO jk = 1, nlay_i + ztmelts = - rTmlt * sz_i(ji,jj,jk,jl) ! Melting temperature in C + t_i(ji,jj,jk,jl) = MIN( t_i(ji,jj,jk,jl), (ztmelts-0.15_wp) + rt0 ) ! Force t_i to be lower than melting point (-0.15) => likely conservation issue + ! + e_i(ji,jj,jk,jl) = rhoi * ( rcpi * ( ztmelts - ( t_i(ji,jj,jk,jl) - rt0 ) ) & ! enthalpy in J/m3 + & + rLfus * ( 1._wp - ztmelts / ( t_i(ji,jj,jk,jl) - rt0 ) ) & + & - rcp * ztmelts ) + e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * v_i(ji,jj,jl) * r1_nlay_i ! enthalpy in J/m2 + END DO + ! + ! melt ponds + v_ip(ji,jj,jl) = h_ip(ji,jj,jl) * a_ip(ji,jj,jl) + v_il(ji,jj,jl) = h_il(ji,jj,jl) * a_ip(ji,jj,jl) + ! + ELSE ! no ice at the boundary + ! + a_i (ji,jj, jl) = 0._wp + h_i (ji,jj, jl) = 0._wp + h_s (ji,jj, jl) = 0._wp + oa_i(ji,jj, jl) = 0._wp + t_su(ji,jj, jl) = rt0 + t_s (ji,jj,:,jl) = rt0 + t_i (ji,jj,:,jl) = rt0 + + a_ip(ji,jj,jl) = 0._wp + h_ip(ji,jj,jl) = 0._wp + h_il(ji,jj,jl) = 0._wp + + IF( nn_icesal == 1 ) THEN ! if constant salinity + s_i (ji,jj ,jl) = rn_icesal + sz_i(ji,jj,:,jl) = rn_icesal + ELSE ! if variable salinity + s_i (ji,jj,jl) = rn_simin + sz_i(ji,jj,:,jl) = rn_simin + ENDIF + ! + ! global fields + v_i (ji,jj, jl) = 0._wp + v_s (ji,jj, jl) = 0._wp + sv_i(ji,jj, jl) = 0._wp + e_s (ji,jj,:,jl) = 0._wp + e_i (ji,jj,:,jl) = 0._wp + v_ip(ji,jj, jl) = 0._wp + v_il(ji,jj, jl) = 0._wp + + ENDIF + + END DO + ! + END DO ! jl + ! + END SUBROUTINE bdy_ice_frs + + + SUBROUTINE bdy_ice_dyn( cd_type ) + !!------------------------------------------------------------------------------ + !! *** SUBROUTINE bdy_ice_dyn *** + !! + !! ** Purpose : Apply dynamics boundary conditions for sea-ice. + !! + !! ** Method : if this adjacent grid point is not ice free, then u_ice and v_ice take its value + !! if is ice free, then u_ice and v_ice are unchanged by BDY + !! they keep values calculated in rheology + !! + !!------------------------------------------------------------------------------ + CHARACTER(len=1), INTENT(in) :: cd_type ! nature of velocity grid-points + ! + INTEGER :: i_bdy, jgrd ! dummy loop indices + INTEGER :: ji, jj ! local scalar + INTEGER :: jbdy, ir ! BDY set index, rim index + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) + INTEGER, DIMENSION(3) :: idir3 + REAL(wp) :: zmsk1, zmsk2, zflag + LOGICAL, DIMENSION(8) :: llsend2, llrecv2, llsend3, llrecv3 ! indicate how communications are to be carried out + !!------------------------------------------------------------------------------ + IF( ln_timing ) CALL timing_start('bdy_ice_dyn') + ! + llsend2(:) = .false. ; llrecv2(:) = .false. + llsend3(:) = .false. ; llrecv3(:) = .false. + DO ir = 1, 0, -1 + DO jbdy = 1, nb_bdy + ! + SELECT CASE( cn_ice(jbdy) ) + ! + CASE('none') + CYCLE + ! + CASE('frs') + ! + IF( nn_ice_dta(jbdy) == 0 ) CYCLE ! case ice boundaries = initial conditions + ! ! do not change ice velocity (it is only computed by rheology) + SELECT CASE ( cd_type ) + ! + CASE ( 'U' ) + jgrd = 2 ! u velocity + IF( ir == 0 ) THEN ; ibeg = 1 ; iend = idx_bdy(jbdy)%nblenrim0(jgrd) + ELSE ; ibeg = idx_bdy(jbdy)%nblenrim0(jgrd)+1 ; iend = idx_bdy(jbdy)%nblenrim(jgrd) + END IF + DO i_bdy = ibeg, iend + ji = idx_bdy(jbdy)%nbi(i_bdy,jgrd) + jj = idx_bdy(jbdy)%nbj(i_bdy,jgrd) + zflag = idx_bdy(jbdy)%flagu(i_bdy,jgrd) + ! i-1 i i | ! i i i+1 | ! i i i+1 | + ! > ice > | ! o > ice | ! o > o | + ! => set at u_ice(i-1) ! => set to O ! => unchanged + IF( zflag == -1. .AND. ji > 1 .AND. ji < jpi ) THEN + IF ( vt_i(ji ,jj) > 0. ) THEN ; u_ice(ji,jj) = u_ice(ji-1,jj) + ELSEIF( vt_i(ji+1,jj) > 0. ) THEN ; u_ice(ji,jj) = u_oce(ji,jj) + END IF + END IF + ! | i i+1 i+1 ! | i i i+1 ! | i i i+1 + ! | > ice > ! | ice > o ! | o > o + ! => set at u_ice(i+1) ! => set to O ! => unchanged + IF( zflag == 1. .AND. ji+1 < jpi+1 ) THEN + IF ( vt_i(ji+1,jj) > 0. ) THEN ; u_ice(ji,jj) = u_ice(ji+1,jj) + ELSEIF( vt_i(ji ,jj) > 0. ) THEN ; u_ice(ji,jj) = u_oce(ji,jj) + END IF + END IF + ! + IF( zflag == 0. ) u_ice(ji,jj) = 0._wp ! u_ice = 0 if north/south bdy + ! + END DO + ! + CASE ( 'V' ) + jgrd = 3 ! v velocity + IF( ir == 0 ) THEN ; ibeg = 1 ; iend = idx_bdy(jbdy)%nblenrim0(jgrd) + ELSE ; ibeg = idx_bdy(jbdy)%nblenrim0(jgrd)+1 ; iend = idx_bdy(jbdy)%nblenrim(jgrd) + END IF + DO i_bdy = ibeg, iend + ji = idx_bdy(jbdy)%nbi(i_bdy,jgrd) + jj = idx_bdy(jbdy)%nbj(i_bdy,jgrd) + zflag = idx_bdy(jbdy)%flagv(i_bdy,jgrd) + ! ! ice (jj+1) ! o (jj+1) + ! ^ (jj ) ! ^ (jj ) ! ^ (jj ) + ! ice (jj ) ! o (jj ) ! o (jj ) + ! ^ (jj-1) ! ! + ! => set to u_ice(jj-1) ! => set to 0 ! => unchanged + IF( zflag == -1. .AND. jj > 1 .AND. jj < jpj ) THEN + IF ( vt_i(ji,jj ) > 0. ) THEN ; v_ice(ji,jj) = v_ice(ji,jj-1) + ELSEIF( vt_i(ji,jj+1) > 0. ) THEN ; v_ice(ji,jj) = v_oce(ji,jj) + END IF + END IF + ! ^ (jj+1) ! ! + ! ice (jj+1) ! o (jj+1) ! o (jj+1) + ! ^ (jj ) ! ^ (jj ) ! ^ (jj ) + ! ________________ ! ____ice___(jj )_ ! _____o____(jj ) + ! => set to u_ice(jj+1) ! => set to 0 ! => unchanged + IF( zflag == 1. .AND. jj < jpj ) THEN + IF ( vt_i(ji,jj+1) > 0. ) THEN ; v_ice(ji,jj) = v_ice(ji,jj+1) + ELSEIF( vt_i(ji,jj ) > 0. ) THEN ; v_ice(ji,jj) = v_oce(ji,jj) + END IF + END IF + ! + IF( zflag == 0. ) v_ice(ji,jj) = 0._wp ! v_ice = 0 if west/east bdy + ! + END DO + ! + END SELECT + ! + CASE DEFAULT + CALL ctl_stop( 'bdy_ice_dyn : unrecognised option for open boundaries for ice fields' ) + END SELECT + ! + END DO ! jbdy + ! + SELECT CASE ( cd_type ) + CASE ( 'U' ) + IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 + IF( nn_hls == 1 ) THEN ; llsend2(:) = .false. ; llrecv2(:) = .false. ; END IF + DO jbdy = 1, nb_bdy + IF( cn_ice(jbdy) == 'frs' .AND. nn_ice_dta(jbdy) /= 0 ) THEN + llsend2( : ) = llsend2( : ) .OR. lsend_bdyint(jbdy,2, : ,ir) ! possibly every direction, U points + idir3 = (/ jpwe, jpsw, jpnw /) + llsend2(idir3) = llsend2(idir3) .OR. lsend_bdyext(jbdy,2,idir3,ir) ! nei might search point towards its ea bdy + llrecv2( : ) = llrecv2( : ) .OR. lrecv_bdyint(jbdy,2, : ,ir) ! possibly every direction, U points + idir3 = (/ jpea, jpse, jpne /) + llrecv2(idir3) = llrecv2(idir3) .OR. lrecv_bdyext(jbdy,2,idir3,ir) ! might search point towards east bdy + END IF + END DO + IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdyice', u_ice, 'U', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) + END IF + CASE ( 'V' ) + IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 + IF( nn_hls == 1 ) THEN ; llsend3(:) = .false. ; llrecv3(:) = .false. ; END IF + DO jbdy = 1, nb_bdy + IF( cn_ice(jbdy) == 'frs' .AND. nn_ice_dta(jbdy) /= 0 ) THEN + llsend3( : ) = llsend3( : ) .OR. lsend_bdyint(jbdy,3, : ,ir) ! possibly every direction, V points + idir3 = (/ jpso, jpsw, jpse /) + llsend3(idir3) = llsend3(idir3) .OR. lsend_bdyext(jbdy,3,idir3,ir) ! nei might search point towards its no bdy + llrecv3( : ) = llrecv3( : ) .OR. lrecv_bdyint(jbdy,3, : ,ir) ! possibly every direction, V points + idir3 = (/ jpno, jpnw, jpne /) + llrecv3(idir3) = llrecv3(idir3) .OR. lrecv_bdyext(jbdy,3,idir3,ir) ! might search point towards north bdy + END IF + END DO + IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdyice', v_ice, 'V', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) + END IF + END SELECT + END DO ! ir + ! + IF( ln_timing ) CALL timing_stop('bdy_ice_dyn') + ! + END SUBROUTINE bdy_ice_dyn + +#else + !!--------------------------------------------------------------------------------- + !! Default option Empty module + !!--------------------------------------------------------------------------------- +CONTAINS + SUBROUTINE bdy_ice( kt ) ! Empty routine + IMPLICIT NONE + INTEGER, INTENT( in ) :: kt + WRITE(*,*) 'bdy_ice: You should not have seen this print! error?', kt + END SUBROUTINE bdy_ice +#endif + + !!================================================================================= +END MODULE bdyice \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdyini.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdyini.F90 new file mode 100644 index 0000000..1b32ec3 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdyini.F90 @@ -0,0 +1,2019 @@ +MODULE bdyini + !!====================================================================== + !! *** MODULE bdyini *** + !! Unstructured open boundaries : initialisation + !!====================================================================== + !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code + !! - ! 2007-01 (D. Storkey) Update to use IOM module + !! - ! 2007-01 (D. Storkey) Tidal forcing + !! 3.0 ! 2008-04 (NEMO team) add in the reference version + !! 3.3 ! 2010-09 (E.O'Dea) updates for Shelf configurations + !! 3.3 ! 2010-09 (D.Storkey) add ice boundary conditions + !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge + !! 3.4 ! 2012 (J. Chanut) straight open boundary case update + !! 3.5 ! 2012 (S. Mocavero, I. Epicoco) optimization of BDY communications + !! 3.7 ! 2016 (T. Lovato) Remove bdy macro, call here init for dta and tides + !!---------------------------------------------------------------------- + !! bdy_init : Initialization of unstructured open boundaries + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain + USE sbc_oce , ONLY: nn_ice + USE bdy_oce ! unstructured open boundary conditions + USE bdydta ! open boundary cond. setting (bdy_dta_init routine) + USE bdytides ! open boundary cond. setting (bdytide_init routine) + USE tide_mod, ONLY: ln_tide ! tidal forcing + USE phycst , ONLY: rday + ! + USE in_out_manager ! I/O units + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! for mpp_sum + USE iom ! I/O + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_init ! routine called in nemo_init + PUBLIC find_neib ! routine called in bdy_nmn + + INTEGER, PARAMETER :: jp_nseg = 100 ! + ! Straight open boundary segment parameters: + INTEGER :: nbdysege, nbdysegw, nbdysegn, nbdysegs + INTEGER, DIMENSION(jp_nseg) :: jpieob, jpjedt, jpjeft, npckge ! + INTEGER, DIMENSION(jp_nseg) :: jpiwob, jpjwdt, jpjwft, npckgw ! + INTEGER, DIMENSION(jp_nseg) :: jpjnob, jpindt, jpinft, npckgn ! + INTEGER, DIMENSION(jp_nseg) :: jpjsob, jpisdt, jpisft, npckgs ! + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdyini.F90 15368 2021-10-14 08:25:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_init + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_init *** + !! + !! ** Purpose : Initialization of the dynamics and tracer fields with + !! unstructured open boundaries. + !! + !! ** Method : Read initialization arrays (mask, indices) to identify + !! an unstructured open boundary + !! + !! ** Input : bdy_init.nc, input file for unstructured open boundaries + !!---------------------------------------------------------------------- + NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & + & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & + & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, & + & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & + & cn_ice, nn_ice_dta, & + & ln_vol, nn_volctl, nn_rimwidth + ! + INTEGER :: ios ! Local integer output status for namelist read + !!---------------------------------------------------------------------- + + ! ------------------------ + ! Read namelist parameters + ! ------------------------ + READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' ) + ! make sur that all elements of the namelist variables have a default definition from namelist_ref + ln_coords_file (2:jp_bdy) = ln_coords_file (1) + cn_coords_file (2:jp_bdy) = cn_coords_file (1) + cn_dyn2d (2:jp_bdy) = cn_dyn2d (1) + nn_dyn2d_dta (2:jp_bdy) = nn_dyn2d_dta (1) + cn_dyn3d (2:jp_bdy) = cn_dyn3d (1) + nn_dyn3d_dta (2:jp_bdy) = nn_dyn3d_dta (1) + cn_tra (2:jp_bdy) = cn_tra (1) + nn_tra_dta (2:jp_bdy) = nn_tra_dta (1) + ln_tra_dmp (2:jp_bdy) = ln_tra_dmp (1) + ln_dyn3d_dmp (2:jp_bdy) = ln_dyn3d_dmp (1) + rn_time_dmp (2:jp_bdy) = rn_time_dmp (1) + rn_time_dmp_out(2:jp_bdy) = rn_time_dmp_out(1) + cn_ice (2:jp_bdy) = cn_ice (1) + nn_ice_dta (2:jp_bdy) = nn_ice_dta (1) + READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist' ) + IF(lwm) WRITE ( numond, nambdy ) + + IF( .NOT. Agrif_Root() ) ln_bdy = .FALSE. ! forced for Agrif children + + IF( nb_bdy == 0 ) ln_bdy = .FALSE. + + ! ----------------------------------------- + ! unstructured open boundaries use control + ! ----------------------------------------- + IF ( ln_bdy ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'bdy_init : initialization of open boundaries' + IF(lwp) WRITE(numout,*) '~~~~~~~~' + ! + ! Open boundaries definition (arrays and masks) + CALL bdy_def + IF( ln_meshmask ) CALL bdy_meshwri() + ! + ! Open boundaries initialisation of external data arrays + CALL bdy_dta_init + ! + ! Open boundaries initialisation of tidal harmonic forcing + IF( ln_tide ) CALL bdytide_init + ! + ELSE + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'bdy_init : open boundaries not used (ln_bdy = F)' + IF(lwp) WRITE(numout,*) '~~~~~~~~' + ! + ENDIF + ! + END SUBROUTINE bdy_init + + + SUBROUTINE bdy_def + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_init *** + !! + !! ** Purpose : Definition of unstructured open boundaries. + !! + !! ** Method : Read initialization arrays (mask, indices) to identify + !! an unstructured open boundary + !! + !! ** Input : bdy_init.nc, input file for unstructured open boundaries + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ib_bdy, ii, ij, igrd, ib, ir, iseg ! dummy loop indices + INTEGER :: icount, icountr, icountr0, ibr_max ! local integers + INTEGER :: ilen1 ! - - + INTEGER :: iiRst, iiRnd, iiSst, iiSnd, iiSstdiag, iiSnddiag, iiSstsono, iiSndsono + INTEGER :: ijRst, ijRnd, ijSst, ijSnd, ijSstdiag, ijSnddiag, ijSstsono, ijSndsono + INTEGER :: iiout, ijout, iioutdir, ijoutdir, icnt + INTEGER :: iRnei, iRdiag, iRsono + INTEGER :: iSnei, iSdiag, iSsono ! - - + INTEGER :: iwe, ies, iso, ino, inum, id_dummy ! - - + INTEGER :: jpbdta ! - - + INTEGER :: ib_bdy1, ib_bdy2, ib1, ib2 ! - - + INTEGER :: ii1, ii2, ii3, ij1, ij2, ij3 ! - - + INTEGER :: iibe, ijbe, iibi, ijbi ! - - + INTEGER :: flagu, flagv ! short cuts + INTEGER :: nbdyind, nbdybeg, nbdyend + INTEGER , DIMENSION(4) :: kdimsz + INTEGER , DIMENSION(jpbgrd,jp_bdy) :: nblendta ! Length of index arrays + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbidta, nbjdta ! Index arrays: i and j indices of bdy dta + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: nbrdta ! Discrete distance from rim points + CHARACTER(LEN=1) , DIMENSION(jpbgrd) :: cgrid + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zz_read ! work space for 2D global boundary data + REAL(wp), POINTER , DIMENSION(:,:) :: zmask ! pointer to 2D mask fields + REAL(wp) , DIMENSION(jpi,jpj) :: zfmask ! temporary fmask array excluding coastal boundary condition (shlat) + REAL(wp) , DIMENSION(jpi,jpj) :: ztmask, zumask, zvmask ! temporary u/v mask array + REAL(wp) , DIMENSION(jpi,jpj) :: zzbdy + !!---------------------------------------------------------------------- + ! + cgrid = (/'t','u','v'/) + + ! ----------------------------------------- + ! Check and write out namelist parameters + ! ----------------------------------------- + + IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ', nb_bdy + + DO ib_bdy = 1,nb_bdy + + IF(lwp) THEN + WRITE(numout,*) ' ' + WRITE(numout,*) '------ Open boundary data set ',ib_bdy,' ------' + IF( ln_coords_file(ib_bdy) ) THEN + WRITE(numout,*) 'Boundary definition read from file '//TRIM(cn_coords_file(ib_bdy)) + ELSE + WRITE(numout,*) 'Boundary defined in namelist.' + ENDIF + WRITE(numout,*) + ENDIF + + ! barotropic bdy + !---------------- + IF(lwp) THEN + WRITE(numout,*) 'Boundary conditions for barotropic solution: ' + SELECT CASE( cn_dyn2d(ib_bdy) ) + CASE( 'none' ) ; WRITE(numout,*) ' no open boundary condition' + CASE( 'frs' ) ; WRITE(numout,*) ' Flow Relaxation Scheme' + CASE( 'flather' ) ; WRITE(numout,*) ' Flather radiation condition' + CASE( 'orlanski' ) ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' + CASE( 'orlanski_npo' ) ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn2d' ) + END SELECT + ENDIF + + dta_bdy(ib_bdy)%lneed_ssh = cn_dyn2d(ib_bdy) == 'flather' + dta_bdy(ib_bdy)%lneed_dyn2d = cn_dyn2d(ib_bdy) /= 'none' + + IF( lwp .AND. dta_bdy(ib_bdy)%lneed_dyn2d ) THEN + SELECT CASE( nn_dyn2d_dta(ib_bdy) ) ! + CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' + CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' + CASE( 2 ) ; WRITE(numout,*) ' tidal harmonic forcing taken from file' + CASE( 3 ) ; WRITE(numout,*) ' boundary data AND tidal harmonic forcing taken from files' + CASE DEFAULT ; CALL ctl_stop( 'nn_dyn2d_dta must be between 0 and 3' ) + END SELECT + ENDIF + IF ( dta_bdy(ib_bdy)%lneed_dyn2d .AND. nn_dyn2d_dta(ib_bdy) .GE. 2 .AND. .NOT.ln_tide ) THEN + CALL ctl_stop( 'You must activate with ln_tide to add tidal forcing at open boundaries' ) + ENDIF + IF(lwp) WRITE(numout,*) + + ! baroclinic bdy + !---------------- + IF(lwp) THEN + WRITE(numout,*) 'Boundary conditions for baroclinic velocities: ' + SELECT CASE( cn_dyn3d(ib_bdy) ) + CASE('none') ; WRITE(numout,*) ' no open boundary condition' + CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' + CASE('specified') ; WRITE(numout,*) ' Specified value' + CASE('neumann') ; WRITE(numout,*) ' Neumann conditions' + CASE('zerograd') ; WRITE(numout,*) ' Zero gradient for baroclinic velocities' + CASE('zero') ; WRITE(numout,*) ' Zero baroclinic velocities (runoff case)' + CASE('orlanski') ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' + CASE('orlanski_npo') ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn3d' ) + END SELECT + ENDIF + + dta_bdy(ib_bdy)%lneed_dyn3d = cn_dyn3d(ib_bdy) == 'frs' .OR. cn_dyn3d(ib_bdy) == 'specified' & + & .OR. cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo' + + IF( lwp .AND. dta_bdy(ib_bdy)%lneed_dyn3d ) THEN + SELECT CASE( nn_dyn3d_dta(ib_bdy) ) ! + CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' + CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' + CASE DEFAULT ; CALL ctl_stop( 'nn_dyn3d_dta must be 0 or 1' ) + END SELECT + END IF + + IF ( ln_dyn3d_dmp(ib_bdy) ) THEN + IF ( cn_dyn3d(ib_bdy) == 'none' ) THEN + IF(lwp) WRITE(numout,*) 'No open boundary condition for baroclinic velocities: ln_dyn3d_dmp is set to .false.' + ln_dyn3d_dmp(ib_bdy) = .false. + ELSEIF ( cn_dyn3d(ib_bdy) == 'frs' ) THEN + CALL ctl_stop( 'Use FRS OR relaxation' ) + ELSE + IF(lwp) WRITE(numout,*) ' + baroclinic velocities relaxation zone' + IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days' + IF(rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) + dta_bdy(ib_bdy)%lneed_dyn3d = .TRUE. + ENDIF + ELSE + IF(lwp) WRITE(numout,*) ' NO relaxation on baroclinic velocities' + ENDIF + IF(lwp) WRITE(numout,*) + + ! tra bdy + !---------------- + IF(lwp) THEN + WRITE(numout,*) 'Boundary conditions for temperature and salinity: ' + SELECT CASE( cn_tra(ib_bdy) ) + CASE('none') ; WRITE(numout,*) ' no open boundary condition' + CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' + CASE('specified') ; WRITE(numout,*) ' Specified value' + CASE('neumann') ; WRITE(numout,*) ' Neumann conditions' + CASE('runoff') ; WRITE(numout,*) ' Runoff conditions : Neumann for T and specified to 0.1 for salinity' + CASE('orlanski') ; WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' + CASE('orlanski_npo') ; WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_tra' ) + END SELECT + ENDIF + + dta_bdy(ib_bdy)%lneed_tra = cn_tra(ib_bdy) == 'frs' .OR. cn_tra(ib_bdy) == 'specified' & + & .OR. cn_tra(ib_bdy) == 'orlanski' .OR. cn_tra(ib_bdy) == 'orlanski_npo' + + IF( lwp .AND. dta_bdy(ib_bdy)%lneed_tra ) THEN + SELECT CASE( nn_tra_dta(ib_bdy) ) ! + CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' + CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' + CASE DEFAULT ; CALL ctl_stop( 'nn_tra_dta must be 0 or 1' ) + END SELECT + ENDIF + + IF ( ln_tra_dmp(ib_bdy) ) THEN + IF ( cn_tra(ib_bdy) == 'none' ) THEN + IF(lwp) WRITE(numout,*) 'No open boundary condition for tracers: ln_tra_dmp is set to .false.' + ln_tra_dmp(ib_bdy) = .false. + ELSEIF ( cn_tra(ib_bdy) == 'frs' ) THEN + CALL ctl_stop( 'Use FRS OR relaxation' ) + ELSE + IF(lwp) WRITE(numout,*) ' + T/S relaxation zone' + IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days' + IF(lwp) WRITE(numout,*) ' Outflow damping time scale: ',rn_time_dmp_out(ib_bdy),' days' + IF(lwp.AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) + dta_bdy(ib_bdy)%lneed_tra = .TRUE. + ENDIF + ELSE + IF(lwp) WRITE(numout,*) ' NO T/S relaxation' + ENDIF + IF(lwp) WRITE(numout,*) + +#if defined key_si3 + IF(lwp) THEN + WRITE(numout,*) 'Boundary conditions for sea ice: ' + SELECT CASE( cn_ice(ib_bdy) ) + CASE('none') ; WRITE(numout,*) ' no open boundary condition' + CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_ice' ) + END SELECT + ENDIF + + dta_bdy(ib_bdy)%lneed_ice = cn_ice(ib_bdy) /= 'none' + + IF( dta_bdy(ib_bdy)%lneed_ice .AND. nn_ice /= 2 ) THEN + WRITE(ctmp1,*) 'bdy number ', ib_bdy,', needs ice model but nn_ice = ', nn_ice + CALL ctl_stop( ctmp1 ) + ENDIF + + IF( lwp .AND. dta_bdy(ib_bdy)%lneed_ice ) THEN + SELECT CASE( nn_ice_dta(ib_bdy) ) ! + CASE( 0 ) ; WRITE(numout,*) ' initial state used for bdy data' + CASE( 1 ) ; WRITE(numout,*) ' boundary data taken from file' + CASE DEFAULT ; CALL ctl_stop( 'nn_ice_dta must be 0 or 1' ) + END SELECT + ENDIF +#else + dta_bdy(ib_bdy)%lneed_ice = .FALSE. +#endif + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Width of relaxation zone = ', nn_rimwidth(ib_bdy) + IF(lwp) WRITE(numout,*) + ! + END DO ! nb_bdy + + IF( lwp ) THEN + IF( ln_vol ) THEN ! check volume conservation (nn_volctl value) + WRITE(numout,*) 'Volume correction applied at open boundaries' + WRITE(numout,*) + SELECT CASE ( nn_volctl ) + CASE( 1 ) ; WRITE(numout,*) ' The total volume will be constant' + CASE( 0 ) ; WRITE(numout,*) ' The total volume will vary according to the surface E-P flux' + CASE DEFAULT ; CALL ctl_stop( 'nn_volctl must be 0 or 1' ) + END SELECT + WRITE(numout,*) + ! + ! sanity check if used with tides + IF( ln_tide ) THEN + WRITE(numout,*) ' The total volume correction is not working with tides. ' + WRITE(numout,*) ' Set ln_vol to .FALSE. ' + WRITE(numout,*) ' or ' + WRITE(numout,*) ' equilibriate your bdy input files ' + CALL ctl_stop( 'The total volume correction is not working with tides.' ) + END IF + ELSE + WRITE(numout,*) 'No volume correction applied at open boundaries' + WRITE(numout,*) + ENDIF + ENDIF + + ! ------------------------------------------------- + ! Initialise indices arrays for open boundaries + ! ------------------------------------------------- + + nblendta(:,:) = 0 + nbdysege = 0 + nbdysegw = 0 + nbdysegn = 0 + nbdysegs = 0 + + ! Define all boundaries + ! --------------------- + DO ib_bdy = 1, nb_bdy + ! + IF( .NOT. ln_coords_file(ib_bdy) ) THEN ! build bdy coordinates with segments defined in namelist + + CALL bdy_read_seg( ib_bdy, nblendta(:,ib_bdy) ) + + ELSE ! Read size of arrays in boundary coordinates file. + + CALL iom_open( cn_coords_file(ib_bdy), inum ) + DO igrd = 1, jpbgrd + id_dummy = iom_varid( inum, 'nbi'//cgrid(igrd), kdimsz=kdimsz ) + nblendta(igrd,ib_bdy) = MAXVAL(kdimsz) + END DO + CALL iom_close( inum ) + ENDIF + ! + END DO ! ib_bdy + + ! Now look for crossings in user (namelist) defined open boundary segments: + IF( nbdysege > 0 .OR. nbdysegw > 0 .OR. nbdysegn > 0 .OR. nbdysegs > 0) CALL bdy_ctl_seg + + ! Allocate arrays + !--------------- + jpbdta = MAXVAL(nblendta(1:jpbgrd,1:nb_bdy)) + ALLOCATE( nbidta(jpbdta, jpbgrd, nb_bdy), nbjdta(jpbdta, jpbgrd, nb_bdy), nbrdta(jpbdta, jpbgrd, nb_bdy) ) + nbrdta(:,:,:) = 0 ! initialize nbrdta as it may not be completely defined for each bdy + + ! Calculate global boundary index arrays or read in from file + !------------------------------------------------------------ + ! 1. Read global index arrays from boundary coordinates file. + DO ib_bdy = 1, nb_bdy + ! + IF( ln_coords_file(ib_bdy) ) THEN + ! + ALLOCATE( zz_read( MAXVAL(nblendta), 1 ) ) + CALL iom_open( cn_coords_file(ib_bdy), inum ) + ! + DO igrd = 1, jpbgrd + CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) + DO ii = 1,nblendta(igrd,ib_bdy) + nbidta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) + nn_hls + END DO + CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) + DO ii = 1,nblendta(igrd,ib_bdy) + nbjdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) + nn_hls + END DO + CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) + DO ii = 1,nblendta(igrd,ib_bdy) + nbrdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) + END DO + ! + ibr_max = MAXVAL( nbrdta(:,igrd,ib_bdy) ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Maximum rimwidth in file is ', ibr_max + IF(lwp) WRITE(numout,*) ' nn_rimwidth from namelist is ', nn_rimwidth(ib_bdy) + IF (ibr_max < nn_rimwidth(ib_bdy)) & + CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_bdy) ) + END DO + ! + CALL iom_close( inum ) + DEALLOCATE( zz_read ) + ! + ENDIF + ! + END DO + + ! 2. Now fill indices corresponding to straight open boundary arrays: + CALL bdy_coords_seg( nbidta, nbjdta, nbrdta ) + + ! Deal with duplicated points + !----------------------------- + ! We assign negative indices to duplicated points (to remove them from bdy points to be updated) + ! if their distance to the bdy is greater than the other + ! If their distance are the same, just keep only one to avoid updating a point twice + DO igrd = 1, jpbgrd + DO ib_bdy1 = 1, nb_bdy + DO ib_bdy2 = 1, nb_bdy + IF (ib_bdy1/=ib_bdy2) THEN + DO ib1 = 1, nblendta(igrd,ib_bdy1) + DO ib2 = 1, nblendta(igrd,ib_bdy2) + IF ((nbidta(ib1, igrd, ib_bdy1)==nbidta(ib2, igrd, ib_bdy2)).AND. & + & (nbjdta(ib1, igrd, ib_bdy1)==nbjdta(ib2, igrd, ib_bdy2))) THEN + ! IF ((lwp).AND.(igrd==1)) WRITE(numout,*) ' found coincident point ji, jj:', & + ! & nbidta(ib1, igrd, ib_bdy1), & + ! & nbjdta(ib2, igrd, ib_bdy2) + ! keep only points with the lowest distance to boundary: + IF (nbrdta(ib1, igrd, ib_bdy1)nbrdta(ib2, igrd, ib_bdy2)) THEN + nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 + nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 + ! Arbitrary choice if distances are the same: + ELSE + nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 + nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 + ENDIF + END IF + END DO + END DO + ENDIF + END DO + END DO + END DO + ! + ! Find lenght of boundaries and rim on local mpi domain + !------------------------------------------------------ + ! + iwe = mig(1) + ies = mig(jpi) + iso = mjg(1) + ino = mjg(jpj) + ! + DO ib_bdy = 1, nb_bdy + DO igrd = 1, jpbgrd + icount = 0 ! initialization of local bdy length + icountr = 0 ! initialization of local rim 0 and rim 1 bdy length + icountr0 = 0 ! initialization of local rim 0 bdy length + idx_bdy(ib_bdy)%nblen(igrd) = 0 + idx_bdy(ib_bdy)%nblenrim(igrd) = 0 + idx_bdy(ib_bdy)%nblenrim0(igrd) = 0 + DO ib = 1, nblendta(igrd,ib_bdy) + ! check that data is in correct order in file + IF( ib > 1 ) THEN + IF( nbrdta(ib,igrd,ib_bdy) < nbrdta(ib-1,igrd,ib_bdy) ) THEN + CALL ctl_stop('bdy_segs : ERROR : boundary data in file must be defined ', & + & ' in order of distance from edge nbr A utility for re-ordering ', & + & ' boundary coordinates and data files exists in the TOOLS/OBC directory') + ENDIF + ENDIF + ! check if point is in local domain + IF( nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND. & + & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino ) THEN + ! + icount = icount + 1 + IF( nbrdta(ib,igrd,ib_bdy) == 1 .OR. nbrdta(ib,igrd,ib_bdy) == 0 ) icountr = icountr + 1 + IF( nbrdta(ib,igrd,ib_bdy) == 0 ) icountr0 = icountr0 + 1 + ENDIF + END DO + idx_bdy(ib_bdy)%nblen (igrd) = icount !: length of boundary data on each proc + idx_bdy(ib_bdy)%nblenrim (igrd) = icountr !: length of rim 0 and rim 1 boundary data on each proc + idx_bdy(ib_bdy)%nblenrim0(igrd) = icountr0 !: length of rim 0 boundary data on each proc + END DO ! igrd + + ! Allocate index arrays for this boundary set + !-------------------------------------------- + ilen1 = MAXVAL( idx_bdy(ib_bdy)%nblen(:) ) + ALLOCATE( idx_bdy(ib_bdy)%nbi (ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%nbj (ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%nbr (ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%nbd (ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%nbdout(ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%ntreat(ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%nbmap (ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%nbw (ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%flagu (ilen1,jpbgrd) , & + & idx_bdy(ib_bdy)%flagv (ilen1,jpbgrd) ) + + ! Dispatch mapping indices and discrete distances on each processor + ! ----------------------------------------------------------------- + DO igrd = 1, jpbgrd + icount = 0 + ! Outer loop on rimwidth to ensure outermost points come first in the local arrays. + DO ir = 0, nn_rimwidth(ib_bdy) + DO ib = 1, nblendta(igrd,ib_bdy) + ! check if point is in local domain and equals ir + IF( nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND. & + & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino .AND. & + & nbrdta(ib,igrd,ib_bdy) == ir ) THEN + ! + icount = icount + 1 + idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy) - mig(1) + 1 ! global to local indexes + idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy) - mjg(1) + 1 ! global to local indexes + idx_bdy(ib_bdy)%nbr(icount,igrd) = nbrdta(ib,igrd,ib_bdy) + idx_bdy(ib_bdy)%nbmap(icount,igrd) = ib + ENDIF + END DO + END DO + END DO ! igrd + + END DO ! ib_bdy + + ! Initialize array indicating communications in bdy + ! ------------------------------------------------- + ALLOCATE( lsend_bdyolr(nb_bdy,jpbgrd,8,0:1), lrecv_bdyolr(nb_bdy,jpbgrd,8,0:1) ) + lsend_bdyolr(:,:,:,:) = .false. + lrecv_bdyolr(:,:,:,:) = .false. + + DO ib_bdy = 1, nb_bdy + DO igrd = 1, jpbgrd + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! only the rim triggers communications, see bdy routines + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( ib .LE. idx_bdy(ib_bdy)%nblenrim0(igrd) ) THEN ; ir = 0 + ELSE ; ir = 1 + END IF + ! + ! check if point has to be sent to a neighbour + IF( ii >= Nis0 .AND. ii < Nis0 + nn_hls .AND. ij >= Njs0 .AND. ij <= Nje0 ) THEN ! we inner side + IF( mpiSnei(nn_hls,jpwe) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpwe,ir) = .TRUE. + ENDIF + IF( ii <= Nie0 .AND. ii > Nie0 - nn_hls .AND. ij >= Njs0 .AND. ij <= Nje0 ) THEN ! ea inner side + IF( mpiSnei(nn_hls,jpea) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpea,ir) = .TRUE. + ENDIF + IF( ii >= Nis0 .AND. ii <= Nie0 .AND. ij >= Njs0 .AND. ij < Njs0 + nn_hls ) THEN ! so inner side + IF( mpiSnei(nn_hls,jpso) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpso,ir) = .TRUE. + ENDIF + IF( ii < Nis0 .AND. ij >= Njs0 .AND. ij < Njs0 + nn_hls ) THEN ! so side we-halo + IF( mpiSnei(nn_hls,jpso) > -1 .AND. nn_comm == 1 ) lsend_bdyolr(ib_bdy,igrd,jpso,ir) = .TRUE. + ENDIF + IF( ii > Nie0 .AND. ij >= Njs0 .AND. ij < Njs0 + nn_hls ) THEN ! so side ea-halo + IF( mpiSnei(nn_hls,jpso) > -1 .AND. nn_comm == 1 ) lsend_bdyolr(ib_bdy,igrd,jpso,ir) = .TRUE. + ENDIF + IF( ii >= Nis0 .AND. ii <= Nie0 .AND. ij <= Nje0 .AND. ij > Nje0 - nn_hls ) THEN ! no inner side + IF( mpiSnei(nn_hls,jpno) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpno,ir) = .TRUE. + ENDIF + IF( ii < Nis0 .AND. ij <= Nje0 .AND. ij > Nje0 - nn_hls ) THEN ! no side we-halo + IF( mpiSnei(nn_hls,jpno) > -1 .AND. nn_comm == 1 ) lsend_bdyolr(ib_bdy,igrd,jpno,ir) = .TRUE. + ENDIF + IF( ii > Nie0 .AND. ij <= Nje0 .AND. ij > Nje0 - nn_hls ) THEN ! no side ea-halo + IF( mpiSnei(nn_hls,jpno) > -1 .AND. nn_comm == 1 ) lsend_bdyolr(ib_bdy,igrd,jpno,ir) = .TRUE. + ENDIF + IF( ii >= Nis0 .AND. ii < Nis0 + nn_hls .AND. ij >= Njs0 .AND. ij < Njs0 + nn_hls ) THEN ! sw inner corner + IF( mpiSnei(nn_hls,jpsw) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpsw,ir) = .TRUE. + ENDIF + IF( ii <= Nie0 .AND. ii > Nie0 - nn_hls .AND. ij >= Njs0 .AND. ij < Njs0 + nn_hls ) THEN ! se inner corner + IF( mpiSnei(nn_hls,jpse) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpse,ir) = .TRUE. + ENDIF + IF( ii >= Nis0 .AND. ii < Nis0 + nn_hls .AND. ij <= Nje0 .AND. ij > Nje0 - nn_hls ) THEN ! nw inner corner + IF( mpiSnei(nn_hls,jpnw) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpnw,ir) = .TRUE. + ENDIF + IF( ii <= Nie0 .AND. ii > Nie0 - nn_hls .AND. ij <= Nje0 .AND. ij > Nje0 - nn_hls ) THEN ! ne inner corner + IF( mpiSnei(nn_hls,jpne) > -1 ) lsend_bdyolr(ib_bdy,igrd,jpne,ir) = .TRUE. + ENDIF + ! + ! check if point has to be received from a neighbour + IF( ii < Nis0 .AND. ij >= Njs0 .AND. ij <= Nje0 ) THEN ! we side + IF( mpiRnei(nn_hls,jpwe) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpwe,ir) = .TRUE. + ENDIF + IF( ii > Nie0 .AND. ij >= Njs0 .AND. ij <= Nje0 ) THEN ! ea side + IF( mpiRnei(nn_hls,jpea) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpea,ir) = .TRUE. + ENDIF + IF( ii >= Nis0 .AND. ii <= Nie0 .AND. ij < Njs0 ) THEN ! so side + IF( mpiRnei(nn_hls,jpso) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpso,ir) = .TRUE. + ENDIF + IF( ii >= Nis0 .AND. ii <= Nie0 .AND. ij > Nje0 ) THEN ! no side + IF( mpiRnei(nn_hls,jpno) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpno,ir) = .TRUE. + ENDIF + IF( ii < Nis0 .AND. ij < Njs0 ) THEN ! sw corner + IF( mpiRnei(nn_hls,jpsw) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpsw,ir) = .TRUE. + IF( mpiRnei(nn_hls,jpso) > -1 .AND. nn_comm == 1 ) lrecv_bdyolr(ib_bdy,igrd,jpso,ir) = .TRUE. + ENDIF + IF( ii > Nie0 .AND. ij < Njs0 ) THEN ! se corner + IF( mpiRnei(nn_hls,jpse) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpse,ir) = .TRUE. + IF( mpiRnei(nn_hls,jpso) > -1 .AND. nn_comm == 1 ) lrecv_bdyolr(ib_bdy,igrd,jpso,ir) = .TRUE. + ENDIF + IF( ii < Nis0 .AND. ij > Nje0 ) THEN ! nw corner + IF( mpiRnei(nn_hls,jpnw) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpnw,ir) = .TRUE. + IF( mpiRnei(nn_hls,jpno) > -1 .AND. nn_comm == 1 ) lrecv_bdyolr(ib_bdy,igrd,jpno,ir) = .TRUE. + ENDIF + IF( ii > Nie0 .AND. ij > Nje0 ) THEN ! ne corner + IF( mpiRnei(nn_hls,jpne) > -1 ) lrecv_bdyolr(ib_bdy,igrd,jpne,ir) = .TRUE. + IF( mpiRnei(nn_hls,jpno) > -1 .AND. nn_comm == 1 ) lrecv_bdyolr(ib_bdy,igrd,jpno,ir) = .TRUE. + ENDIF + ! + END DO + END DO ! igrd + + ! Comment out for debug +!!$ DO ir = 0,1 +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'T', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyolr(ib_bdy,1,:,ir), lrecv = lrecv_bdyolr(ib_bdy,1,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' seb bdy debug olr T', ir ; CALL FLUSH(numout) +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'U', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyolr(ib_bdy,2,:,ir), lrecv = lrecv_bdyolr(ib_bdy,2,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' seb bdy debug olr U', ir ; CALL FLUSH(numout) +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'V', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyolr(ib_bdy,3,:,ir), lrecv = lrecv_bdyolr(ib_bdy,3,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' seb bdy debug olr V', ir ; CALL FLUSH(numout) +!!$ END DO + + ! Compute rim weights for FRS scheme + ! ---------------------------------- + DO igrd = 1, jpbgrd + DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) + ir = MAX( 1, idx_bdy(ib_bdy)%nbr(ib,igrd) ) ! both rim 0 and rim 1 have the same weights + idx_bdy(ib_bdy)%nbw(ib,igrd) = 1.- TANH( REAL( ir - 1 ) *0.5 ) ! tanh formulation + ! idx_bdy(ib_bdy)%nbw(ib,igrd) = (REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic + ! idx_bdy(ib_bdy)%nbw(ib,igrd) = REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)) ! linear + END DO + END DO + + ! Compute damping coefficients + ! ---------------------------- + DO igrd = 1, jpbgrd + DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) + ir = MAX( 1, idx_bdy(ib_bdy)%nbr(ib,igrd) ) ! both rim 0 and rim 1 have the same damping coefficients + idx_bdy(ib_bdy)%nbd(ib,igrd) = 1. / ( rn_time_dmp(ib_bdy) * rday ) & + & *(REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic + idx_bdy(ib_bdy)%nbdout(ib,igrd) = 1. / ( rn_time_dmp_out(ib_bdy) * rday ) & + & *(REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic + END DO + END DO + + END DO ! ib_bdy + + ! ------------------------------------------------------ + ! Initialise masks and find normal/tangential directions + ! ------------------------------------------------------ + + ! ------------------------------------------ + ! handle rim0, do as if rim 1 was free ocean + ! ------------------------------------------ + + ztmask(:,:) = tmask(:,:,1) ; zumask(:,:) = umask(:,:,1) ; zvmask(:,:) = vmask(:,:,1) + ! For the flagu/flagv calculation below we require a version of fmask without + ! the land boundary condition (shlat) included: + DO_2D( 0, 0, 0, 0 ) + zfmask(ji,jj) = ztmask(ji,jj ) * ztmask(ji+1,jj ) & + & * ztmask(ji,jj+1) * ztmask(ji+1,jj+1) + END_2D + CALL lbc_lnk( 'bdyini', zfmask, 'F', 1.0_wp ) + + ! Read global 2D mask at T-points: bdytmask + ! ----------------------------------------- + ! bdytmask = 1 on the computational domain but not on open boundaries + ! = 0 elsewhere + + bdytmask(:,:) = ssmask(:,:) + + ! Derive mask on U and V grid from mask on T grid + DO_2D( 0, 0, 0, 0 ) + bdyumask(ji,jj) = bdytmask(ji,jj) * bdytmask(ji+1,jj ) + bdyvmask(ji,jj) = bdytmask(ji,jj) * bdytmask(ji ,jj+1) + END_2D + CALL lbc_lnk( 'bdyini', bdyumask, 'U', 1.0_wp , bdyvmask, 'V', 1.0_wp ) ! Lateral boundary cond. + + ! bdy masks are now set to zero on rim 0 points: + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1) ! extent of rim 0 + bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp + END DO + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2) ! extent of rim 0 + bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp + END DO + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3) ! extent of rim 0 + bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp + END DO + END DO + + CALL bdy_rim_treat( zumask, zvmask, zfmask, .true. ) ! compute flagu, flagv, ntreat on rim 0 + + ! ------------------------------------ + ! handle rim1, do as if rim 0 was land + ! ------------------------------------ + + ! z[tuv]mask are now set to zero on rim 0 points: + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1) ! extent of rim 0 + ztmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp + END DO + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2) ! extent of rim 0 + zumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp + END DO + DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3) ! extent of rim 0 + zvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp + END DO + END DO + + ! Recompute zfmask + DO_2D( 0, 0, 0, 0 ) + zfmask(ji,jj) = ztmask(ji,jj ) * ztmask(ji+1,jj ) & + & * ztmask(ji,jj+1) * ztmask(ji+1,jj+1) + END_2D + CALL lbc_lnk( 'bdyini', zfmask, 'F', 1.0_wp ) + + ! bdy masks are now set to zero on rim1 points: + DO ib_bdy = 1, nb_bdy + DO ib = idx_bdy(ib_bdy)%nblenrim0(1) + 1, idx_bdy(ib_bdy)%nblenrim(1) ! extent of rim 1 + bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp + END DO + DO ib = idx_bdy(ib_bdy)%nblenrim0(2) + 1, idx_bdy(ib_bdy)%nblenrim(2) ! extent of rim 1 + bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp + END DO + DO ib = idx_bdy(ib_bdy)%nblenrim0(3) + 1, idx_bdy(ib_bdy)%nblenrim(3) ! extent of rim 1 + bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp + END DO + END DO + + CALL bdy_rim_treat( zumask, zvmask, zfmask, .false. ) ! compute flagu, flagv, ntreat on rim 1 + ! + ! Check which boundaries might need communication + ALLOCATE( lsend_bdyint(nb_bdy,jpbgrd,8,0:1), lrecv_bdyint(nb_bdy,jpbgrd,8,0:1) ) + lsend_bdyint(:,:,:,:) = .false. + lrecv_bdyint(:,:,:,:) = .false. + ALLOCATE( lsend_bdyext(nb_bdy,jpbgrd,8,0:1), lrecv_bdyext(nb_bdy,jpbgrd,8,0:1) ) + lsend_bdyext(:,:,:,:) = .false. + lrecv_bdyext(:,:,:,:) = .false. + ! + DO ib_bdy = 1, nb_bdy + DO igrd = 1, jpbgrd + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) + IF( idx_bdy(ib_bdy)%ntreat(ib,igrd) == -1 ) CYCLE + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + ir = idx_bdy(ib_bdy)%nbr(ib,igrd) + flagu = NINT(idx_bdy(ib_bdy)%flagu(ib,igrd)) + flagv = NINT(idx_bdy(ib_bdy)%flagv(ib,igrd)) + iibe = ii - flagu ! neighbouring point towards the exterior of the computational domain + ijbe = ij - flagv + iibi = ii + flagu ! neighbouring point towards the interior of the computational domain + ijbi = ij + flagv + CALL find_neib( ii, ij, idx_bdy(ib_bdy)%ntreat(ib,igrd), ii1, ij1, ii2, ij2, ii3, ij3 ) ! free ocean neighbours + ! + ! take care of the 4 sides + ! + DO icnt = 1, 4 + SELECT CASE( icnt ) + ! ... _____ + CASE( 1 ) ! x: rim on rcvwe/sndea-side o| : + ! o: potential neighbour(s) o|x : + ! outside of the MPI domain ..o|__:__ + iRnei = jpwe ; iSnei = jpea + iiRst = 1 ; ijRst = Njs0 ! Rcv we-side starting point, excluding sw-corner + iiRnd = nn_hls ; ijRnd = Nje0 ! Rcv we-side ending point, excluding nw-corner + iiSst = Nie0-nn_hls+1 ; ijSst = Njs0 ! Snd ea-side starting point, excluding se-corner + iiSnd = Nie0 ; ijSnd = Nje0 ! Snd ea-side ending point, excluding ne-corner + iioutdir = -1 ; ijoutdir = -999 ! outside MPI domain: westward + ! ______.... + CASE( 2 ) ! x: rim on rcvea/sndwe-side : |o + ! o: potential neighbour(s) : x|o + ! outside of the MPI domain ___:__|o.. + iRnei = jpea ; iSnei = jpwe + iiRst = Nie0+1 ; ijRst = Njs0 ! Rcv ea-side starting point, excluding se-corner + iiRnd = jpi ; ijRnd = Nje0 ! Rcv ea-side ending point, excluding ne-corner + iiSst = Nis0 ; ijSst = Njs0 ! Snd we-side starting point, excluding sw-corner + iiSnd = Nis0+nn_hls-1 ; ijSnd = Nje0 ! Snd we-side ending point, excluding nw-corner + iioutdir = 1 ; ijoutdir = -999 ! outside MPI domain: eastward + ! + CASE( 3 ) ! x: rim on rcvso/sndno-side | | + ! o: potential neighbour(s) |¨¨¨¨¨¨¨| + ! outside of the MPI domain |___x___| + ! : o o o : + ! : : + iRnei = jpso ; iSnei = jpno + iiRst = Nis0 ; ijRst = 1 ! Rcv so-side starting point, excluding sw-corner + iiRnd = Nie0 ; ijRnd = nn_hls ! Rcv so-side ending point, excluding se-corner + iiSst = Nis0 ; ijSst = Nje0-nn_hls+1 ! Snd no-side starting point, excluding nw-corner + iiSnd = Nie0 ; ijSnd = Nje0 ! Snd no-side ending point, excluding ne-corner + iioutdir = -999 ; ijoutdir = -1 ! outside MPI domain: southward + ! : : + CASE( 4 ) ! x: rim on rcvno/sndso-side :_o_o_o_: + ! o: potential neighbour(s) | x | + ! outside of the MPI domain | | + ! |¨¨¨¨¨¨¨| + iRnei = jpno ; iSnei = jpso + iiRst = Nis0 ; ijRst = Nje0+1 ! Rcv no-side starting point, excluding nw-corner + iiRnd = Nie0 ; ijRnd = jpj ! Rcv no-side ending point, excluding ne-corner + iiSst = Nis0 ; ijSst = Njs0 ! Snd so-side starting point, excluding sw-corner + iiSnd = Nie0 ; ijSnd = Njs0+nn_hls-1 ! Snd so-side ending point, excluding se-corner + iioutdir = -999 ; ijoutdir = 1 ! outside MPI domain: northward + END SELECT + ! + IF( ii >= iiRst .AND. ii <= iiRnd .AND. ij >= ijRst .AND. ij <= ijRnd ) THEN ! rim point in recv side + iiout = ii+iioutdir ; ijout = ij+ijoutdir ! in which direction do we go outside of the MPI domain? + ! take care of neighbourg(s) in the interior of the computational domain + IF( iibi==iiout .OR. ii1==iiout .OR. ii2==iiout .OR. ii3==iiout .OR. & ! Neib outside of the MPI domain + & ijbi==ijout .OR. ij1==ijout .OR. ij2==ijout .OR. ij3==ijout ) THEN ! -> I cannot compute it -> recv it + IF( mpiRnei(nn_hls,iRnei) > -1 ) lrecv_bdyint(ib_bdy,igrd,iRnei,ir) = .TRUE. + ENDIF + ! take care of neighbourg in the exterior of the computational domain + IF( iibe==iiout .OR. ijbe==ijout ) THEN ! Neib outside of the MPI domain -> I cannot compute it -> recv it + IF( mpiRnei(nn_hls,iRnei) > -1 ) lrecv_bdyext(ib_bdy,igrd,iRnei,ir) = .TRUE. + ENDIF + ENDIF + + IF( ii >= iiSst .AND. ii <= iiSnd .AND. ij >= ijSst .AND. ij <= ijSnd ) THEN ! rim point in send side + iiout = ii+iioutdir ; ijout = ij+ijoutdir ! in which direction do we go outside of the nei MPI domain? + ! take care of neighbourg(s) in the interior of the computational domain + IF( iibi==iiout .OR. ii1==iiout .OR. ii2==iiout .OR. ii3==iiout .OR. & ! Neib outside of nei MPI domain + & ijbi==ijout .OR. ij1==ijout .OR. ij2==ijout .OR. ij3==ijout ) THEN ! -> nei cannot compute it + IF( mpiSnei(nn_hls,iSnei) > -1 ) lsend_bdyint(ib_bdy,igrd,iSnei,ir) = .TRUE. ! -> send to nei + ENDIF + ! take care of neighbourg in the exterior of the computational domain + IF( iibe == iiout .OR. ijbe == ijout ) THEN ! Neib outside of the nei MPI domain -> nei cannot compute it + IF( mpiSnei(nn_hls,iSnei) > -1 ) lsend_bdyext(ib_bdy,igrd,iSnei,ir) = .TRUE. ! -> send to nei + ENDIF + END IF + + END DO ! 4 sides + ! + ! specific treatment for the corners + ! + DO icnt = 1, 4 + SELECT CASE( icnt ) + ! ...|.... + CASE( 1 ) ! x: rim on sw-corner o| : + ! o: potential neighbour(s) o|x__:__ + ! outside of the MPI domain o o o: + ! : + iRdiag = jpsw ; iRsono = jpso ! Recv: for sw or so + iSdiag = jpne ; iSsono = jpno ! Send: to ne or no + iiRst = 1 ; ijRst = 1 ! Rcv sw-corner starting point + iiRnd = nn_hls ; ijRnd = nn_hls ! Rcv sw-corner ending point + iiSstdiag = Nie0-nn_hls+1 ; ijSstdiag = Nje0-nn_hls+1 ! send to sw-corner of ne neighbourg + iiSnddiag = Nie0 ; ijSnddiag = Nje0 ! send to sw-corner of ne neighbourg + iiSstsono = 1 ; ijSstsono = Nje0-nn_hls+1 ! send to sw-corner of no neighbourg + iiSndsono = nn_hls ; ijSndsono = Nje0 ! send to sw-corner of no neighbourg + iioutdir = -1 ; ijoutdir = -1 ! outside MPI domain: westward or southward + ! ....|... + CASE( 2 ) ! x: rim on se-corner : |o + ! o: potential neighbour(s) __:__x|o + ! outside of the MPI domain :o o o + ! : + iRdiag = jpse ; iRsono = jpso ! Recv: for se or so + iSdiag = jpnw ; iSsono = jpno ! Send: to nw or no + iiRst = Nie0+1 ; ijRst = 1 ! Rcv se-corner starting point + iiRnd = jpi ; ijRnd = nn_hls ! Rcv se-corner ending point + iiSstdiag = Nis0 ; ijSstdiag = Nje0-nn_hls+1 ! send to se-corner of nw neighbourg + iiSnddiag = Nis0+nn_hls-1 ; ijSnddiag = Nje0 ! send to se-corner of nw neighbourg + iiSstsono = Nie0+1 ; ijSstsono = Nje0-nn_hls+1 ! send to se-corner of no neighbourg + iiSndsono = jpi ; ijSndsono = Nje0 ! send to se-corner of no neighbourg + iioutdir = 1 ; ijoutdir = -1 ! outside MPI domain: eastward or southward + ! : + ! o o_o:___ + CASE( 3 ) ! x: rim on nw-corner o|x : + ! o: potential neighbour(s) ..o|...: + ! outside of the MPI domain | + iRdiag = jpnw ; iRsono = jpno ! Recv: for nw or no + iSdiag = jpse ; iSsono = jpso ! Send: to se or so + iiRst = 1 ; ijRst = Nje0+1 ! Rcv nw-corner starting point + iiRnd = nn_hls ; ijRnd = jpj ! Rcv nw-corner ending point + iiSstdiag = Nie0-nn_hls+1 ; ijSstdiag = Njs0 ! send to nw-corner of se neighbourg + iiSnddiag = Nie0 ; ijSnddiag = Njs0+nn_hls-1 ! send to nw-corner of se neighbourg + iiSstsono = 1 ; ijSstsono = Njs0 ! send to nw-corner of so neighbourg + iiSndsono = nn_hls ; ijSndsono = Njs0+nn_hls-1 ! send to nw-corner of so neighbourg + iioutdir = -1 ; ijoutdir = 1 ! outside MPI domain: westward or northward + ! : + ! ___:o_o o + CASE( 4 ) ! x: rim on ne-corner : x|o + ! o: potential neighbour(s) :...|o... + ! outside of the MPI domain | + iRdiag = jpne ; iRsono = jpno ! Recv: for ne or no + iSdiag = jpsw ; iSsono = jpso ! Send: to sw or so + iiRst = Nie0+1 ; ijRst = Nje0+1 ! Rcv ne-corner starting point + iiRnd = jpi ; ijRnd = jpj ! Rcv ne-corner ending point + iiSstdiag = Nis0 ; ijSstdiag = Njs0 ! send to ne-corner of sw neighbourg + iiSnddiag = Nis0+nn_hls-1 ; ijSnddiag = Njs0+nn_hls-1 ! send to ne-corner of sw neighbourg + iiSstsono = Nie0+1 ; ijSstsono = Njs0 ! send to ne-corner of so neighbourg + iiSndsono = jpi ; ijSndsono = Njs0+nn_hls-1 ! send to ne-corner of so neighbourg + iioutdir = 1 ; ijoutdir = 1 ! outside MPI domain: eastward or southward + END SELECT + ! + ! Check if we need to receive data for this rim point + IF( ii >= iiRst .AND. ii <= iiRnd .AND. ij >= ijRst .AND. ij <= ijRnd ) THEN ! rim point on the corner + iiout = ii+iioutdir ; ijout = ij+ijoutdir ! in which direction do we go outside of the MPI domain? + ! take care of neighbourg(s) in the interior of the computational domain + IF( iibi==iiout .OR. ii1==iiout .OR. ii2==iiout .OR. ii3==iiout .OR. & ! Neib outside of the MPI domain + & ijbi==ijout .OR. ij1==ijout .OR. ij2==ijout .OR. ij3==ijout ) THEN ! -> I cannot compute it -> recv it + IF( mpiRnei(nn_hls,iRdiag) > -1 ) lrecv_bdyint(ib_bdy,igrd,iRdiag,ir) = .TRUE. ! Receive directly from diagonal neighbourg + IF( mpiRnei(nn_hls,iRsono) > -1 .AND. nn_comm == 1 ) lrecv_bdyint(ib_bdy,igrd,iRsono,ir) = .TRUE. ! Receive through the South/North neighbourg + ENDIF + ! take care of neighbourg in the exterior of the computational domain + IF( iibe==iiout .OR. ijbe==ijout ) THEN ! Neib outside of the MPI domain -> I cannot compute it -> recv it + IF( mpiRnei(nn_hls,iRdiag) > -1 ) lrecv_bdyext(ib_bdy,igrd,iRdiag,ir) = .TRUE. ! Receive directly from diagonal neighbourg + IF( mpiRnei(nn_hls,iRsono) > -1 .AND. nn_comm == 1 ) lrecv_bdyext(ib_bdy,igrd,iRsono,ir) = .TRUE. ! Receive through the South/North neighbourg + ENDIF + ENDIF + ! + ! Check if this rim point corresponds to the corner of one neighbourg. if yes, do we need to send data? + ! Direct send to diag: Is this rim point the corner point of a diag neighbour with which we communicate? + IF( ii >= iiSstdiag .AND. ii <= iiSnddiag .AND. ij >= ijSstdiag .AND. ij <= ijSnddiag & + & .AND. mpiSnei(nn_hls,iSdiag) > -1 ) THEN + iiout = ii+iioutdir ; ijout = ij+ijoutdir ! in which direction do we go outside of the nei MPI domain? + ! take care of neighbourg(s) in the interior of the computational domain + IF( iibi==iiout .OR. ii1==iiout .OR. ii2==iiout .OR. ii3==iiout .OR. & ! Neib outside of diag nei MPI + & ijbi==ijout .OR. ij1==ijout .OR. ij2==ijout .OR. ij3==ijout ) & ! domain -> nei cannot compute it + & lsend_bdyint(ib_bdy,igrd,iSdiag,ir) = .TRUE. ! send rim point data to diag nei + ! take care of neighbourg in the exterior of the computational domain + IF( iibe==iiout .OR. ijbe==ijout ) & + & lsend_bdyext(ib_bdy,igrd,iSdiag,ir) = .TRUE. + ENDIF + ! Indirect send to diag (through so/no): rim point is the corner point of a so/no nei with which we communicate + IF( ii >= iiSstsono .AND. ii <= iiSndsono .AND. ij >= ijSstsono .AND. ij <= ijSndsono & + & .AND. mpiSnei(nn_hls,iSsono) > -1 .AND. nn_comm == 1 ) THEN + iiout = ii+iioutdir ; ijout = ij+ijoutdir ! in which direction do we go outside of the nei MPI domain? + ! take care of neighbourg(s) in the interior of the computational domain + IF( iibi==iiout .OR. ii1==iiout .OR. ii2==iiout .OR. ii3==iiout .OR. & ! Neib outside of so/no nei MPI + & ijbi==ijout .OR. ij1==ijout .OR. ij2==ijout .OR. ij3==ijout ) & ! domain -> nei cannot compute it + & lsend_bdyint(ib_bdy,igrd,iSsono,ir) = .TRUE. ! send rim point data to so/no nei + ! take care of neighbourg in the exterior of the computational domain + IF( iibe==iiout .OR. ijbe==ijout ) & + & lsend_bdyext(ib_bdy,igrd,iSsono,ir) = .TRUE. + ENDIF + ! + END DO ! 4 corners + END DO ! ib + END DO ! igrd + + ! Comment out for debug +!!$ DO ir = 0,1 +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'T', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyint(ib_bdy,1,:,ir), lrecv = lrecv_bdyint(ib_bdy,1,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' bdy debug int T', ir ; CALL FLUSH(numout) +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'U', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyint(ib_bdy,2,:,ir), lrecv = lrecv_bdyint(ib_bdy,2,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' bdy debug int U', ir ; CALL FLUSH(numout) +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'V', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyint(ib_bdy,3,:,ir), lrecv = lrecv_bdyint(ib_bdy,3,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' bdy debug int V', ir ; CALL FLUSH(numout) +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'T', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyext(ib_bdy,1,:,ir), lrecv = lrecv_bdyext(ib_bdy,1,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' bdy debug ext T', ir ; CALL FLUSH(numout) +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'U', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyext(ib_bdy,2,:,ir), lrecv = lrecv_bdyext(ib_bdy,2,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' bdy debug ext U', ir ; CALL FLUSH(numout) +!!$ zzbdy(:,:) = narea ; CALL lbc_lnk('bdy debug', zzbdy, 'V', 1._wp, kfillmode = jpfillnothing, & +!!$ & lsend = lsend_bdyext(ib_bdy,3,:,ir), lrecv = lrecv_bdyext(ib_bdy,3,:,ir) ) +!!$ IF(lwp) WRITE(numout,*) ' bdy debug ext V', ir ; CALL FLUSH(numout) +!!$ END DO + + END DO ! ib_bdy + + DO ib_bdy = 1,nb_bdy + IF( cn_dyn2d(ib_bdy) == 'orlanski' .OR. cn_dyn2d(ib_bdy) == 'orlanski_npo' .OR. & + & cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo' .OR. & + & cn_tra(ib_bdy) == 'orlanski' .OR. cn_tra(ib_bdy) == 'orlanski_npo' ) THEN + DO igrd = 1, jpbgrd + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( mig0(ii) > 2 .AND. mig0(ii) < Ni0glo-2 .AND. mjg0(ij) > 2 .AND. mjg0(ij) < Nj0glo-2 ) THEN + WRITE(ctmp1,*) ' Orlanski is not safe when the open boundaries are on the interior of the computational domain' + CALL ctl_stop( ctmp1 ) + END IF + END DO + END DO + END IF + END DO + ! + DEALLOCATE( nbidta, nbjdta, nbrdta ) + ! + END SUBROUTINE bdy_def + + + SUBROUTINE bdy_rim_treat( pumask, pvmask, pfmask, lrim0 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_rim_treat *** + !! + !! ** Purpose : Initialize structures ( flagu, flagv, ntreat ) indicating how rim points + !! are to be handled in the boundary condition treatment + !! + !! ** Method : - to handle rim 0 zmasks must indicate ocean points (set at one on rim 0 and rim 1 and interior) + !! and bdymasks must be set at 0 on rim 0 (set at one on rim 1 and interior) + !! (as if rim 1 was free ocean) + !! - to handle rim 1 zmasks must be set at 0 on rim 0 (set at one on rim 1 and interior) + !! and bdymasks must indicate free ocean points (set at one on interior) + !! (as if rim 0 was land) + !! - we can then check in which direction the interior of the computational domain is with the difference + !! mask array values on both sides to compute flagu and flagv + !! - and look at the ocean neighbours to compute ntreat + !!---------------------------------------------------------------------- + REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pumask, pvmask ! temporary u/v mask array + REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pfmask ! temporary fmask excluding coastal boundary condition (shlat) + LOGICAL , INTENT (in ) :: lrim0 ! .true. -> rim 0 .false. -> rim 1 + INTEGER :: ib_bdy, ii, ij, igrd, ib, icount ! dummy loop indices + INTEGER :: i_offset, j_offset, inn ! local integer + INTEGER :: ibeg, iend ! local integer + LOGICAL :: llnon, llson, llean, llwen ! local logicals indicating the presence of a ocean neighbour + REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! pointer to 2D mask fields + REAL(wp) :: zefl, zwfl, znfl, zsfl ! local scalars + CHARACTER(LEN=1), DIMENSION(jpbgrd) :: cgrid + REAL(wp) , DIMENSION(jpi,jpj) :: ztmp + !!---------------------------------------------------------------------- + + cgrid = (/'t','u','v'/) + + DO ib_bdy = 1, nb_bdy ! Indices and directions of rim velocity components + + DO igrd = 1, jpbgrd + + IF( lrim0 ) THEN ! extent of rim 0 + ibeg = 1 ; iend = idx_bdy(ib_bdy)%nblenrim0(igrd) + ELSE ! extent of rim 1 + ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1 ; iend = idx_bdy(ib_bdy)%nblenrim(igrd) + END IF + + ! Calculate relationship of U direction to the local orientation of the boundary + ! flagu = -1 : u component is normal to the dynamical boundary and its direction is outward + ! flagu = 0 : u is tangential + ! flagu = 1 : u is normal to the boundary and is direction is inward + SELECT CASE( igrd ) + CASE( 1 ) ; zmask => pumask ; i_offset = 0 ! U(i-1) T(i) U(i ) + CASE( 2 ) ; zmask => bdytmask ; i_offset = 1 ! T(i ) U(i) T(i+1) + CASE( 3 ) ; zmask => pfmask ; i_offset = 0 ! F(i-1) V(i) F(i ) + END SELECT + icount = 0 + ztmp(:,:) = -999._wp + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( ii < Nis0 .OR. ii > Nie0 .OR. ij < Njs0 .OR. ij > Nje0 ) CYCLE ! call lbc_lnk -> no need to compute these pts + zwfl = zmask(ii+i_offset-1,ij) + zefl = zmask(ii+i_offset ,ij) + ! This error check only works if you are using the bdyXmask arrays (which are set to 0 on rims) + IF( i_offset == 1 .and. zefl + zwfl == 2._wp ) THEN + icount = icount + 1 + IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij) + ELSE + ztmp(ii,ij) = -zwfl + zefl + ENDIF + END DO + IF( icount /= 0 ) THEN + WRITE(ctmp1,*) 'Some ',cgrid(igrd),' grid points,', & + ' are not boundary points (flagu calculation). Check nbi, nbj, indices for boundary set ',ib_bdy + CALL ctl_stop( ctmp1 ) + ENDIF + SELECT CASE( igrd ) + CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) + END SELECT + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + idx_bdy(ib_bdy)%flagu(ib,igrd) = ztmp(ii,ij) + END DO + + ! Calculate relationship of V direction to the local orientation of the boundary + ! flagv = -1 : v component is normal to the dynamical boundary but its direction is outward + ! flagv = 0 : v is tangential + ! flagv = 1 : v is normal to the boundary and is direction is inward + SELECT CASE( igrd ) + CASE( 1 ) ; zmask => pvmask ; j_offset = 0 + CASE( 2 ) ; zmask => pfmask ; j_offset = 0 + CASE( 3 ) ; zmask => bdytmask ; j_offset = 1 + END SELECT + icount = 0 + ztmp(:,:) = -999._wp + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( ii < Nis0 .OR. ii > Nie0 .OR. ij < Njs0 .OR. ij > Nje0 ) CYCLE ! call lbc_lnk -> no need to compute these pts + zsfl = zmask(ii,ij+j_offset-1) + znfl = zmask(ii,ij+j_offset ) + ! This error check only works if you are using the bdyXmask arrays (which are set to 0 on rims) + IF( j_offset == 1 .and. znfl + zsfl == 2._wp ) THEN + IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij) + icount = icount + 1 + ELSE + ztmp(ii,ij) = -zsfl + znfl + END IF + END DO + IF( icount /= 0 ) THEN + WRITE(ctmp1,*) 'Some ',cgrid(igrd),' grid points,', & + ' are not boundary points (flagv calculation). Check nbi, nbj, indices for boundary set ',ib_bdy + CALL ctl_stop( ctmp1 ) + ENDIF + SELECT CASE( igrd ) + CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) + END SELECT + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + idx_bdy(ib_bdy)%flagv(ib,igrd) = ztmp(ii,ij) + END DO + + ! Calculate ntreat + SELECT CASE( igrd ) + CASE( 1 ) ; zmask => bdytmask + CASE( 2 ) ; zmask => bdyumask + CASE( 3 ) ; zmask => bdyvmask + END SELECT + ztmp(:,:) = -999._wp + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( ii < Nis0 .OR. ii > Nie0 .OR. ij < Njs0 .OR. ij > Nje0 ) CYCLE ! call lbc_lnk -> no need to compute these pts + llnon = zmask(ii ,ij+1) == 1._wp + llson = zmask(ii ,ij-1) == 1._wp + llean = zmask(ii+1,ij ) == 1._wp + llwen = zmask(ii-1,ij ) == 1._wp + inn = COUNT( (/ llnon, llson, llean, llwen /) ) + IF( inn == 0 ) THEN ! no neighbours -> interior of a corner or cluster of rim points + ! ! ! _____ ! _____ ! __ __ + ! 1 | o ! 2 o | ! 3 | x ! 4 x | ! | | -> error + ! |_x_ _ ! _ _x_| ! | o ! o | ! |x_x| + IF( zmask(ii+1,ij+1) == 1._wp ) THEN ; ztmp(ii,ij) = 1._wp + ELSEIF( zmask(ii-1,ij+1) == 1._wp ) THEN ; ztmp(ii,ij) = 2._wp + ELSEIF( zmask(ii+1,ij-1) == 1._wp ) THEN ; ztmp(ii,ij) = 3._wp + ELSEIF( zmask(ii-1,ij-1) == 1._wp ) THEN ; ztmp(ii,ij) = 4._wp + ELSE ; ztmp(ii,ij) = -1._wp + WRITE(ctmp1,*) 'Problem with ',cgrid(igrd) ,' grid point', ii, ij, & + ' on boundary set ', ib_bdy, ' has no free ocean neighbour' + IF( lrim0 ) THEN + WRITE(ctmp2,*) ' There seems to be a cluster of rim 0 points.' + ELSE + WRITE(ctmp2,*) ' There seems to be a cluster of rim 1 points.' + END IF + CALL ctl_warn( ctmp1, ctmp2 ) + END IF + END IF + IF( inn == 1 ) THEN ! middle of linear bdy or incomplete corner ! ___ o + ! | ! | ! o ! ______ ! |x___ + ! 5 | x o ! 6 o x | ! 7 __x__ ! 8 x + ! | ! | ! ! o + IF( llean ) ztmp(ii,ij) = 5._wp + IF( llwen ) ztmp(ii,ij) = 6._wp + IF( llnon ) ztmp(ii,ij) = 7._wp + IF( llson ) ztmp(ii,ij) = 8._wp + END IF + IF( inn == 2 ) THEN ! exterior of a corner + ! o ! o ! _____| ! |_____ + ! 9 ____x o ! 10 o x___ ! 11 x o ! 12 o x + ! | ! | ! o ! o + IF( llnon .AND. llean ) ztmp(ii,ij) = 9._wp + IF( llnon .AND. llwen ) ztmp(ii,ij) = 10._wp + IF( llson .AND. llean ) ztmp(ii,ij) = 11._wp + IF( llson .AND. llwen ) ztmp(ii,ij) = 12._wp + END IF + IF( inn == 3 ) THEN ! 3 neighbours __ __ + ! |_ o ! o _| ! |_| ! o + ! 13 _| x o ! 14 o x |_ ! 15 o x o ! 16 o x o + ! | o ! o | ! o ! __|¨|__ + IF( llnon .AND. llean .AND. llson ) ztmp(ii,ij) = 13._wp + IF( llnon .AND. llwen .AND. llson ) ztmp(ii,ij) = 14._wp + IF( llwen .AND. llson .AND. llean ) ztmp(ii,ij) = 15._wp + IF( llwen .AND. llnon .AND. llean ) ztmp(ii,ij) = 16._wp + END IF + IF( inn == 4 ) THEN + WRITE(ctmp1,*) 'Problem with ',cgrid(igrd) ,' grid point', ii, ij, & + ' on boundary set ', ib_bdy, ' have 4 neighbours' + CALL ctl_stop( ctmp1 ) + END IF + END DO + SELECT CASE( igrd ) + CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) + END SELECT + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + idx_bdy(ib_bdy)%ntreat(ib,igrd) = NINT(ztmp(ii,ij)) + END DO + ! + END DO ! jpbgrd + ! + END DO ! ib_bdy + + END SUBROUTINE bdy_rim_treat + + + SUBROUTINE find_neib( ii, ij, itreat, ii1, ij1, ii2, ij2, ii3, ij3 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE find_neib *** + !! + !! ** Purpose : get ii1, ij1, ii2, ij2, ii3, ij3, the indices of + !! the free ocean neighbours of (ii,ij) for bdy treatment + !! + !! ** Method : use itreat input to select a case + !! N.B. ntreat is defined for all bdy points in routine bdy_rim_treat + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: ii, ij, itreat + INTEGER, INTENT( out) :: ii1, ij1, ii2, ij2, ii3, ij3 + !!---------------------------------------------------------------------- + SELECT CASE( itreat ) ! points that will be used by bdy routines, -1 will be discarded + ! ! ! _____ ! _____ + ! 1 | o ! 2 o | ! 3 | x ! 4 x | + ! |_x_ _ ! _ _x_| ! | o ! o | + CASE( 1 ) ; ii1 = ii+1 ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + CASE( 2 ) ; ii1 = ii-1 ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + CASE( 3 ) ; ii1 = ii+1 ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + CASE( 4 ) ; ii1 = ii-1 ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + ! | ! | ! o ! ______ ! or incomplete corner + ! 5 | x o ! 6 o x | ! 7 __x__ ! 8 x ! 7 ____ o + ! | ! | ! ! o ! |x___ + CASE( 5 ) ; ii1 = ii+1 ; ij1 = ij ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + CASE( 6 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + CASE( 7 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + CASE( 8 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = -1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -1 + ! o ! o ! _____| ! |_____ + ! 9 ____x o ! 10 o x___ ! 11 x o ! 12 o x + ! | ! | ! o ! o + CASE( 9 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 + CASE( 10 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 + CASE( 11 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 + CASE( 12 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = -1 ; ij3 = -1 + ! |_ o ! o _| ! ¨¨|_|¨¨ ! o + ! 13 _| x o ! 14 o x |_ ! 15 o x o ! 16 o x o + ! | o ! o | ! o ! __|¨|__ + CASE( 13 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = ii ; ij3 = ij-1 + CASE( 14 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = ii ; ij3 = ij-1 + CASE( 15 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = ii ; ij2 = ij-1 ; ii3 = ii+1 ; ij3 = ij + CASE( 16 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = ii ; ij2 = ij+1 ; ii3 = ii+1 ; ij3 = ij + END SELECT + END SUBROUTINE find_neib + + + SUBROUTINE bdy_read_seg( kb_bdy, knblendta ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_read_seg *** + !! + !! ** Purpose : build bdy coordinates with segments defined in namelist + !! + !! ** Method : read namelist nambdy_index blocks + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT (in ) :: kb_bdy ! bdy number + INTEGER, DIMENSION(jpbgrd), INTENT ( out) :: knblendta ! length of index arrays + !! + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: nbdyind, nbdybeg, nbdyend + INTEGER :: nbdy_count, nbdy_rdstart, nbdy_loc + CHARACTER(LEN=1) :: ctypebdy ! - - + CHARACTER(LEN=50):: cerrmsg ! - - + NAMELIST/nambdy_index/ ctypebdy, nbdyind, nbdybeg, nbdyend + !!---------------------------------------------------------------------- + ! Need to support possibility of reading more than one nambdy_index from + ! the namelist_cfg internal file. + ! Do this by finding the kb_bdy'th occurence of nambdy_index in the + ! character buffer as the starting point. + nbdy_rdstart = 1 + DO nbdy_count = 1, kb_bdy + nbdy_loc = INDEX( numnam_cfg( nbdy_rdstart: ), 'nambdy_index' ) + IF( nbdy_loc .GT. 0 ) THEN + nbdy_rdstart = nbdy_rdstart + nbdy_loc + ELSE + WRITE(cerrmsg,'(A,I4,A)') 'Error: entry number ',kb_bdy,' of nambdy_index not found' + ios = -1 + CALL ctl_nam ( ios , cerrmsg ) + ENDIF + END DO + nbdy_rdstart = MAX( 1, nbdy_rdstart - 2 ) + READ ( numnam_cfg( nbdy_rdstart: ), nambdy_index, IOSTAT = ios, ERR = 904) +904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_index in configuration namelist' ) + IF(lwm) WRITE ( numond, nambdy_index ) + + SELECT CASE ( TRIM(ctypebdy) ) + CASE( 'N' ) + IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 + nbdyind = Nj0glo - 2 ! set boundary to whole side of model domain. + nbdybeg = 2 + nbdyend = Ni0glo - 1 + ENDIF + nbdysegn = nbdysegn + 1 + npckgn(nbdysegn) = kb_bdy ! Save bdy package number + jpjnob(nbdysegn) = nbdyind + jpindt(nbdysegn) = nbdybeg + jpinft(nbdysegn) = nbdyend + ! + CASE( 'S' ) + IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 + nbdyind = 2 ! set boundary to whole side of model domain. + nbdybeg = 2 + nbdyend = Ni0glo - 1 + ENDIF + nbdysegs = nbdysegs + 1 + npckgs(nbdysegs) = kb_bdy ! Save bdy package number + jpjsob(nbdysegs) = nbdyind + jpisdt(nbdysegs) = nbdybeg + jpisft(nbdysegs) = nbdyend + ! + CASE( 'E' ) + IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 + nbdyind = Ni0glo - 2 ! set boundary to whole side of model domain. + nbdybeg = 2 + nbdyend = Nj0glo - 1 + ENDIF + nbdysege = nbdysege + 1 + npckge(nbdysege) = kb_bdy ! Save bdy package number + jpieob(nbdysege) = nbdyind + jpjedt(nbdysege) = nbdybeg + jpjeft(nbdysege) = nbdyend + ! + CASE( 'W' ) + IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 + nbdyind = 2 ! set boundary to whole side of model domain. + nbdybeg = 2 + nbdyend = Nj0glo - 1 + ENDIF + nbdysegw = nbdysegw + 1 + npckgw(nbdysegw) = kb_bdy ! Save bdy package number + jpiwob(nbdysegw) = nbdyind + jpjwdt(nbdysegw) = nbdybeg + jpjwft(nbdysegw) = nbdyend + ! + CASE DEFAULT ; CALL ctl_stop( 'ctypebdy must be N, S, E or W' ) + END SELECT + + ! For simplicity we assume that in case of straight bdy, arrays have the same length + ! (even if it is true that last tangential velocity points + ! are useless). This simplifies a little bit boundary data format (and agrees with format + ! used so far in obc package) + + knblendta(1:jpbgrd) = (nbdyend - nbdybeg + 1) * nn_rimwidth(kb_bdy) + + END SUBROUTINE bdy_read_seg + + + SUBROUTINE bdy_ctl_seg + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_ctl_seg *** + !! + !! ** Purpose : Check straight open boundary segments location + !! + !! ** Method : - Look for open boundary corners + !! - Check that segments start or end on land + !!---------------------------------------------------------------------- + INTEGER :: ib, ib1, ib2, ji ,jj, itest + INTEGER, DIMENSION(jp_nseg,2) :: icorne, icornw, icornn, icorns + REAL(wp), DIMENSION(2) :: ztestmask + !!---------------------------------------------------------------------- + ! + IF (lwp) WRITE(numout,*) ' ' + IF (lwp) WRITE(numout,*) 'bdy_ctl_seg: Check analytical segments' + IF (lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ! + IF(lwp) WRITE(numout,*) 'Number of east segments : ', nbdysege + IF(lwp) WRITE(numout,*) 'Number of west segments : ', nbdysegw + IF(lwp) WRITE(numout,*) 'Number of north segments : ', nbdysegn + IF(lwp) WRITE(numout,*) 'Number of south segments : ', nbdysegs + ! + ! 1. Check bounds + !---------------- + DO ib = 1, nbdysegn + IF (lwp) WRITE(numout,*) '**check north seg bounds pckg: ', npckgn(ib) + IF ((jpjnob(ib).ge.Nj0glo-1).or.& + &(jpjnob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) + IF (jpindt(ib).ge.jpinft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) + IF (jpindt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) + IF (jpinft(ib).gt.Ni0glo) CALL ctl_stop( 'End index out of domain' ) + END DO + ! + DO ib = 1, nbdysegs + IF (lwp) WRITE(numout,*) '**check south seg bounds pckg: ', npckgs(ib) + IF ((jpjsob(ib).ge.Nj0glo-1).or.& + &(jpjsob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) + IF (jpisdt(ib).ge.jpisft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) + IF (jpisdt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) + IF (jpisft(ib).gt.Ni0glo) CALL ctl_stop( 'End index out of domain' ) + END DO + ! + DO ib = 1, nbdysege + IF (lwp) WRITE(numout,*) '**check east seg bounds pckg: ', npckge(ib) + IF ((jpieob(ib).ge.Ni0glo-1).or.& + &(jpieob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) + IF (jpjedt(ib).ge.jpjeft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) + IF (jpjedt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) + IF (jpjeft(ib).gt.Nj0glo) CALL ctl_stop( 'End index out of domain' ) + END DO + ! + DO ib = 1, nbdysegw + IF (lwp) WRITE(numout,*) '**check west seg bounds pckg: ', npckgw(ib) + IF ((jpiwob(ib).ge.Ni0glo-1).or.& + &(jpiwob(ib).le.1)) CALL ctl_stop( 'nbdyind out of domain' ) + IF (jpjwdt(ib).ge.jpjwft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) + IF (jpjwdt(ib).lt.1 ) CALL ctl_stop( 'Start index out of domain' ) + IF (jpjwft(ib).gt.Nj0glo) CALL ctl_stop( 'End index out of domain' ) + ENDDO + ! + ! 2. Look for segment crossings + !------------------------------ + IF (lwp) WRITE(numout,*) '**Look for segments corners :' + ! + itest = 0 ! corner number + ! + ! flag to detect if start or end of open boundary belongs to a corner + ! if not (=0), it must be on land. + ! if a corner is detected, save bdy package number for further tests + icorne(:,:)=0. ; icornw(:,:)=0. ; icornn(:,:)=0. ; icorns(:,:)=0. + ! South/West crossings + IF ((nbdysegw > 0).AND.(nbdysegs > 0)) THEN + DO ib1 = 1, nbdysegw + DO ib2 = 1, nbdysegs + IF (( jpisdt(ib2)<=jpiwob(ib1)).AND. & + & ( jpisft(ib2)>=jpiwob(ib1)).AND. & + & ( jpjwdt(ib1)<=jpjsob(ib2)).AND. & + & ( jpjwft(ib1)>=jpjsob(ib2))) THEN + IF ((jpjwdt(ib1)==jpjsob(ib2)).AND.(jpisdt(ib2)==jpiwob(ib1))) THEN + ! We have a possible South-West corner +! WRITE(numout,*) ' Found a South-West corner at (i,j): ', jpisdt(ib2), jpjwdt(ib1) +! WRITE(numout,*) ' between segments: ', npckgw(ib1), npckgs(ib2) + icornw(ib1,1) = npckgs(ib2) + icorns(ib2,1) = npckgw(ib1) + ELSEIF ((jpisft(ib2)==jpiwob(ib1)).AND.(jpjwft(ib1)==jpjsob(ib2))) THEN + WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & + & jpisft(ib2), jpjwft(ib1) + WRITE(ctmp2,*) ' Not allowed yet' + WRITE(ctmp3,*) ' Crossing problem with West segment: ',npckgw(ib1), & + & ' and South segment: ',npckgs(ib2) + CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) + ELSE + WRITE(ctmp1,*) ' Check South and West Open boundary indices' + WRITE(ctmp2,*) ' Crossing problem with West segment: ',npckgw(ib1) , & + & ' and South segment: ',npckgs(ib2) + CALL ctl_stop( ctmp1, ctmp2 ) + END IF + END IF + END DO + END DO + END IF + ! + ! South/East crossings + IF ((nbdysege > 0).AND.(nbdysegs > 0)) THEN + DO ib1 = 1, nbdysege + DO ib2 = 1, nbdysegs + IF (( jpisdt(ib2)<=jpieob(ib1)+1).AND. & + & ( jpisft(ib2)>=jpieob(ib1)+1).AND. & + & ( jpjedt(ib1)<=jpjsob(ib2) ).AND. & + & ( jpjeft(ib1)>=jpjsob(ib2) )) THEN + IF ((jpjedt(ib1)==jpjsob(ib2)).AND.(jpisft(ib2)==jpieob(ib1)+1)) THEN + ! We have a possible South-East corner +! WRITE(numout,*) ' Found a South-East corner at (i,j): ', jpisft(ib2), jpjedt(ib1) +! WRITE(numout,*) ' between segments: ', npckge(ib1), npckgs(ib2) + icorne(ib1,1) = npckgs(ib2) + icorns(ib2,2) = npckge(ib1) + ELSEIF ((jpjeft(ib1)==jpjsob(ib2)).AND.(jpisdt(ib2)==jpieob(ib1)+1)) THEN + WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & + & jpisdt(ib2), jpjeft(ib1) + WRITE(ctmp2,*) ' Not allowed yet' + WRITE(ctmp3,*) ' Crossing problem with East segment: ',npckge(ib1), & + & ' and South segment: ',npckgs(ib2) + CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) + ELSE + WRITE(ctmp1,*) ' Check South and East Open boundary indices' + WRITE(ctmp2,*) ' Crossing problem with East segment: ',npckge(ib1), & + & ' and South segment: ',npckgs(ib2) + CALL ctl_stop( ctmp1, ctmp2 ) + END IF + END IF + END DO + END DO + END IF + ! + ! North/West crossings + IF ((nbdysegn > 0).AND.(nbdysegw > 0)) THEN + DO ib1 = 1, nbdysegw + DO ib2 = 1, nbdysegn + IF (( jpindt(ib2)<=jpiwob(ib1) ).AND. & + & ( jpinft(ib2)>=jpiwob(ib1) ).AND. & + & ( jpjwdt(ib1)<=jpjnob(ib2)+1).AND. & + & ( jpjwft(ib1)>=jpjnob(ib2)+1)) THEN + IF ((jpjwft(ib1)==jpjnob(ib2)+1).AND.(jpindt(ib2)==jpiwob(ib1))) THEN + ! We have a possible North-West corner +! WRITE(numout,*) ' Found a North-West corner at (i,j): ', jpindt(ib2), jpjwft(ib1) +! WRITE(numout,*) ' between segments: ', npckgw(ib1), npckgn(ib2) + icornw(ib1,2) = npckgn(ib2) + icornn(ib2,1) = npckgw(ib1) + ELSEIF ((jpjwdt(ib1)==jpjnob(ib2)+1).AND.(jpinft(ib2)==jpiwob(ib1))) THEN + WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & + & jpinft(ib2), jpjwdt(ib1) + WRITE(ctmp2,*) ' Not allowed yet' + WRITE(ctmp3,*) ' Crossing problem with West segment: ',npckgw(ib1), & + & ' and North segment: ',npckgn(ib2) + CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) + ELSE + WRITE(ctmp1,*) ' Check North and West Open boundary indices' + WRITE(ctmp2,*) ' Crossing problem with West segment: ',npckgw(ib1), & + & ' and North segment: ',npckgn(ib2) + CALL ctl_stop( ctmp1, ctmp2 ) + END IF + END IF + END DO + END DO + END IF + ! + ! North/East crossings + IF ((nbdysegn > 0).AND.(nbdysege > 0)) THEN + DO ib1 = 1, nbdysege + DO ib2 = 1, nbdysegn + IF (( jpindt(ib2)<=jpieob(ib1)+1).AND. & + & ( jpinft(ib2)>=jpieob(ib1)+1).AND. & + & ( jpjedt(ib1)<=jpjnob(ib2)+1).AND. & + & ( jpjeft(ib1)>=jpjnob(ib2)+1)) THEN + IF ((jpjeft(ib1)==jpjnob(ib2)+1).AND.(jpinft(ib2)==jpieob(ib1)+1)) THEN + ! We have a possible North-East corner +! WRITE(numout,*) ' Found a North-East corner at (i,j): ', jpinft(ib2), jpjeft(ib1) +! WRITE(numout,*) ' between segments: ', npckge(ib1), npckgn(ib2) + icorne(ib1,2) = npckgn(ib2) + icornn(ib2,2) = npckge(ib1) + ELSEIF ((jpjedt(ib1)==jpjnob(ib2)+1).AND.(jpindt(ib2)==jpieob(ib1)+1)) THEN + WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & + & jpindt(ib2), jpjedt(ib1) + WRITE(ctmp2,*) ' Not allowed yet' + WRITE(ctmp3,*) ' Crossing problem with East segment: ',npckge(ib1), & + & ' and North segment: ',npckgn(ib2) + CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) + ELSE + WRITE(ctmp1,*) ' Check North and East Open boundary indices' + WRITE(ctmp2,*) ' Crossing problem with East segment: ',npckge(ib1), & + & ' and North segment: ',npckgn(ib2) + CALL ctl_stop( ctmp1, ctmp2 ) + END IF + END IF + END DO + END DO + END IF + ! + ! 3. Check if segment extremities are on land + !-------------------------------------------- + ! + ! West segments + DO ib = 1, nbdysegw + ! get mask at boundary extremities: + ztestmask(1:2)=0. + DO ji = 1, jpi + DO jj = 1, jpj + IF( mig0(ji) == jpiwob(ib) .AND. mjg0(jj) == jpjwdt(ib) ) ztestmask(1) = tmask(ji,jj,1) + IF( mig0(ji) == jpiwob(ib) .AND. mjg0(jj) == jpjwft(ib) ) ztestmask(2) = tmask(ji,jj,1) + END DO + END DO + CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain + + IF (ztestmask(1)==1) THEN + IF (icornw(ib,1)==0) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckgw(ib) + CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) + ELSE + ! This is a corner + IF(lwp) WRITE(numout,*) 'Found a South-West corner at (i,j): ', jpiwob(ib), jpjwdt(ib) + CALL bdy_ctl_corn(npckgw(ib), icornw(ib,1)) + itest=itest+1 + ENDIF + ENDIF + IF (ztestmask(2)==1) THEN + IF (icornw(ib,2)==0) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckgw(ib) + CALL ctl_stop( ' ', ctmp1, ' does not end on land or on a corner' ) + ELSE + ! This is a corner + IF(lwp) WRITE(numout,*) 'Found a North-West corner at (i,j): ', jpiwob(ib), jpjwft(ib) + CALL bdy_ctl_corn(npckgw(ib), icornw(ib,2)) + itest=itest+1 + ENDIF + ENDIF + END DO + ! + ! East segments + DO ib = 1, nbdysege + ! get mask at boundary extremities: + ztestmask(1:2)=0. + DO ji = 1, jpi + DO jj = 1, jpj + IF( mig0(ji) == jpieob(ib)+1 .AND. mjg0(jj) == jpjedt(ib) ) ztestmask(1) = tmask(ji,jj,1) + IF( mig0(ji) == jpieob(ib)+1 .AND. mjg0(jj) == jpjeft(ib) ) ztestmask(2) = tmask(ji,jj,1) + END DO + END DO + CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain + + IF (ztestmask(1)==1) THEN + IF (icorne(ib,1)==0) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckge(ib) + CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) + ELSE + ! This is a corner + IF(lwp) WRITE(numout,*) 'Found a South-East corner at (i,j): ', jpieob(ib)+1, jpjedt(ib) + CALL bdy_ctl_corn(npckge(ib), icorne(ib,1)) + itest=itest+1 + ENDIF + ENDIF + IF (ztestmask(2)==1) THEN + IF (icorne(ib,2)==0) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckge(ib) + CALL ctl_stop( ctmp1, ' does not end on land or on a corner' ) + ELSE + ! This is a corner + IF(lwp) WRITE(numout,*) 'Found a North-East corner at (i,j): ', jpieob(ib)+1, jpjeft(ib) + CALL bdy_ctl_corn(npckge(ib), icorne(ib,2)) + itest=itest+1 + ENDIF + ENDIF + END DO + ! + ! South segments + DO ib = 1, nbdysegs + ! get mask at boundary extremities: + ztestmask(1:2)=0. + DO ji = 1, jpi + DO jj = 1, jpj + IF( mjg0(jj) == jpjsob(ib) .AND. mig0(ji) == jpisdt(ib) ) ztestmask(1) = tmask(ji,jj,1) + IF( mjg0(jj) == jpjsob(ib) .AND. mig0(ji) == jpisft(ib) ) ztestmask(2) = tmask(ji,jj,1) + END DO + END DO + CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain + + IF ((ztestmask(1)==1).AND.(icorns(ib,1)==0)) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckgs(ib) + CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) + ENDIF + IF ((ztestmask(2)==1).AND.(icorns(ib,2)==0)) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckgs(ib) + CALL ctl_stop( ctmp1, ' does not end on land or on a corner' ) + ENDIF + END DO + ! + ! North segments + DO ib = 1, nbdysegn + ! get mask at boundary extremities: + ztestmask(1:2)=0. + DO ji = 1, jpi + DO jj = 1, jpj + IF( mjg0(jj) == jpjnob(ib)+1 .AND. mig0(ji) == jpindt(ib) ) ztestmask(1) = tmask(ji,jj,1) + IF( mjg0(jj) == jpjnob(ib)+1 .AND. mig0(ji) == jpinft(ib) ) ztestmask(2) = tmask(ji,jj,1) + END DO + END DO + CALL mpp_sum( 'bdyini', ztestmask, 2 ) ! sum over the global domain + + IF ((ztestmask(1)==1).AND.(icornn(ib,1)==0)) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckgn(ib) + CALL ctl_stop( ctmp1, ' does not start on land' ) + ENDIF + IF ((ztestmask(2)==1).AND.(icornn(ib,2)==0)) THEN + WRITE(ctmp1,*) ' Open boundary segment ', npckgn(ib) + CALL ctl_stop( ctmp1, ' does not end on land' ) + ENDIF + END DO + ! + IF ((itest==0).AND.(lwp)) WRITE(numout,*) 'NO open boundary corner found' + ! + ! Other tests TBD: + ! segments completly on land + ! optimized open boundary array length according to landmask + ! Nudging layers that overlap with interior domain + ! + END SUBROUTINE bdy_ctl_seg + + + SUBROUTINE bdy_coords_seg( nbidta, nbjdta, nbrdta ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_coords_seg *** + !! + !! ** Purpose : build nbidta, nbidta, nbrdta for bdy built with segments + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(:,:,:), intent( out) :: nbidta, nbjdta, nbrdta ! Index arrays: i and j indices of bdy dta + !! + INTEGER :: ii, ij, ir, iseg + INTEGER :: igrd ! grid type (t=1, u=2, v=3) + INTEGER :: icount ! + INTEGER :: ib_bdy ! bdy number + !!---------------------------------------------------------------------- + + ! East + !----- + DO iseg = 1, nbdysege + ib_bdy = npckge(iseg) + ! + ! ------------ T points ------------- + igrd=1 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ij = jpjedt(iseg), jpjeft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir + nn_hls + nbjdta(icount, igrd, ib_bdy) = ij + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ! + ! ------------ U points ------------- + igrd=2 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ij = jpjedt(iseg), jpjeft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir + nn_hls + nbjdta(icount, igrd, ib_bdy) = ij + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ! + ! ------------ V points ------------- + igrd=3 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + ! DO ij = jpjedt(iseg), jpjeft(iseg) - 1 + DO ij = jpjedt(iseg), jpjeft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir + nn_hls + nbjdta(icount, igrd, ib_bdy) = ij + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + ENDDO + ENDDO + ! + ! West + !----- + DO iseg = 1, nbdysegw + ib_bdy = npckgw(iseg) + ! + ! ------------ T points ------------- + igrd=1 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ij = jpjwdt(iseg), jpjwft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls + nbjdta(icount, igrd, ib_bdy) = ij + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ! + ! ------------ U points ------------- + igrd=2 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ij = jpjwdt(iseg), jpjwft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls + nbjdta(icount, igrd, ib_bdy) = ij + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ! + ! ------------ V points ------------- + igrd=3 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + ! DO ij = jpjwdt(iseg), jpjwft(iseg) - 1 + DO ij = jpjwdt(iseg), jpjwft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls + nbjdta(icount, igrd, ib_bdy) = ij + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + ENDDO + ENDDO + ! + ! North + !----- + DO iseg = 1, nbdysegn + ib_bdy = npckgn(iseg) + ! + ! ------------ T points ------------- + igrd=1 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ii = jpindt(iseg), jpinft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = ii + nn_hls + nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ! + ! ------------ U points ------------- + igrd=2 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + ! DO ii = jpindt(iseg), jpinft(iseg) - 1 + DO ii = jpindt(iseg), jpinft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = ii + nn_hls + nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + ENDDO + ! + ! ------------ V points ------------- + igrd=3 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ii = jpindt(iseg), jpinft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = ii + nn_hls + nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ENDDO + ! + ! South + !----- + DO iseg = 1, nbdysegs + ib_bdy = npckgs(iseg) + ! + ! ------------ T points ------------- + igrd=1 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ii = jpisdt(iseg), jpisft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = ii + nn_hls + nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ! + ! ------------ U points ------------- + igrd=2 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + ! DO ii = jpisdt(iseg), jpisft(iseg) - 1 + DO ii = jpisdt(iseg), jpisft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = ii + nn_hls + nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point + ENDDO + ! + ! ------------ V points ------------- + igrd=3 + icount=0 + DO ir = 1, nn_rimwidth(ib_bdy) + DO ii = jpisdt(iseg), jpisft(iseg) + icount = icount + 1 + nbidta(icount, igrd, ib_bdy) = ii + nn_hls + nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls + nbrdta(icount, igrd, ib_bdy) = ir + ENDDO + ENDDO + ENDDO + + + END SUBROUTINE bdy_coords_seg + + + SUBROUTINE bdy_ctl_corn( ib1, ib2 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_ctl_corn *** + !! + !! ** Purpose : Check numerical schemes consistency between + !! segments having a common corner + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: ib1, ib2 + INTEGER :: itest + !!---------------------------------------------------------------------- + itest = 0 + + IF( cn_dyn2d(ib1) /= cn_dyn2d(ib2) ) itest = itest + 1 + IF( cn_dyn3d(ib1) /= cn_dyn3d(ib2) ) itest = itest + 1 + IF( cn_tra (ib1) /= cn_tra (ib2) ) itest = itest + 1 + ! + IF( nn_dyn2d_dta(ib1) /= nn_dyn2d_dta(ib2) ) itest = itest + 1 + IF( nn_dyn3d_dta(ib1) /= nn_dyn3d_dta(ib2) ) itest = itest + 1 + IF( nn_tra_dta (ib1) /= nn_tra_dta (ib2) ) itest = itest + 1 + ! + IF( nn_rimwidth(ib1) /= nn_rimwidth(ib2) ) itest = itest + 1 + ! + IF( itest>0 ) THEN + WRITE(ctmp1,*) ' Segments ', ib1, 'and ', ib2 + CALL ctl_stop( ctmp1, ' have different open bdy schemes' ) + ENDIF + ! + END SUBROUTINE bdy_ctl_corn + + + SUBROUTINE bdy_meshwri() + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_meshwri *** + !! + !! ** Purpose : write netcdf file with nbr, flagu, flagv, ntreat for T, U + !! and V points in 2D arrays for easier visualisation/control + !! + !! ** Method : use iom_rstput as in domwri.F + !!---------------------------------------------------------------------- + INTEGER :: ib_bdy, ii, ij, igrd, ib ! dummy loop indices + INTEGER :: inum ! - - + REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! pointer to 2D mask fields + REAL(wp) , DIMENSION(jpi,jpj) :: ztmp + CHARACTER(LEN=1) , DIMENSION(jpbgrd) :: cgrid + !!---------------------------------------------------------------------- + cgrid = (/'t','u','v'/) + CALL iom_open( 'bdy_mesh', inum, ldwrt = .TRUE. ) + DO igrd = 1, jpbgrd + SELECT CASE( igrd ) + CASE( 1 ) ; zmask => tmask(:,:,1) + CASE( 2 ) ; zmask => umask(:,:,1) + CASE( 3 ) ; zmask => vmask(:,:,1) + END SELECT + ztmp(:,:) = zmask(:,:) + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) ! nbr deined for all rims + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%nbr(ib,igrd), wp) + 10. + IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) + END DO + END DO + CALL iom_rstput( 0, 0, inum, 'bdy_nbr_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) + ztmp(:,:) = zmask(:,:) + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! flagu defined only for rims 0 and 1 + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagu(ib,igrd), wp) + 10. + IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) + END DO + END DO + CALL iom_rstput( 0, 0, inum, 'flagu_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) + ztmp(:,:) = zmask(:,:) + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! flagv defined only for rims 0 and 1 + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagv(ib,igrd), wp) + 10. + IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) + END DO + END DO + CALL iom_rstput( 0, 0, inum, 'flagv_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) + ztmp(:,:) = zmask(:,:) + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) ! ntreat defined only for rims 0 and 1 + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%ntreat(ib,igrd), wp) + 10. + IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) + END DO + END DO + CALL iom_rstput( 0, 0, inum, 'ntreat_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) + END DO + CALL iom_close( inum ) + + END SUBROUTINE bdy_meshwri + + !!================================================================================= +END MODULE bdyini \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdylib.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdylib.F90 new file mode 100644 index 0000000..b3776e4 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdylib.F90 @@ -0,0 +1,518 @@ +MODULE bdylib + !!====================================================================== + !! *** MODULE bdylib *** + !! Unstructured Open Boundary Cond. : Library module of generic boundary algorithms. + !!====================================================================== + !! History : 3.6 ! 2013 (D. Storkey) original code + !! 4.0 ! 2014 (T. Lovato) Generalize OBC structure + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! bdy_orlanski_2d + !! bdy_orlanski_3d + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE bdy_oce ! ocean open boundary conditions + USE phycst ! physical constants + USE bdyini + ! + USE in_out_manager ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp, ONLY: ctl_stop + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_frs, bdy_spe, bdy_nmn, bdy_orl + PUBLIC bdy_orlanski_2d + PUBLIC bdy_orlanski_3d + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdylib.F90 13527 2020-09-25 16:00:14Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_frs( idx, phia, dta ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_frs *** + !! + !! ** Purpose : Apply the Flow Relaxation Scheme for tracers at open boundaries. + !! + !! Reference : Engedahl H., 1995, Tellus, 365-382. + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + REAL(wp), DIMENSION(:,:), POINTER, INTENT(in) :: dta ! OBC external data + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend + !! + REAL(wp) :: zwgt ! boundary weight + INTEGER :: ib, ik, igrd ! dummy loop indices + INTEGER :: ii, ij ! 2D addresses + !!---------------------------------------------------------------------- + ! + igrd = 1 ! Everything is at T-points here + DO ib = 1, idx%nblen(igrd) + DO ik = 1, jpkm1 + ii = idx%nbi(ib,igrd) + ij = idx%nbj(ib,igrd) + zwgt = idx%nbw(ib,igrd) + phia(ii,ij,ik) = ( phia(ii,ij,ik) + zwgt * (dta(ib,ik) - phia(ii,ij,ik) ) ) * tmask(ii,ij,ik) + END DO + END DO + ! + END SUBROUTINE bdy_frs + + + SUBROUTINE bdy_spe( idx, phia, dta ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_spe *** + !! + !! ** Purpose : Apply a specified value for tracers at open boundaries. + !! + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + REAL(wp), DIMENSION(:,:), POINTER, INTENT(in) :: dta ! OBC external data + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend + !! + INTEGER :: ib, ik, igrd ! dummy loop indices + INTEGER :: ii, ij ! 2D addresses + !!---------------------------------------------------------------------- + ! + igrd = 1 ! Everything is at T-points here + DO ib = 1, idx%nblenrim(igrd) + ii = idx%nbi(ib,igrd) + ij = idx%nbj(ib,igrd) + DO ik = 1, jpkm1 + phia(ii,ij,ik) = dta(ib,ik) * tmask(ii,ij,ik) + END DO + END DO + ! + END SUBROUTINE bdy_spe + + + SUBROUTINE bdy_orl( idx, phib, phia, dta, lrim0, ll_npo ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_orl *** + !! + !! ** Purpose : Apply Orlanski radiation for tracers at open boundaries. + !! This is a wrapper routine for bdy_orlanski_3d below + !! + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices + REAL(wp), DIMENSION(:,:), POINTER, INTENT(in ) :: dta ! OBC external data + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phib ! before tracer field + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phia ! tracer trend + LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated + LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version + !! + INTEGER :: igrd ! grid index + !!---------------------------------------------------------------------- + ! + igrd = 1 ! Everything is at T-points here + ! + CALL bdy_orlanski_3d( idx, igrd, phib(:,:,:), phia(:,:,:), dta, lrim0, ll_npo ) + ! + END SUBROUTINE bdy_orl + + + SUBROUTINE bdy_orlanski_2d( idx, igrd, phib, phia, phi_ext, lrim0, ll_npo ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_orlanski_2d *** + !! + !! - Apply Orlanski radiation condition adaptively to 2D fields: + !! - radiation plus weak nudging at outflow points + !! - no radiation and strong nudging at inflow points + !! + !! + !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices + INTEGER , INTENT(in ) :: igrd ! grid index + REAL(wp), DIMENSION(:,:), INTENT(in ) :: phib ! model before 2D field + REAL(wp), DIMENSION(:,:), INTENT(inout) :: phia ! model after 2D field (to be updated) + REAL(wp), DIMENSION(: ), POINTER, INTENT(in ) :: phi_ext ! external forcing data + LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated + LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version + ! + INTEGER :: jb ! dummy loop indices + INTEGER :: ii, ij, iibm1, iibm2, ijbm1, ijbm2 ! 2D addresses + INTEGER :: iijm1, iijp1, ijjm1, ijjp1 ! 2D addresses + INTEGER :: iibm1jp1, iibm1jm1, ijbm1jp1, ijbm1jm1 ! 2D addresses + INTEGER :: ii_offset, ij_offset ! offsets for mask indices + INTEGER :: flagu, flagv ! short cuts + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) + REAL(wp) :: zmask_x, zmask_y1, zmask_y2 + REAL(wp) :: zex1, zex2, zey, zey1, zey2 + REAL(wp) :: zdt, zdx, zdy, znor2, zrx, zry ! intermediate calculations + REAL(dp) :: zout, zwgt, zdy_centred + REAL(wp) :: zdy_1, zdy_2, zsign_ups + REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value + REAL(wp), POINTER, DIMENSION(:,:) :: zmask ! land/sea mask for field + REAL(wp), POINTER, DIMENSION(:,:) :: zmask_xdif ! land/sea mask for x-derivatives + REAL(wp), POINTER, DIMENSION(:,:) :: zmask_ydif ! land/sea mask for y-derivatives + REAL(dp), POINTER, DIMENSION(:,:) :: pe_xdif ! scale factors for x-derivatives + REAL(dp), POINTER, DIMENSION(:,:) :: pe_ydif ! scale factors for y-derivatives + !!---------------------------------------------------------------------- + ! + ! ----------------------------------! + ! Orlanski boundary conditions :! + ! ----------------------------------! + + SELECT CASE(igrd) + CASE(1) + zmask => tmask(:,:,1) + zmask_xdif => umask(:,:,1) + zmask_ydif => vmask(:,:,1) + pe_xdif => e1u(:,:) + pe_ydif => e2v(:,:) + ii_offset = 0 + ij_offset = 0 + CASE(2) + zmask => umask(:,:,1) + zmask_xdif => tmask(:,:,1) + zmask_ydif => fmask(:,:,1) + pe_xdif => e1t(:,:) + pe_ydif => e2f(:,:) + ii_offset = 1 + ij_offset = 0 + CASE(3) + zmask => vmask(:,:,1) + zmask_xdif => fmask(:,:,1) + zmask_ydif => tmask(:,:,1) + pe_xdif => e1f(:,:) + pe_ydif => e2t(:,:) + ii_offset = 0 + ij_offset = 1 + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for igrd in bdy_orlanksi_2d' ) + END SELECT + ! + IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 + ENDIF + ! + DO jb = ibeg, iend + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE + flagu = int( idx%flagu(jb,igrd) ) + flagv = int( idx%flagv(jb,igrd) ) + ! + ! Calculate positions of b-1 and b-2 points for this rim point + ! also (b-1,j-1) and (b-1,j+1) points + iibm1 = ii + flagu ; iibm2 = ii + 2*flagu + ijbm1 = ij + flagv ; ijbm2 = ij + 2*flagv + ! + iijm1 = ii - abs(flagv) ; iijp1 = ii + abs(flagv) + ijjm1 = ij - abs(flagu) ; ijjp1 = ij + abs(flagu) + ! + iibm1jm1 = ii + flagu - abs(flagv) ; iibm1jp1 = ii + flagu + abs(flagv) + ijbm1jm1 = ij + flagv - abs(flagu) ; ijbm1jp1 = ij + flagv + abs(flagu) + ! + ! Calculate scale factors for calculation of spatial derivatives. + zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & + & + abs(ijbm1-ijbm2) * pe_ydif(iibm1 ,ijbm1 +ij_offset) ) + zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2 +ii_offset,ijbm2 ) & + & + abs(ijbm1-ijbm2) * pe_ydif(iibm2 ,ijbm2 +ij_offset) ) + zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) & + & + (ijbm1-ijbm1jm1) * pe_ydif(iibm1jm1 ,ijbm1jm1+ij_offset) ) + zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & + & + (ijbm1jp1-ijbm1) * pe_ydif(iibm1 ,ijbm1 +ij_offset) ) + ! make sure scale factors are nonzero + if( zey1 .lt. rsmall ) zey1 = zey2 + if( zey2 .lt. rsmall ) zey2 = zey1 + zex1 = max(zex1,rsmall); zex2 = max(zex2,rsmall) + zey1 = max(zey1,rsmall); zey2 = max(zey2,rsmall); + ! + ! Calculate masks for calculation of spatial derivatives. + zmask_x = ( abs(iibm1-iibm2) * zmask_xdif(iibm2 +ii_offset,ijbm2 ) & + & + abs(ijbm1-ijbm2) * zmask_ydif(iibm2 ,ijbm2 +ij_offset) ) + zmask_y1 = ( (iibm1-iibm1jm1) * zmask_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) & + & + (ijbm1-ijbm1jm1) * zmask_ydif(iibm1jm1 ,ijbm1jm1+ij_offset) ) + zmask_y2 = ( (iibm1jp1-iibm1) * zmask_xdif(iibm1 +ii_offset,ijbm1 ) & + & + (ijbm1jp1-ijbm1) * zmask_ydif(iibm1 ,ijbm1 +ij_offset) ) + + ! Calculation of terms required for both versions of the scheme. + ! Mask derivatives to ensure correct land boundary conditions for each variable. + ! Centred derivative is calculated as average of "left" and "right" derivatives for + ! this reason. + ! Note no rn_Dt factor in expression for zdt because it cancels in the expressions for + ! zrx and zry. + zdt = phia(iibm1 ,ijbm1 ) - phib(iibm1 ,ijbm1 ) + zdx = ( ( phia(iibm1 ,ijbm1 ) - phia(iibm2 ,ijbm2 ) ) / zex2 ) * zmask_x + zdy_1 = ( ( phib(iibm1 ,ijbm1 ) - phib(iibm1jm1,ijbm1jm1) ) / zey1 ) * zmask_y1 + zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1) - phib(iibm1 ,ijbm1 ) ) / zey2 ) * zmask_y2 + zdy_centred = 0.5 * ( zdy_1 + zdy_2 ) +!!$ zdy_centred = phib(iibm1jp1,ijbm1jp1) - phib(iibm1jm1,ijbm1jm1) + ! upstream differencing for tangential derivatives + zsign_ups = sign( 1.0_wp, zdt * zdy_centred ) + zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) + zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2 + znor2 = zdx * zdx + zdy * zdy + znor2 = max(znor2,zepsilon) + ! + zrx = zdt * zdx / ( zex1 * znor2 ) +!!$ zrx = min(zrx,2.0_wp) + zout = sign( 1.0_wp, zrx ) + zout = 0.5*( zout + abs(zout) ) + zwgt = 2.*rn_Dt*( (1.-zout) * idx%nbd(jb,igrd) + zout * idx%nbdout(jb,igrd) ) + ! only apply radiation on outflow points + if( ll_npo ) then !! NPO version !! + phia(ii,ij) = (1.-zout) * ( phib(ii,ij) + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) & + & + zout * ( phib(ii,ij) + zrx*phia(iibm1,ijbm1) & + & + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx ) + else !! full oblique radiation !! + zsign_ups = sign( 1.0_wp, zdt * zdy ) + zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) + zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2 + zry = zdt * zdy / ( zey * znor2 ) + phia(ii,ij) = (1.-zout) * ( phib(ii,ij) + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) & + & + zout * ( phib(ii,ij) + zrx*phia(iibm1,ijbm1) & + & - zsign_ups * zry * ( phib(ii ,ij ) - phib(iijm1,ijjm1 ) ) & + & - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1) - phib(ii ,ij ) ) & + & + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx ) + endif + phia(ii,ij) = phia(ii,ij) * zmask(ii,ij) + END DO + ! + END SUBROUTINE bdy_orlanski_2d + + + SUBROUTINE bdy_orlanski_3d( idx, igrd, phib, phia, phi_ext, lrim0, ll_npo ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_orlanski_3d *** + !! + !! - Apply Orlanski radiation condition adaptively to 3D fields: + !! - radiation plus weak nudging at outflow points + !! - no radiation and strong nudging at inflow points + !! + !! + !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in ) :: idx ! BDY indices + INTEGER , INTENT(in ) :: igrd ! grid index + REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: phib ! model before 3D field + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated) + REAL(wp), DIMENSION(:,: ), POINTER, INTENT(in ) :: phi_ext ! external forcing data + LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated + LOGICAL , INTENT(in ) :: ll_npo ! switch for NPO version + ! + INTEGER :: jb, jk ! dummy loop indices + INTEGER :: ii, ij, iibm1, iibm2, ijbm1, ijbm2 ! 2D addresses + INTEGER :: iijm1, iijp1, ijjm1, ijjp1 ! 2D addresses + INTEGER :: iibm1jp1, iibm1jm1, ijbm1jp1, ijbm1jm1 ! 2D addresses + INTEGER :: ii_offset, ij_offset ! offsets for mask indices + INTEGER :: flagu, flagv ! short cuts + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) + REAL(wp) :: zmask_x, zmask_y1, zmask_y2 + REAL(wp) :: zex1, zex2, zey, zey1, zey2 + REAL(wp) :: zdt, zdx, zdy, znor2, zrx, zry ! intermediate calculations + REAL(dp) :: zout, zwgt, zdy_centred + REAL(wp) :: zdy_1, zdy_2, zsign_ups + REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value + REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask ! land/sea mask for field + REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask_xdif ! land/sea mask for x-derivatives + REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask_ydif ! land/sea mask for y-derivatives + REAL(dp), POINTER, DIMENSION(:,:) :: pe_xdif ! scale factors for x-derivatives + REAL(dp), POINTER, DIMENSION(:,:) :: pe_ydif ! scale factors for y-derivatives + !!---------------------------------------------------------------------- + ! + ! ----------------------------------! + ! Orlanski boundary conditions :! + ! ----------------------------------! + ! + SELECT CASE(igrd) + CASE(1) + zmask => tmask(:,:,:) + zmask_xdif => umask(:,:,:) + zmask_ydif => vmask(:,:,:) + pe_xdif => e1u(:,:) + pe_ydif => e2v(:,:) + ii_offset = 0 + ij_offset = 0 + CASE(2) + zmask => umask(:,:,:) + zmask_xdif => tmask(:,:,:) + zmask_ydif => fmask(:,:,:) + pe_xdif => e1t(:,:) + pe_ydif => e2f(:,:) + ii_offset = 1 + ij_offset = 0 + CASE(3) + zmask => vmask(:,:,:) + zmask_xdif => fmask(:,:,:) + zmask_ydif => tmask(:,:,:) + pe_xdif => e1f(:,:) + pe_ydif => e2t(:,:) + ii_offset = 0 + ij_offset = 1 + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for igrd in bdy_orlanksi_2d' ) + END SELECT + ! + IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 + ENDIF + ! + DO jk = 1, jpk + ! + DO jb = ibeg, iend + ii = idx%nbi(jb,igrd) + ij = idx%nbj(jb,igrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE + flagu = int( idx%flagu(jb,igrd) ) + flagv = int( idx%flagv(jb,igrd) ) + ! + ! calculate positions of b-1 and b-2 points for this rim point + ! also (b-1,j-1) and (b-1,j+1) points + iibm1 = ii + flagu ; iibm2 = ii + 2*flagu + ijbm1 = ij + flagv ; ijbm2 = ij + 2*flagv + ! + iijm1 = ii - abs(flagv) ; iijp1 = ii + abs(flagv) + ijjm1 = ij - abs(flagu) ; ijjp1 = ij + abs(flagu) + ! + iibm1jm1 = ii + flagu - abs(flagv) ; iibm1jp1 = ii + flagu + abs(flagv) + ijbm1jm1 = ij + flagv - abs(flagu) ; ijbm1jp1 = ij + flagv + abs(flagu) + ! + ! Calculate scale factors for calculation of spatial derivatives. + zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & + & + abs(ijbm1-ijbm2) * pe_ydif(iibm1 ,ijbm1+ij_offset ) ) + zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2 +ii_offset,ijbm2 ) & + & + abs(ijbm1-ijbm2) * pe_ydif(iibm2 ,ijbm2+ij_offset ) ) + zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1 ) & + & + (ijbm1-ijbm1jm1) * pe_ydif(iibm1jm1 ,ijbm1jm1+ij_offset) ) + zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1 +ii_offset,ijbm1 ) & + & + (ijbm1jp1-ijbm1) * pe_ydif(iibm1 ,ijbm1+ij_offset ) ) + ! make sure scale factors are nonzero + if( zey1 .lt. rsmall ) zey1 = zey2 + if( zey2 .lt. rsmall ) zey2 = zey1 + zex1 = max(zex1,rsmall); zex2 = max(zex2,rsmall); + zey1 = max(zey1,rsmall); zey2 = max(zey2,rsmall); + ! + ! Calculate masks for calculation of spatial derivatives. + zmask_x = ( abs(iibm1-iibm2) * zmask_xdif(iibm2 +ii_offset,ijbm2 ,jk) & + & + abs(ijbm1-ijbm2) * zmask_ydif(iibm2 ,ijbm2 +ij_offset,jk) ) + zmask_y1 = ( (iibm1-iibm1jm1) * zmask_xdif(iibm1jm1+ii_offset,ijbm1jm1 ,jk) & + & + (ijbm1-ijbm1jm1) * zmask_ydif(iibm1jm1 ,ijbm1jm1+ij_offset,jk) ) + zmask_y2 = ( (iibm1jp1-iibm1) * zmask_xdif(iibm1 +ii_offset,ijbm1 ,jk) & + & + (ijbm1jp1-ijbm1) * zmask_ydif(iibm1 ,ijbm1 +ij_offset,jk) ) + ! + ! Calculate normal (zrx) and tangential (zry) components of radiation velocities. + ! Mask derivatives to ensure correct land boundary conditions for each variable. + ! Centred derivative is calculated as average of "left" and "right" derivatives for + ! this reason. + zdt = phia(iibm1 ,ijbm1 ,jk) - phib(iibm1 ,ijbm1 ,jk) + zdx = ( ( phia(iibm1 ,ijbm1 ,jk) - phia(iibm2 ,ijbm2 ,jk) ) / zex2 ) * zmask_x + zdy_1 = ( ( phib(iibm1 ,ijbm1 ,jk) - phib(iibm1jm1,ijbm1jm1,jk) ) / zey1 ) * zmask_y1 + zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1,jk) - phib(iibm1 ,ijbm1 ,jk) ) / zey2 ) * zmask_y2 + zdy_centred = 0.5 * ( zdy_1 + zdy_2 ) +!!$ zdy_centred = phib(iibm1jp1,ijbm1jp1,jk) - phib(iibm1jm1,ijbm1jm1,jk) + ! upstream differencing for tangential derivatives + zsign_ups = sign( 1.0_wp, zdt * zdy_centred ) + zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) + zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2 + znor2 = zdx * zdx + zdy * zdy + znor2 = max(znor2,zepsilon) + ! + ! update boundary value: + zrx = zdt * zdx / ( zex1 * znor2 ) +!!$ zrx = min(zrx,2.0_wp) + zout = sign( 1.0_wp, zrx ) + zout = 0.5*( zout + abs(zout) ) + zwgt = 2.*rn_Dt*( (1.-zout) * idx%nbd(jb,igrd) + zout * idx%nbdout(jb,igrd) ) + ! only apply radiation on outflow points + if( ll_npo ) then !! NPO version !! + phia(ii,ij,jk) = (1.-zout) * ( phib(ii,ij,jk) + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) & + & + zout * ( phib(ii,ij,jk) + zrx*phia(iibm1,ijbm1,jk) & + & + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx ) + else !! full oblique radiation !! + zsign_ups = sign( 1.0_wp, zdt * zdy ) + zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) + zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2 + zry = zdt * zdy / ( zey * znor2 ) + phia(ii,ij,jk) = (1.-zout) * ( phib(ii,ij,jk) + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) & + & + zout * ( phib(ii,ij,jk) + zrx*phia(iibm1,ijbm1,jk) & + & - zsign_ups * zry * ( phib(ii ,ij ,jk) - phib(iijm1,ijjm1,jk) ) & + & - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1,jk) - phib(ii ,ij ,jk) ) & + & + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx ) + endif + phia(ii,ij,jk) = phia(ii,ij,jk) * zmask(ii,ij,jk) + END DO + ! + END DO + ! + END SUBROUTINE bdy_orlanski_3d + + SUBROUTINE bdy_nmn( idx, igrd, phia, lrim0 ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_nmn *** + !! + !! ** Purpose : Duplicate the value at open boundaries, zero gradient. + !! + !! + !! ** Method : - take the average of free ocean neighbours + !! + !! ___ ! |_____| ! ___| ! __|x o ! |_ _| ! | + !! __|x ! x ! x o ! o ! |_| ! |x o + !! o ! o ! o ! ! o x o ! |x_x_ + !! ! o + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: igrd ! grid index + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated), must be masked + TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices + LOGICAL , INTENT(in ) :: lrim0 ! indicate if rim 0 is treated + !! + REAL(wp) :: zweight + REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask ! land/sea mask for field + INTEGER :: ib, ik ! dummy loop indices + INTEGER :: ii, ij ! 2D addresses + INTEGER :: ipkm1 ! size of phia third dimension minus 1 + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1 or both) + INTEGER :: ii1, ii2, ii3, ij1, ij2, ij3, itreat + !!---------------------------------------------------------------------- + ! + ipkm1 = MAX( SIZE(phia,3) - 1, 1 ) + ! + SELECT CASE(igrd) + CASE(1) ; zmask => tmask(:,:,:) + CASE(2) ; zmask => umask(:,:,:) + CASE(3) ; zmask => vmask(:,:,:) + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for igrd in bdy_nmn' ) + END SELECT + ! + IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 + ENDIF + ! + DO ib = ibeg, iend + ii = idx%nbi(ib,igrd) + ij = idx%nbj(ib,igrd) + itreat = idx%ntreat(ib,igrd) + CALL find_neib( ii, ij, itreat, ii1, ij1, ii2, ij2, ii3, ij3 ) ! find free ocean neighbours + SELECT CASE( itreat ) + CASE( 1:8 ) + IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE + DO ik = 1, ipkm1 + IF( zmask(ii1,ij1,ik) /= 0. ) phia(ii,ij,ik) = phia(ii1,ij1,ik) + END DO + CASE( 9:12 ) + IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE + IF( ii2 < 1 .OR. ii2 > jpi .OR. ij2 < 1 .OR. ij2 > jpj ) CYCLE + DO ik = 1, ipkm1 + zweight = zmask(ii1,ij1,ik) + zmask(ii2,ij2,ik) + IF( zweight /= 0. ) phia(ii,ij,ik) = ( phia(ii1,ij1,ik) + phia(ii2,ij2,ik) ) / zweight + END DO + CASE( 13:16 ) + IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE + IF( ii2 < 1 .OR. ii2 > jpi .OR. ij2 < 1 .OR. ij2 > jpj ) CYCLE + IF( ii3 < 1 .OR. ii3 > jpi .OR. ij3 < 1 .OR. ij3 > jpj ) CYCLE + DO ik = 1, ipkm1 + zweight = zmask(ii1,ij1,ik) + zmask(ii2,ij2,ik) + zmask(ii3,ij3,ik) + IF( zweight /= 0. ) phia(ii,ij,ik) = ( phia(ii1,ij1,ik) + phia(ii2,ij2,ik) + phia(ii3,ij3,ik) ) / zweight + END DO + END SELECT + END DO + ! + END SUBROUTINE bdy_nmn + + !!====================================================================== +END MODULE bdylib \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdytides.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdytides.F90 new file mode 100644 index 0000000..fa52680 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdytides.F90 @@ -0,0 +1,476 @@ +MODULE bdytides + !!====================================================================== + !! *** MODULE bdytides *** + !! Ocean dynamics: Tidal forcing at open boundaries + !!====================================================================== + !! History : 2.0 ! 2007-01 (D.Storkey) Original code + !! 2.3 ! 2008-01 (J.Holt) Add date correction. Origins POLCOMS v6.3 2007 + !! 3.0 ! 2008-04 (NEMO team) add in the reference version + !! 3.3 ! 2010-09 (D.Storkey and E.O'Dea) bug fixes + !! 3.4 ! 2012-09 (G. Reffray and J. Chanut) New inputs + mods + !! 3.5 ! 2013-07 (J. Chanut) Compliant with time splitting changes + !!---------------------------------------------------------------------- + !! bdytide_init : read of namelist and initialisation of tidal harmonics data + !! tide_update : calculation of tidal forcing at each timestep + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE bdy_oce ! ocean open boundary conditions + USE tide_mod ! + USE daymod ! calendar + ! + USE in_out_manager ! I/O units + USE iom ! xIO server + USE fldread ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC bdytide_init ! routine called in bdy_init + PUBLIC bdy_dta_tides ! routine called in dyn_spg_ts + + TYPE, PUBLIC :: TIDES_DATA !: Storage for external tidal harmonics data + REAL(wp), POINTER, DIMENSION(:,:,:) :: ssh0 !: Tidal constituents : SSH0 (read in file) + REAL(wp), POINTER, DIMENSION(:,:,:) :: u0, v0 !: Tidal constituents : U0, V0 (read in file) + REAL(wp), POINTER, DIMENSION(:,:,:) :: ssh !: Tidal constituents : SSH (after nodal cor.) + REAL(wp), POINTER, DIMENSION(:,:,:) :: u , v !: Tidal constituents : U , V (after nodal cor.) + END TYPE TIDES_DATA + +!$AGRIF_DO_NOT_TREAT + TYPE(TIDES_DATA), PUBLIC, DIMENSION(jp_bdy), TARGET :: tides !: External tidal harmonics data +!$AGRIF_END_DO_NOT_TREAT + TYPE(OBC_DATA) , PUBLIC, DIMENSION(jp_bdy) :: dta_bdy_s !: bdy external data (slow component) + + INTEGER :: kt_tide + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdytides.F90 14169 2020-12-14 18:32:36Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdytide_init + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdytide_init *** + !! + !! ** Purpose : - Read in namelist for tides and initialise external + !! tidal harmonics data + !! + !!---------------------------------------------------------------------- + !! namelist variables + !!------------------- + CHARACTER(len=80) :: filtide ! Filename root for tidal input files + LOGICAL :: ln_bdytide_2ddta ! If true, read 2d harmonic data + !! + INTEGER :: ib_bdy, itide, ib ! dummy loop indices + INTEGER :: ii, ij ! dummy loop indices + INTEGER :: inum, igrd + INTEGER :: isz ! bdy data size + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: nbdy_rdstart, nbdy_loc + CHARACTER(LEN=50) :: cerrmsg ! error string + CHARACTER(len=80) :: clfile ! full file name for tidal input file + REAL(wp),ALLOCATABLE, DIMENSION(:,:,:) :: dta_read ! work space to read in tidal harmonics data + REAL(wp),ALLOCATABLE, DIMENSION(:,:) :: ztr, zti ! " " " " " " " " + !! + TYPE(TIDES_DATA), POINTER :: td ! local short cut + TYPE( OBC_DATA), POINTER :: dta ! local short cut + !! + NAMELIST/nambdy_tide/filtide, ln_bdytide_2ddta + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'bdytide_init : initialization of tidal harmonic forcing at open boundaries' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + + + nbdy_rdstart = 1 + DO ib_bdy = 1, nb_bdy + IF( nn_dyn2d_dta(ib_bdy) >= 2 ) THEN + ! + td => tides(ib_bdy) + dta => dta_bdy(ib_bdy) + + ! Namelist nambdy_tide : tidal harmonic forcing at open boundaries + filtide(:) = '' + + READ ( numnam_ref, nambdy_tide, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_tide in reference namelist' ) + ! + ! Need to support possibility of reading more than one + ! nambdy_tide from the namelist_cfg internal file. + ! Do this by finding the ib_bdy'th occurence of nambdy_tide in the + ! character buffer as the starting point. + ! + nbdy_loc = INDEX( numnam_cfg( nbdy_rdstart: ), 'nambdy_tide' ) + IF( nbdy_loc .GT. 0 ) THEN + nbdy_rdstart = nbdy_rdstart + nbdy_loc + ELSE + WRITE(cerrmsg,'(A,I4,A)') 'Error: entry number ',ib_bdy,' of nambdy_tide not found' + ios = -1 + CALL ctl_nam ( ios , cerrmsg ) + ENDIF + READ ( numnam_cfg( MAX( 1, nbdy_rdstart - 2 ): ), nambdy_tide, IOSTAT = ios, ERR = 902) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy_tide in configuration namelist' ) + IF(lwm) WRITE ( numond, nambdy_tide ) + ! ! Parameter control and print + IF(lwp) WRITE(numout,*) ' ' + IF(lwp) WRITE(numout,*) ' Namelist nambdy_tide : tidal harmonic forcing at open boundaries' + IF(lwp) WRITE(numout,*) ' read tidal data in 2d files: ', ln_bdytide_2ddta + IF(lwp) WRITE(numout,*) ' Number of tidal components to read: ', nb_harmo + IF(lwp) THEN + WRITE(numout,*) ' Tidal components: ' + DO itide = 1, nb_harmo + WRITE(numout,*) ' ', tide_harmonics(itide)%cname_tide + END DO + ENDIF + IF(lwp) WRITE(numout,*) ' ' + + ! Allocate space for tidal harmonics data - get size from BDY data arrays + ! Allocate also slow varying data in the case of time splitting: + ! Do it anyway because at this stage knowledge of free surface scheme is unknown + ! ----------------------------------------------------------------------- + IF( ASSOCIATED(dta%ssh) ) THEN ! we use bdy ssh on this mpi subdomain + isz = SIZE(dta%ssh) + ALLOCATE( td%ssh0( isz, nb_harmo, 2 ), td%ssh( isz, nb_harmo, 2 ), dta_bdy_s(ib_bdy)%ssh( isz ) ) + dta_bdy_s(ib_bdy)%ssh(:) = 0._wp ! needed? + ENDIF + IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain + isz = SIZE(dta%u2d) + ALLOCATE( td%u0 ( isz, nb_harmo, 2 ), td%u ( isz, nb_harmo, 2 ), dta_bdy_s(ib_bdy)%u2d( isz ) ) + dta_bdy_s(ib_bdy)%u2d(:) = 0._wp ! needed? + ENDIF + IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain + isz = SIZE(dta%v2d) + ALLOCATE( td%v0 ( isz, nb_harmo, 2 ), td%v ( isz, nb_harmo, 2 ), dta_bdy_s(ib_bdy)%v2d( isz ) ) + dta_bdy_s(ib_bdy)%v2d(:) = 0._wp ! needed? + ENDIF + + ! fill td%ssh0, td%u0, td%v0 + ! ----------------------------------------------------------------------- + IF( ln_bdytide_2ddta ) THEN + ! + ! It is assumed that each data file contains all complex harmonic amplitudes + ! given on the global domain (ie global, jpiglo x jpjglo) + ! + ALLOCATE( zti(jpi,jpj), ztr(jpi,jpj) ) + ! + ! SSH fields + clfile = TRIM(filtide)//'_grid_T.nc' + CALL iom_open( clfile , inum ) + igrd = 1 ! Everything is at T-points here + DO itide = 1, nb_harmo + CALL iom_get( inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_z1', ztr(:,:) ) + CALL iom_get( inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_z2', zti(:,:) ) + IF( ASSOCIATED(dta%ssh) ) THEN ! we use bdy ssh on this mpi subdomain + DO ib = 1, SIZE(dta%ssh) + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + td%ssh0(ib,itide,1) = ztr(ii,ij) + td%ssh0(ib,itide,2) = zti(ii,ij) + END DO + ENDIF + END DO + CALL iom_close( inum ) + ! + ! U fields + clfile = TRIM(filtide)//'_grid_U.nc' + CALL iom_open( clfile , inum ) + igrd = 2 ! Everything is at U-points here + DO itide = 1, nb_harmo + CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_u1', ztr(:,:),cd_type='U',psgn=-1._dp) + CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_u2', zti(:,:),cd_type='U',psgn=-1._dp) + IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain + DO ib = 1, SIZE(dta%u2d) + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + td%u0(ib,itide,1) = ztr(ii,ij) + td%u0(ib,itide,2) = zti(ii,ij) + END DO + ENDIF + END DO + CALL iom_close( inum ) + ! + ! V fields + clfile = TRIM(filtide)//'_grid_V.nc' + CALL iom_open( clfile , inum ) + igrd = 3 ! Everything is at V-points here + DO itide = 1, nb_harmo + CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_v1', ztr(:,:),cd_type='V',psgn=-1._dp) + CALL iom_get(inum, jpdom_auto, TRIM(tide_harmonics(itide)%cname_tide)//'_v2', zti(:,:),cd_type='V',psgn=-1._dp) + IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain + DO ib = 1, SIZE(dta%v2d) + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + td%v0(ib,itide,1) = ztr(ii,ij) + td%v0(ib,itide,2) = zti(ii,ij) + END DO + ENDIF + END DO + CALL iom_close( inum ) + ! + DEALLOCATE( ztr, zti ) + ! + ELSE + ! + ! Read tidal data only on bdy segments + ! + ALLOCATE( dta_read( MAXVAL( idx_bdy(ib_bdy)%nblen(:) ), 1, 1 ) ) + ! + ! Open files and read in tidal forcing data + ! ----------------------------------------- + + DO itide = 1, nb_harmo + ! ! SSH fields + IF( ASSOCIATED(dta%ssh) ) THEN ! we use bdy ssh on this mpi subdomain + isz = SIZE(dta%ssh) + clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_T.nc' + CALL iom_open( clfile, inum ) + CALL fld_map( inum, 'z1', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) + td%ssh0(:,itide,1) = dta_read(1:isz,1,1) + CALL fld_map( inum, 'z2', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) + td%ssh0(:,itide,2) = dta_read(1:isz,1,1) + CALL iom_close( inum ) + ENDIF + ! ! U fields + IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain + isz = SIZE(dta%u2d) + clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_U.nc' + CALL iom_open( clfile, inum ) + CALL fld_map( inum, 'u1', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) + td%u0(:,itide,1) = dta_read(1:isz,1,1) + CALL fld_map( inum, 'u2', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) + td%u0(:,itide,2) = dta_read(1:isz,1,1) + CALL iom_close( inum ) + ENDIF + ! ! V fields + IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain + isz = SIZE(dta%v2d) + clfile = TRIM(filtide)//TRIM(tide_harmonics(itide)%cname_tide)//'_grid_V.nc' + CALL iom_open( clfile, inum ) + CALL fld_map( inum, 'v1', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) + td%v0(:,itide,1) = dta_read(1:isz,1,1) + CALL fld_map( inum, 'v2', dta_read(1:isz,1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) + td%v0(:,itide,2) = dta_read(1:isz,1,1) + CALL iom_close( inum ) + ENDIF + ! + END DO ! end loop on tidal components + ! + DEALLOCATE( dta_read ) + ! + ENDIF ! ln_bdytide_2ddta=.true. + ! + ENDIF ! nn_dyn2d_dta(ib_bdy) >= 2 + ! + END DO ! loop on ib_bdy + ! + END SUBROUTINE bdytide_init + + + SUBROUTINE bdy_dta_tides( kt, kit, pt_offset ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dta_tides *** + !! + !! ** Purpose : - Add tidal forcing to ssh, u2d and v2d OBC data arrays. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! Main timestep counter + INTEGER, OPTIONAL, INTENT(in) :: kit ! Barotropic timestep counter (for timesplitting option) + REAL(wp),OPTIONAL, INTENT(in) :: pt_offset ! time offset in units of timesteps + ! + LOGICAL :: lk_first_btstp ! =.TRUE. if time splitting and first barotropic step + INTEGER :: itide, ib_bdy, ib ! loop indices + REAL(wp) :: z_arg, z_sarg, zramp, zoff, z_cost, z_sist, zt_offset + !!---------------------------------------------------------------------- + ! + lk_first_btstp=.TRUE. + IF ( PRESENT(kit).AND.( kit /= 1 ) ) THEN ; lk_first_btstp=.FALSE. ; ENDIF + + zt_offset = 0._wp + IF( PRESENT(pt_offset) ) zt_offset = pt_offset + + ! Absolute time from model initialization: + IF( PRESENT(kit) ) THEN + z_arg = ( REAL(kt, wp) + ( REAL(kit, wp) + zt_offset - 1. ) / REAL(nn_e, wp) ) * rn_Dt + ELSE + z_arg = ( REAL(kt, wp) + zt_offset ) * rn_Dt + ENDIF + + ! Linear ramp on tidal component at open boundaries + zramp = 1. + IF (ln_tide_ramp) zramp = MIN(MAX( (z_arg - REAL(nit000,wp)*rn_Dt)/(rn_tide_ramp_dt*rday),0.),1.) + + DO ib_bdy = 1,nb_bdy + ! + IF( nn_dyn2d_dta(ib_bdy) >= 2 ) THEN + ! + ! We refresh nodal factors every day below + ! This should be done somewhere else + IF ( ( nsec_day == NINT(0.5_wp * rn_Dt) .OR. kt==nit000 ) .AND. lk_first_btstp ) THEN + ! + kt_tide = kt - NINT((REAL(nsec_day,wp) - 0.5_wp * rn_Dt)/rn_Dt) + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'bdy_tide_dta : Refresh nodal factors for tidal open bdy data at kt=',kt + WRITE(numout,*) '~~~~~~~~~~~~~~ ' + ENDIF + ! + CALL tide_init_elevation ( idx=idx_bdy(ib_bdy), td=tides(ib_bdy) ) + CALL tide_init_velocities( idx=idx_bdy(ib_bdy), td=tides(ib_bdy) ) + ! + ENDIF + zoff = REAL(-kt_tide,wp) * rn_Dt ! time offset relative to nodal factor computation time + ! + ! If time splitting, initialize arrays from slow varying open boundary data: + IF ( PRESENT(kit) ) THEN + IF ( ASSOCIATED(dta_bdy(ib_bdy)%ssh) ) dta_bdy(ib_bdy)%ssh(:) = dta_bdy_s(ib_bdy)%ssh(:) + IF ( ASSOCIATED(dta_bdy(ib_bdy)%u2d) ) dta_bdy(ib_bdy)%u2d(:) = dta_bdy_s(ib_bdy)%u2d(:) + IF ( ASSOCIATED(dta_bdy(ib_bdy)%v2d) ) dta_bdy(ib_bdy)%v2d(:) = dta_bdy_s(ib_bdy)%v2d(:) + ENDIF + ! + ! Update open boundary data arrays: + DO itide = 1, nb_harmo + ! + z_sarg = (z_arg + zoff) * tide_harmonics(itide)%omega + z_cost = zramp * COS( z_sarg ) + z_sist = zramp * SIN( z_sarg ) + ! + IF ( ASSOCIATED(dta_bdy(ib_bdy)%ssh) ) THEN ! SSH on tracer grid + DO ib = 1, SIZE(dta_bdy(ib_bdy)%ssh) + dta_bdy(ib_bdy)%ssh(ib) = dta_bdy(ib_bdy)%ssh(ib) + & + & ( tides(ib_bdy)%ssh(ib,itide,1)*z_cost + & + & tides(ib_bdy)%ssh(ib,itide,2)*z_sist ) + END DO + ENDIF + ! + IF ( ASSOCIATED(dta_bdy(ib_bdy)%u2d) ) THEN ! U grid + DO ib = 1, SIZE(dta_bdy(ib_bdy)%u2d) + dta_bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) + & + & ( tides(ib_bdy)%u(ib,itide,1)*z_cost + & + & tides(ib_bdy)%u(ib,itide,2)*z_sist ) + END DO + ENDIF + ! + IF ( ASSOCIATED(dta_bdy(ib_bdy)%v2d) ) THEN ! V grid + DO ib = 1, SIZE(dta_bdy(ib_bdy)%v2d) + dta_bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) + & + & ( tides(ib_bdy)%v(ib,itide,1)*z_cost + & + & tides(ib_bdy)%v(ib,itide,2)*z_sist ) + END DO + ENDIF + ! + END DO + ENDIF + END DO + ! + END SUBROUTINE bdy_dta_tides + + + SUBROUTINE tide_init_elevation( idx, td ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init_elevation *** + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX) , INTENT(in ) :: idx ! OBC indices + TYPE(TIDES_DATA), INTENT(inout) :: td ! tidal harmonics data + ! + INTEGER :: itide, isz, ib ! dummy loop indices + REAL(wp),ALLOCATABLE, DIMENSION(:) :: mod_tide, phi_tide + !!---------------------------------------------------------------------- + ! + IF( ASSOCIATED(td%ssh0) ) THEN ! SSH on tracer grid. + ! + isz = SIZE( td%ssh0, dim = 1 ) + ALLOCATE( mod_tide(isz), phi_tide(isz) ) + ! + DO itide = 1, nb_harmo + DO ib = 1, isz + mod_tide(ib)=SQRT( td%ssh0(ib,itide,1)*td%ssh0(ib,itide,1) + td%ssh0(ib,itide,2)*td%ssh0(ib,itide,2) ) + phi_tide(ib)=ATAN2(-td%ssh0(ib,itide,2),td%ssh0(ib,itide,1)) + END DO + DO ib = 1, isz + mod_tide(ib)=mod_tide(ib)*tide_harmonics(itide)%f + phi_tide(ib)=phi_tide(ib)+tide_harmonics(itide)%v0+tide_harmonics(itide)%u + END DO + DO ib = 1, isz + td%ssh(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib)) + td%ssh(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib)) + END DO + END DO + ! + DEALLOCATE( mod_tide, phi_tide ) + ! + ENDIF + ! + END SUBROUTINE tide_init_elevation + + + SUBROUTINE tide_init_velocities( idx, td ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init_elevation *** + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX) , INTENT(in ) :: idx ! OBC indices + TYPE(TIDES_DATA), INTENT(inout) :: td ! tidal harmonics data + ! + INTEGER :: itide, isz, ib ! dummy loop indices + REAL(wp),ALLOCATABLE, DIMENSION(:) :: mod_tide, phi_tide + !!---------------------------------------------------------------------- + ! + IF( ASSOCIATED(td%u0) ) THEN ! U grid. we use bdy u2d on this mpi subdomain + ! + isz = SIZE( td%u0, dim = 1 ) + ALLOCATE( mod_tide(isz), phi_tide(isz) ) + ! + DO itide = 1, nb_harmo + DO ib = 1, isz + mod_tide(ib)=SQRT( td%u0(ib,itide,1)*td%u0(ib,itide,1) + td%u0(ib,itide,2)*td%u0(ib,itide,2) ) + phi_tide(ib)=ATAN2(-td%u0(ib,itide,2),td%u0(ib,itide,1)) + END DO + DO ib = 1, isz + mod_tide(ib)=mod_tide(ib)*tide_harmonics(itide)%f + phi_tide(ib)=phi_tide(ib)+tide_harmonics(itide)%v0 + tide_harmonics(itide)%u + END DO + DO ib = 1, isz + td%u(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib)) + td%u(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib)) + END DO + END DO + ! + DEALLOCATE( mod_tide, phi_tide ) + ! + ENDIF + ! + IF( ASSOCIATED(td%v0) ) THEN ! V grid. we use bdy u2d on this mpi subdomain + ! + isz = SIZE( td%v0, dim = 1 ) + ALLOCATE( mod_tide(isz), phi_tide(isz) ) + ! + DO itide = 1, nb_harmo + DO ib = 1, isz + mod_tide(ib)=SQRT( td%v0(ib,itide,1)*td%v0(ib,itide,1) + td%v0(ib,itide,2)*td%v0(ib,itide,2) ) + phi_tide(ib)=ATAN2(-td%v0(ib,itide,2),td%v0(ib,itide,1)) + END DO + DO ib = 1, isz + mod_tide(ib)=mod_tide(ib)*tide_harmonics(itide)%f + phi_tide(ib)=phi_tide(ib)+tide_harmonics(itide)%v0 + tide_harmonics(itide)%u + END DO + DO ib = 1, isz + td%v(ib,itide,1)= mod_tide(ib)*COS(phi_tide(ib)) + td%v(ib,itide,2)=-mod_tide(ib)*SIN(phi_tide(ib)) + END DO + END DO + ! + DEALLOCATE( mod_tide, phi_tide ) + ! + ENDIF + ! + END SUBROUTINE tide_init_velocities + + !!====================================================================== +END MODULE bdytides diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdytra.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdytra.F90 new file mode 100644 index 0000000..a4cf411 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdytra.F90 @@ -0,0 +1,186 @@ +MODULE bdytra + !!====================================================================== + !! *** MODULE bdytra *** + !! Ocean tracers: Apply boundary conditions for tracers + !!====================================================================== + !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code + !! 3.0 ! 2008-04 (NEMO team) add in the reference version + !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge + !! 3.5 ! 2012 (S. Mocavero, I. Epicoco) Optimization of BDY communications + !! 4.0 ! 2016 (T. Lovato) Generalize OBC structure + !!---------------------------------------------------------------------- + !! bdy_tra : Apply open boundary conditions & damping to T and S + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE bdy_oce ! ocean open boundary conditions + USE bdylib ! for orlanski library routines + ! + USE in_out_manager ! I/O manager + USE lib_mpp, ONLY: jpfillnothing + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp, ONLY: ctl_stop + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + ! Local structure to rearrange tracers data + TYPE, PUBLIC :: ztrabdy + REAL(wp), POINTER, DIMENSION(:,:) :: tra + END TYPE + + PUBLIC bdy_tra ! called in tranxt.F90 + PUBLIC bdy_tra_dmp ! called in step.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdytra.F90 15354 2021-10-12 13:44:46Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_tra( kt, Kbb, pts, Kaa ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_tra *** + !! + !! ** Purpose : - Apply open boundary conditions for temperature and salinity + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! Main time step counter + INTEGER , INTENT(in) :: Kbb, Kaa ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! tracer fields + ! + INTEGER :: ib_bdy, jn, igrd, ir ! Loop indeces + TYPE(ztrabdy), DIMENSION(jpts) :: zdta ! Temporary data structure + LOGICAL :: llrim0 ! indicate if rim 0 is treated + LOGICAL, DIMENSION(8) :: llsend1, llrecv1 ! indicate how communications are to be carried out + !!---------------------------------------------------------------------- + igrd = 1 + llsend1(:) = .false. ; llrecv1(:) = .false. + DO ir = 1, 0, -1 ! treat rim 1 before rim 0 + IF( ir == 0 ) THEN ; llrim0 = .TRUE. + ELSE ; llrim0 = .FALSE. + ENDIF + DO ib_bdy=1, nb_bdy + ! + zdta(1)%tra => dta_bdy(ib_bdy)%tem + zdta(2)%tra => dta_bdy(ib_bdy)%sal + ! + DO jn = 1, jpts + ! + SELECT CASE( cn_tra(ib_bdy) ) + CASE('none' ) ; CYCLE + CASE('frs' ) ! treat the whole boundary at once + IF( ir == 0 ) CALL bdy_frs ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), zdta(jn)%tra ) + CASE('specified' ) ! treat the whole rim at once + IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), zdta(jn)%tra ) + CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd , pts(:,:,:,jn,Kaa), llrim0 ) ! tsa masked + CASE('orlanski' ) ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), zdta(jn)%tra, & + & llrim0, ll_npo=.FALSE. ) + CASE('orlanski_npo') ; CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), zdta(jn)%tra, & + & llrim0, ll_npo=.TRUE. ) + CASE('runoff' ) ; CALL bdy_rnf ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kaa), jn, llrim0 ) + CASE DEFAULT ; CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) + END SELECT + ! + END DO + END DO + ! + IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 + IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; ENDIF + DO ib_bdy=1, nb_bdy + SELECT CASE( cn_tra(ib_bdy) ) + CASE('neumann','runoff') + llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points + llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points + CASE('orlanski', 'orlanski_npo') + llsend1(:) = llsend1(:) .OR. lsend_bdyolr(ib_bdy,1,:,ir) ! possibly every direction, T points + llrecv1(:) = llrecv1(:) .OR. lrecv_bdyolr(ib_bdy,1,:,ir) ! possibly every direction, T points + END SELECT + END DO + IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdytra', pts(:,:,:,jn,Kaa), 'T', 1.0_dp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + ENDIF + ! + END DO ! ir + ! + END SUBROUTINE bdy_tra + + + SUBROUTINE bdy_rnf( idx, pt, jpa, llrim0 ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_rnf *** + !! + !! ** Purpose : Specialized routine to apply TRA runoff values at OBs: + !! - duplicate the neighbour value for the temperature + !! - specified to 0.1 PSU for the salinity + !! + !!---------------------------------------------------------------------- + TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt ! tracer trend + INTEGER, INTENT(in) :: jpa ! TRA index + LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated + ! + INTEGER :: ib, ii, ij, igrd ! dummy loop indices + !!---------------------------------------------------------------------- + ! + igrd = 1 ! Everything is at T-points here + IF( jpa == jp_tem ) THEN + CALL bdy_nmn( idx, igrd, pt, llrim0 ) + ELSE IF( jpa == jp_sal ) THEN + IF( .NOT. llrim0 ) RETURN + DO ib = 1, idx%nblenrim(igrd) ! if llrim0 then treat the whole rim + ii = idx%nbi(ib,igrd) + ij = idx%nbj(ib,igrd) + pt(ii,ij,1:jpkm1) = 0.1 * tmask(ii,ij,1:jpkm1) + END DO + ENDIF + ! + END SUBROUTINE bdy_rnf + + + SUBROUTINE bdy_tra_dmp( kt, Kbb, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_tra_dmp *** + !! + !! ** Purpose : Apply damping for tracers at open boundaries. + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! time step + INTEGER , INTENT(in) :: Kbb, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + REAL(wp) :: zwgt ! boundary weight + REAL(wp) :: zta, zsa, ztime + INTEGER :: ib, ik, igrd ! dummy loop indices + INTEGER :: ii, ij ! 2D addresses + INTEGER :: ib_bdy ! Loop index + !!---------------------------------------------------------------------- + IF( l_istiled .AND. ntile /= 1 ) RETURN ! Do only for the full domain + ! + IF( ln_timing ) CALL timing_start('bdy_tra_dmp') + ! + DO ib_bdy = 1, nb_bdy + IF( ln_tra_dmp(ib_bdy) ) THEN + igrd = 1 ! Everything is at T-points here + DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + zwgt = idx_bdy(ib_bdy)%nbd(ib,igrd) + DO ik = 1, jpkm1 + zta = zwgt * ( dta_bdy(ib_bdy)%tem(ib,ik) - pts(ii,ij,ik,jp_tem,Kbb) ) * tmask(ii,ij,ik) + zsa = zwgt * ( dta_bdy(ib_bdy)%sal(ib,ik) - pts(ii,ij,ik,jp_sal,Kbb) ) * tmask(ii,ij,ik) + pts(ii,ij,ik,jp_tem,Krhs) = pts(ii,ij,ik,jp_tem,Krhs) + zta + pts(ii,ij,ik,jp_sal,Krhs) = pts(ii,ij,ik,jp_sal,Krhs) + zsa + END DO + END DO + ENDIF + END DO + ! + IF( ln_timing ) CALL timing_stop('bdy_tra_dmp') + ! + END SUBROUTINE bdy_tra_dmp + + !!====================================================================== +END MODULE bdytra diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdyvol.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdyvol.F90 new file mode 100644 index 0000000..1ff413e --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/BDY/bdyvol.F90 @@ -0,0 +1,229 @@ +MODULE bdyvol + !!====================================================================== + !! *** MODULE bdyvol *** + !! Ocean dynamic : Volume constraint when unstructured boundary + !! and filtered free surface are used + !!====================================================================== + !! History : 1.0 ! 2005-01 (J. Chanut, A. Sellar) Original code + !! - ! 2006-01 (J. Chanut) Bug correction + !! 3.0 ! 2008-04 (NEMO team) add in the reference version + !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge + !! 4.0 ! 2019-01 (P. Mathiot) adapted to time splitting + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE bdy_oce ! ocean open boundary conditions + USE sbc_oce ! ocean surface boundary conditions + USE isf_oce, ONLY : fwfisf_cav, fwfisf_par ! ice shelf + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! for mppsum + USE lib_fortran ! Fortran routines library + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_vol2d ! called by dynspg_ts + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: bdyvol.F90 15004 2021-06-16 10:33:18Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_vol2d( kt, kc, pua2d, pva2d, phu, phv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bdyvol *** + !! + !! ** Purpose : This routine controls the volume of the system. + !! A correction velocity is calculated to correct the total transport + !! through the unstructured OBC. + !! + !! ** Method : The correction velocity (zubtpecor here) is defined calculating + !! the total transport through all open boundaries (trans_bdy) minus + !! the cumulate E-P flux (z_cflxemp) divided by the total lateral + !! surface (bdysurftot) of the unstructured boundary. + !! zubtpecor = [trans_bdy - z_cflxemp ]*(1./bdysurftot) + !! with z_cflxemp => sum of (Evaporation minus Precipitation) + !! over all the domain in m3/s at each time step. + !! z_cflxemp < 0 when precipitation dominate + !! z_cflxemp > 0 when evaporation dominate + !! + !! There are 2 options (user's desiderata): + !! 1/ The volume changes according to E-P, this is the default + !! option. In this case the cumulate E-P flux are setting to + !! zero (z_cflxemp=0) to calculate the correction velocity. So + !! it will only balance the flux through open boundaries. + !! (set nn_volctl to 0 in tne namelist for this option) + !! 2/ The volume is constant even with E-P flux. In this case + !! the correction velocity must balance both the flux + !! through open boundaries and the ones through the free + !! surface. + !! (set nn_volctl to 1 in tne namelist for this option) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt, kc ! ocean time-step index, cycle time-step + ! + INTEGER :: ji, jj, jk, jb, jgrd + INTEGER :: ib_bdy, ii, ij + REAL(wp) :: zubtpecor, ztranst + REAL(wp), SAVE :: z_cflxemp ! cumulated emp flux + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d ! Barotropic velocities + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phu, phv ! Ocean depth at U- and V-points + TYPE(OBC_INDEX), POINTER :: idx + !!----------------------------------------------------------------------------- + ! + ! Calculate the cumulate surface Flux z_cflxemp (m3/s) over all the domain + ! ----------------------------------------------------------------------- + IF ( kc == 1 ) z_cflxemp = glob_sum( 'bdyvol', ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) ) * bdytmask(:,:) * e1e2t(:,:) ) / rho0 + + ! Compute bdy surface each cycle if non linear free surface + ! --------------------------------------------------------- + IF ( .NOT. ln_linssh ) THEN + ! compute area each time step + bdysurftot = bdy_segs_surf( phu, phv ) + ELSE + ! compute area only the first time + IF ( ( kt == nit000 ) .AND. ( kc == 1 ) ) bdysurftot = bdy_segs_surf( phu, phv ) + END IF + + ! Transport through the unstructured open boundary + ! ------------------------------------------------ + zubtpecor = 0._wp + DO ib_bdy = 1, nb_bdy + idx => idx_bdy(ib_bdy) + ! + jgrd = 2 ! cumulate u component contribution first + DO jb = 1, idx%nblenrim(jgrd) + ii = idx%nbi(jb,jgrd) + ij = idx%nbj(jb,jgrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! sum : else halo couted twice + zubtpecor = zubtpecor + idx%flagu(jb,jgrd) * pua2d(ii,ij) * e2u(ii,ij) * phu(ii,ij) * tmask_i(ii,ij) * tmask_i(ii+1,ij) + END DO + jgrd = 3 ! then add v component contribution + DO jb = 1, idx%nblenrim(jgrd) + ii = idx%nbi(jb,jgrd) + ij = idx%nbj(jb,jgrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! sum : else halo couted twice + zubtpecor = zubtpecor + idx%flagv(jb,jgrd) * pva2d(ii,ij) * e1v(ii,ij) * phv(ii,ij) * tmask_i(ii,ij) * tmask_i(ii,ij+1) + END DO + ! + END DO + IF( lk_mpp ) CALL mpp_sum( 'bdyvol', zubtpecor ) ! sum over the global domain + + ! The normal velocity correction + ! ------------------------------ + IF( nn_volctl==1 ) THEN ; zubtpecor = ( zubtpecor - z_cflxemp ) / bdysurftot ! maybe should be apply only once at the end + ELSE ; zubtpecor = zubtpecor / bdysurftot + END IF + + ! Correction of the total velocity on the unstructured boundary to respect the mass flux conservation + ! ------------------------------------------------------------- + DO ib_bdy = 1, nb_bdy + idx => idx_bdy(ib_bdy) + ! + jgrd = 2 ! correct u component + DO jb = 1, idx%nblenrim(jgrd) + ii = idx%nbi(jb,jgrd) + ij = idx%nbj(jb,jgrd) + !IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove ? + pua2d(ii,ij) = pua2d(ii,ij) - idx%flagu(jb,jgrd) * zubtpecor * tmask_i(ii,ij) * tmask_i(ii+1,ij) + END DO + jgrd = 3 ! correct v component + DO jb = 1, idx%nblenrim(jgrd) + ii = idx%nbi(jb,jgrd) + ij = idx%nbj(jb,jgrd) + !IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE ! to remove ? + pva2d(ii,ij) = pva2d(ii,ij) - idx%flagv(jb,jgrd) * zubtpecor * tmask_i(ii,ij) * tmask_i(ii,ij+1) + END DO + ! + END DO + ! + ! Check the cumulated transport through unstructured OBC once barotropic velocities corrected + ! ------------------------------------------------------ + IF( MOD( kt, MAX(nn_write,1) ) == 0 .AND. ( kc == 1 ) ) THEN + ! + ! compute residual transport across boundary + ztranst = 0._wp + DO ib_bdy = 1, nb_bdy + idx => idx_bdy(ib_bdy) + ! + jgrd = 2 ! correct u component + DO jb = 1, idx%nblenrim(jgrd) + ii = idx%nbi(jb,jgrd) + ij = idx%nbj(jb,jgrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE + ztranst = ztranst + idx%flagu(jb,jgrd) * pua2d(ii,ij) * e2u(ii,ij) * phu(ii,ij) * tmask_i(ii,ij) * tmask_i(ii+1,ij) + END DO + jgrd = 3 ! correct v component + DO jb = 1, idx%nblenrim(jgrd) + ii = idx%nbi(jb,jgrd) + ij = idx%nbj(jb,jgrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE + ztranst = ztranst + idx%flagv(jb,jgrd) * pva2d(ii,ij) * e1v(ii,ij) * phv(ii,ij) * tmask_i(ii,ij) * tmask_i(ii,ij+1) + END DO + ! + END DO + IF( lk_mpp ) CALL mpp_sum('bdyvol', ztranst ) ! sum over the global domain + + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)'bdy_vol : time step :', kt + IF(lwp) WRITE(numout,*)'~~~~~~~ ' + IF(lwp) WRITE(numout,*)' cumulate flux EMP =', z_cflxemp , ' (m3/s)' + IF(lwp) WRITE(numout,*)' total lateral surface of OBC =', bdysurftot, '(m2)' + IF(lwp) WRITE(numout,*)' correction velocity zubtpecor =', zubtpecor , '(m/s)' + IF(lwp) WRITE(numout,*)' cumulated transport ztranst =', ztranst , '(m3/s)' + END IF + ! + END SUBROUTINE bdy_vol2d + ! + REAL(wp) FUNCTION bdy_segs_surf(phu, phv) + !!---------------------------------------------------------------------- + !! *** ROUTINE bdy_ctl_seg *** + !! + !! ** Purpose : Compute total lateral surface for volume correction + !! + !!---------------------------------------------------------------------- + + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phu, phv ! water column thickness at U and V points + INTEGER :: igrd, ib_bdy, ib ! loop indexes + INTEGER , POINTER :: nbi, nbj ! short cuts + REAL(wp), POINTER :: zflagu, zflagv ! - - + + ! Compute total lateral surface for volume correction: + ! ---------------------------------------------------- + bdy_segs_surf = 0._wp + igrd = 2 ! Lateral surface at U-points + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) + nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) + nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( nbi == 1 .OR. nbi == jpi .OR. nbj == 1 .OR. nbj == jpj ) CYCLE + zflagu => idx_bdy(ib_bdy)%flagu(ib,igrd) + bdy_segs_surf = bdy_segs_surf + phu(nbi, nbj) & + & * e2u(nbi, nbj) * ABS( zflagu ) & + & * tmask_i(nbi, nbj) * tmask_i(nbi+1, nbj) + END DO + END DO + + igrd=3 ! Add lateral surface at V-points + DO ib_bdy = 1, nb_bdy + DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) + nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) + nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( nbi == 1 .OR. nbi == jpi .OR. nbj == 1 .OR. nbj == jpj ) CYCLE + zflagv => idx_bdy(ib_bdy)%flagv(ib,igrd) + bdy_segs_surf = bdy_segs_surf + phv(nbi, nbj) & + & * e1v(nbi, nbj) * ABS( zflagv ) & + & * tmask_i(nbi, nbj) * tmask_i(nbi, nbj+1) + END DO + END DO + ! + ! redirect the time to bdyvol as this variable is only used by bdyvol + IF( lk_mpp ) CALL mpp_sum( 'bdyvol', bdy_segs_surf ) ! sum over the global domain + ! + END FUNCTION bdy_segs_surf + !!====================================================================== +END MODULE bdyvol \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/C1D/c1d.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/C1D/c1d.F90 new file mode 100644 index 0000000..0a8b533 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/C1D/c1d.F90 @@ -0,0 +1,66 @@ +MODULE c1d + !!====================================================================== + !! *** MODULE c1d *** + !! Ocean domain : 1D configuration + !!===================================================================== + !! History : 2.0 ! 2004-09 (C. Ethe) Original code + !! 3.0 ! 2008-04 (G. Madec) adaptation to SBC + !! 3.5 ! 2013-10 (D. Calvert) add namelist + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! c1d_init : read in the C1D namelist + !!---------------------------------------------------------------------- + USE par_kind ! kind parameters + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC c1d_init ! called by nemogcm.F90 + + REAL(wp), PUBLIC :: rn_lat1d !: Column latitude + REAL(wp), PUBLIC :: rn_lon1d !: Column longitude + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: c1d.F90 15023 2021-06-18 14:35:25Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +CONTAINS + + SUBROUTINE c1d_init + !!---------------------------------------------------------------------- + !! *** ROUTINE c1d_init *** + !! + !! ** Purpose : Initialization of C1D options + !! + !! ** Method : Read namelist namc1d + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer + !! + NAMELIST/namc1d/ rn_lat1d, rn_lon1d + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namc1d, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d in reference namelist' ) + ! + READ ( numnam_cfg, namc1d, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d in configuration namelist' ) + IF(lwm) WRITE ( numond, namc1d ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'c1d_init : Initialize 1D model configuration options' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) ' Namelist namc1d : set options for the C1D model' + WRITE(numout,*) ' column latitude rn_lat1d = ', rn_lat1d + WRITE(numout,*) ' column longitude rn_lon1d = ', rn_lon1d + ENDIF + ! + END SUBROUTINE c1d_init + + !!====================================================================== +END MODULE c1d \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/C1D/dtauvd.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/C1D/dtauvd.F90 new file mode 100644 index 0000000..ba34017 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/C1D/dtauvd.F90 @@ -0,0 +1,224 @@ +MODULE dtauvd + !!====================================================================== + !! *** MODULE dtauvd *** + !! Ocean data : read ocean U & V current data from gridded data + !!====================================================================== + !! History : 3.5 ! 2013-08 (D. Calvert) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dta_uvd_init : read namelist and allocate data structures + !! dta_uvd : read and time-interpolate ocean U & V current data + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE phycst ! physical constants + USE dom_oce ! ocean space and time domain + ! + USE in_out_manager ! I/O manager + USE fldread ! read input fields + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dta_uvd_init ! called by nemogcm.F90 + PUBLIC dta_uvd ! called by istate.F90 and dyndmp.90 + + LOGICAL , PUBLIC :: ln_uvd_init = .FALSE. ! Flag to initialise with U & V current data + LOGICAL , PUBLIC :: ln_uvd_dyndmp = .FALSE. ! Flag for Newtonian damping toward U & V current data + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_uvd ! structure for input U & V current (file information and data) + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dtauvd.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dta_uvd_init( ld_dyndmp ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dta_uvd_init *** + !! + !! ** Purpose : initialization of U & V current input data + !! + !! ** Method : - read namc1d_uvd namelist + !! - allocate U & V current data structure + !! - fld_fill data structure with namelist information + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in), OPTIONAL :: ld_dyndmp ! force the initialization when dyndmp is used + ! + INTEGER :: ios, ierr0, ierr1, ierr2, ierr3 ! local integers + CHARACTER(len=100) :: cn_dir ! Root directory for location of files to be used + TYPE(FLD_N), DIMENSION(2) :: suv_i ! Combined U & V namelist information + TYPE(FLD_N) :: sn_ucur, sn_vcur ! U & V data namelist information + !! + NAMELIST/namc1d_uvd/ ln_uvd_init, ln_uvd_dyndmp, cn_dir, sn_ucur, sn_vcur + !!---------------------------------------------------------------------- + ! + ierr0 = 0 ; ierr1 = 0 ; ierr2 = 0 ; ierr3 = 0 + + READ ( numnam_ref, namc1d_uvd, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d_uvd in reference namelist' ) + ! + READ ( numnam_cfg, namc1d_uvd, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d_uvd in configuration namelist' ) + IF(lwm) WRITE ( numond, namc1d_uvd ) + + ! ! force the initialization when dyndmp is used + IF( PRESENT( ld_dyndmp ) ) ln_uvd_dyndmp = .TRUE. + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dta_uvd_init : U & V current data ' + WRITE(numout,*) '~~~~~~~~~~~~ ' + WRITE(numout,*) ' Namelist namc1d_uvd : Set flags' + WRITE(numout,*) ' Initialization of ocean U & V current with input data ln_uvd_init = ', ln_uvd_init + WRITE(numout,*) ' Damping of ocean U & V current toward input data ln_uvd_dyndmp = ', ln_uvd_dyndmp + WRITE(numout,*) + IF( .NOT. ln_uvd_init .AND. .NOT. ln_uvd_dyndmp ) THEN + WRITE(numout,*) + WRITE(numout,*) ' U & V current data not used' + ENDIF + ENDIF + ! ! no initialization when restarting + IF( ln_rstart .AND. ln_uvd_init ) THEN + CALL ctl_warn( 'dta_uvd_init: ocean restart and U & V current data initialization, ', & + & 'we keep the restart U & V current values and set ln_uvd_init to FALSE' ) + ln_uvd_init = .FALSE. + ENDIF + + ! + IF( ln_uvd_init .OR. ln_uvd_dyndmp ) THEN + ! !== allocate the data arrays ==! + ALLOCATE( sf_uvd(2), STAT=ierr0 ) + IF( ierr0 > 0 ) THEN + CALL ctl_stop( 'dta_uvd_init: unable to allocate sf_uvd structure' ) ; RETURN + ENDIF + ! + ALLOCATE( sf_uvd(1)%fnow(jpi,jpj,jpk) , STAT=ierr0 ) + IF( sn_ucur%ln_tint ) ALLOCATE( sf_uvd(1)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 ) + ALLOCATE( sf_uvd(2)%fnow(jpi,jpj,jpk) , STAT=ierr2 ) + IF( sn_vcur%ln_tint ) ALLOCATE( sf_uvd(2)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 ) + ! + IF( ierr0 + ierr1 + ierr2 + ierr3 > 0 ) THEN + CALL ctl_stop( 'dta_uvd_init : unable to allocate U & V current data arrays' ) ; RETURN + ENDIF + ! !== fill sf_uvd with sn_ucur, sn_vcur and control print ==! + suv_i(1) = sn_ucur ; suv_i(2) = sn_vcur + CALL fld_fill( sf_uvd, suv_i, cn_dir, 'dta_uvd', 'U & V current data', 'namc1d_uvd' ) + ! + ENDIF + ! + END SUBROUTINE dta_uvd_init + + + SUBROUTINE dta_uvd( kt, Kmm, pud, pvd ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dta_uvd *** + !! + !! ** Purpose : provides U & V current data at time step kt + !! + !! ** Method : - call fldread routine + !! - ORCA_R2: make some hand made alterations to the data (EMPTY) + !! - s- or mixed s-zps coordinate: vertical interpolation onto model mesh + !! - zps coordinate: vertical interpolation onto last partial level + !! - ln_uvd_dyndmp=False: deallocate the U & V current data structure, + !! as the data is no longer used + !! + !! ** Action : puvd, U & V current data interpolated onto model mesh at time-step kt + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pud ! U & V current data + REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pvd ! U & V current data + ! + INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies + INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers + REAL(wp):: zl, zi ! local floats + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zup, zvp ! 1D workspace + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dta_uvd') + ! + CALL fld_read( kt, 1, sf_uvd ) !== read U & V current data at time step kt ==! + ! + pud(:,:,:) = sf_uvd(1)%fnow(:,:,:) ! NO mask + pvd(:,:,:) = sf_uvd(2)%fnow(:,:,:) + ! + IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! + ! + ALLOCATE( zup(jpk), zvp(jpk) ) + ! + IF( kt == nit000 .AND. lwp )THEN + WRITE(numout,*) + WRITE(numout,*) 'dta_uvd: interpolate U & V current data onto the s- or mixed s-z-coordinate mesh' + ENDIF + ! + DO_2D( 1, 1, 1, 1 ) ! vertical interpolation of U & V current: + DO jk = 1, jpk + zl = gdept(ji,jj,jk,Kmm) + IF ( zl < gdept_1d(1 ) ) THEN ! extrapolate above the first level of data + zup(jk) = pud(ji,jj,1) + zvp(jk) = pvd(ji,jj,1) + ELSEIF( zl > gdept_1d(jpk) ) THEN ! extrapolate below the last level of data + zup(jk) = pud(ji,jj,jpkm1) + zvp(jk) = pvd(ji,jj,jpkm1) + ELSE ! inbetween : vertical interpolation between jkk & jkk+1 + DO jkk = 1, jpkm1 ! when dept(jkk) < zl < dept(jkk+1) + IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN + zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) + zup(jk) = pud(ji,jj,jkk) + ( pud(ji,jj,jkk+1) - pud(ji,jj,jkk) ) * zi + zvp(jk) = pvd(ji,jj,jkk) + ( pvd(ji,jj,jkk+1) - pvd(ji,jj,jkk) ) * zi + ENDIF + END DO + ENDIF + END DO + DO jk = 1, jpkm1 ! apply mask + pud(ji,jj,jk) = zup(jk) * umask(ji,jj,jk) + pvd(ji,jj,jk) = zvp(jk) * vmask(ji,jj,jk) + END DO + pud(ji,jj,jpk) = 0._wp + pvd(ji,jj,jpk) = 0._wp + END_2D + ! + DEALLOCATE( zup, zvp ) + ! + ELSE !== z- or zps- coordinate ==! + ! + pud(:,:,:) = pud(:,:,:) * umask(:,:,:) ! apply mask + pvd(:,:,:) = pvd(:,:,:) * vmask(:,:,:) + ! + IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level + DO_2D( 1, 1, 1, 1 ) + ik = mbkt(ji,jj) + IF( ik > 1 ) THEN + zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) + pud(ji,jj,ik) = (1.-zl) * pud(ji,jj,ik) + zl * pud(ji,jj,ik-1) + pvd(ji,jj,ik) = (1.-zl) * pvd(ji,jj,ik) + zl * pvd(ji,jj,ik-1) + ENDIF + END_2D + ENDIF + ! + ENDIF + ! + IF( .NOT. ln_uvd_dyndmp ) THEN !== deallocate U & V current structure ==! + ! !== (data used only for initialization) ==! + IF(lwp) WRITE(numout,*) 'dta_uvd: deallocate U & V current arrays as they are only used to initialize the run' + DEALLOCATE( sf_uvd(1)%fnow ) ! U current arrays in the structure + IF( sf_uvd(1)%ln_tint ) DEALLOCATE( sf_uvd(1)%fdta ) + DEALLOCATE( sf_uvd(2)%fnow ) ! V current arrays in the structure + IF( sf_uvd(2)%ln_tint ) DEALLOCATE( sf_uvd(2)%fdta ) + DEALLOCATE( sf_uvd ) ! the structure itself + ENDIF + ! + IF( ln_timing ) CALL timing_stop('dta_uvd') + ! + END SUBROUTINE dta_uvd + + !!====================================================================== +END MODULE dtauvd \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/C1D/dyndmp.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/C1D/dyndmp.F90 new file mode 100644 index 0000000..6abcf79 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/C1D/dyndmp.F90 @@ -0,0 +1,218 @@ +MODULE dyndmp + !!====================================================================== + !! *** MODULE dyndmp *** + !! Ocean dynamics: internal restoring trend on momentum (U and V current) + !! This should only be used for C1D case in current form + !!====================================================================== + !! History : 3.5 ! 2013-08 (D. Calvert) Original code + !! 3.6 ! 2014-08 (T. Graham) Modified to use netcdf file of + !! restoration coefficients supplied to tradmp + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_dmp_alloc : allocate dyndmp arrays + !! dyn_dmp_init : namelist read, parameter control and resto coeff. + !! dyn_dmp : update the momentum trend with the internal damping + !!---------------------------------------------------------------------- + USE oce ! ocean: variables + USE dom_oce ! ocean: domain variables + USE c1d ! 1D vertical configuration + USE tradmp ! ocean: internal damping + USE zdf_oce ! ocean: vertical physics + USE phycst ! physical constants + USE dtauvd ! data: U & V current + USE zdfmxl ! vertical physics: mixed layer depth + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE prtctl ! Print control + USE timing ! Timing + USE iom ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_dmp_init ! routine called by nemogcm.F90 + PUBLIC dyn_dmp ! routine called by step_c1d.F90 + + LOGICAL, PUBLIC :: ln_dyndmp !: Flag for Newtonian damping + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: utrdmp !: damping U current trend (m/s2) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vtrdmp !: damping V current trend (m/s2) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: resto_uv !: restoring coeff. on U & V current + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dyndmp.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION dyn_dmp_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION dyn_dmp_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( utrdmp(jpi,jpj,jpk), vtrdmp(jpi,jpj,jpk), resto_uv(jpi,jpj,jpk), STAT= dyn_dmp_alloc ) + ! + CALL mpp_sum ( 'dyndmp', dyn_dmp_alloc ) + IF( dyn_dmp_alloc > 0 ) CALL ctl_warn('dyn_dmp_alloc: allocation of arrays failed') + ! + END FUNCTION dyn_dmp_alloc + + + SUBROUTINE dyn_dmp_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_dmp_init *** + !! + !! ** Purpose : Initialization for the Newtonian damping + !! + !! ** Method : - read the ln_dyndmp parameter from the namc1d_dyndmp namelist + !! - allocate damping arrays + !! - check the parameters of the namtra_dmp namelist + !! - calculate damping coefficient + !!---------------------------------------------------------------------- + INTEGER :: ios, imask ! local integers + !! + NAMELIST/namc1d_dyndmp/ ln_dyndmp + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namc1d_dyndmp, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d_dyndmp in reference namelist' ) + READ ( numnam_cfg, namc1d_dyndmp, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namc1d_dyndmp in configuration namelist' ) + IF(lwm) WRITE ( numond, namc1d_dyndmp ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dyn_dmp_init : U and V current Newtonian damping' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namc1d_dyndmp : Set damping flag' + WRITE(numout,*) ' add a damping term or not ln_dyndmp = ', ln_dyndmp + WRITE(numout,*) ' Namelist namtra_dmp : Set damping parameters' + WRITE(numout,*) ' Apply relaxation or not ln_tradmp = ', ln_tradmp + WRITE(numout,*) ' mixed layer damping option nn_zdmp = ', nn_zdmp + WRITE(numout,*) ' Damping file name cn_resto = ', cn_resto + WRITE(numout,*) + ENDIF + ! + IF( ln_dyndmp ) THEN + ! !== allocate the data arrays ==! + IF( dyn_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dyn_dmp_init: unable to allocate arrays' ) + ! + SELECT CASE ( nn_zdmp ) !== control print of vertical option ==! + CASE ( 0 ) ; IF(lwp) WRITE(numout,*) ' momentum damping throughout the water column' + CASE ( 1 ) ; IF(lwp) WRITE(numout,*) ' no momentum damping in the turbocline (avt > 5 cm2/s)' + CASE ( 2 ) ; IF(lwp) WRITE(numout,*) ' no momentum damping in the mixed layer' + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for nn_zdmp = ', nn_zdmp + CALL ctl_stop(ctmp1) + END SELECT + ! + IF( .NOT. ln_uvd_dyndmp ) THEN ! force the initialization of U & V current data for damping + CALL ctl_warn( 'dyn_dmp_init: U & V current read data not initialized, we force ln_uvd_dyndmp=T' ) + CALL dta_uvd_init( ld_dyndmp=ln_dyndmp ) + ENDIF + ! + utrdmp(:,:,:) = 0._wp ! internal damping trends + vtrdmp(:,:,:) = 0._wp + ! + !Read in mask from file + CALL iom_open ( cn_resto, imask) + CALL iom_get ( imask, jpdom_auto, 'resto', resto) + CALL iom_close( imask ) + ENDIF + ! + END SUBROUTINE dyn_dmp_init + + + SUBROUTINE dyn_dmp( kt, Kbb, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_dmp *** + !! + !! ** Purpose : Compute the momentum trends due to a newtonian damping + !! of the ocean velocities towards the given data and add it to the + !! general momentum trends. + !! + !! ** Method : Compute Newtonian damping towards u_dta and v_dta + !! and add to the general momentum trends: + !! puu(Krhs) = puu(Krhs) + resto_uv * (u_dta - puu(Kbb)) + !! pvv(Krhs) = pvv(Krhs) + resto_uv * (v_dta - pvv(Kbb)) + !! The trend is computed either throughout the water column + !! (nn_zdmp=0), where the vertical mixing is weak (nn_zdmp=1) or + !! below the well mixed layer (nn_zdmp=2) + !! + !! ** Action : - (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) momentum trends updated with the damping trend + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zua, zva ! local scalars + REAL(dp), DIMENSION(jpi,jpj,jpk,2) :: zuv_dta ! Read in data + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'dyn_dmp' ) + ! + ! + ! !== read and interpolate U & V current data at kt ==! + CALL dta_uvd( kt, Kmm, zuv_dta(:,:,:,1), zuv_dta(:,:,:,2)) + ! + SELECT CASE ( nn_zdmp ) !== Calculate/add Newtonian damping to the momentum trend ==! + ! + CASE( 0 ) ! Newtonian damping throughout the water column + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - puu(ji,jj,jk,Kbb) ) + zva = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,2) - pvv(ji,jj,jk,Kbb) ) + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zua + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zva + utrdmp(ji,jj,jk) = zua ! save the trends + vtrdmp(ji,jj,jk) = zva + END_3D + ! + CASE ( 1 ) ! no damping above the turbocline (avt > 5 cm2/s) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + IF( avt(ji,jj,jk) <= avt_c ) THEN + zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - puu(ji,jj,jk,Kbb) ) + zva = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,2) - pvv(ji,jj,jk,Kbb) ) + ELSE + zua = 0._wp + zva = 0._wp + ENDIF + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zua + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zva + utrdmp(ji,jj,jk) = zua ! save the trends + vtrdmp(ji,jj,jk) = zva + END_3D + ! + CASE ( 2 ) ! no damping in the mixed layer + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + IF( gdept(ji,jj,jk,Kmm) >= hmlp (ji,jj) ) THEN + zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - puu(ji,jj,jk,Kbb) ) + zva = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,2) - pvv(ji,jj,jk,Kbb) ) + ELSE + zua = 0._wp + zva = 0._wp + ENDIF + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zua + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zva + utrdmp(ji,jj,jk) = zua ! save the trends + vtrdmp(ji,jj,jk) = zva + END_3D + ! + END SELECT + ! + ! ! Control print + IF( sn_cfctl%l_prtctl ) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' dmp - Ua: ', mask1=umask, & + & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + ! + IF( ln_timing ) CALL timing_stop( 'dyn_dmp') + ! + END SUBROUTINE dyn_dmp + + !!====================================================================== +END MODULE dyndmp \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/README.rst b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/README.rst new file mode 100644 index 0000000..8633dbe --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/README.rst @@ -0,0 +1,153 @@ +********************************** +On line biogeochemistry coarsening +********************************** + +.. todo:: + + + +.. contents:: + :local: + +Presentation +============ + +A capacity of coarsening physics to force a BGC model coupled to NEMO has been developed. +This capacity allow to run 'online' a BGC model coupled to OCE-SI3 with a lower resolution, +to reduce the CPU cost of the BGC model, while preserving the effective resolution of the dynamics. + +A presentation is available [attachment:crs_wiki_1.1.pdf​ here], where the methodology is presented. + +What is available and working for now in this version +===================================================== + +[To be completed] + +Description of the successful validation tests +============================================== + +[To be completed] + +What is not working yet with on line coarsening of biogeochemistry +================================================================== + +[To be completed] + +''should include precise explanation on MPI decomposition problems too'' + +How to set up and use on line biogeochemistry +============================================= + +Extract the on line biogeochemistry branch +------------------------------------------ + +To get the appropriate source code with the on line coarsening of biogeochemistry feature: + +.. code-block:: console + + $ svn co https://forge.ipsl.jussieu.fr/nemo/browser/NEMO/branches/2018/dev_r5003_MERCATOR6_CRS + + +How to activate coarsening? +--------------------------- + +To activate the coarsening, ``key_crs`` should be added to list of CPP keys. +This key will only activate the coarsening of dynamics. + +Some parameters are available in the namelist_cfg: + +.. code-block:: fortran + + ! passive tracer coarsened online simulations + !----------------------------------------------------------------------- + nn_factx = 3 ! Reduction factor of x-direction + nn_facty = 3 ! Reduction factor of y-direction + nn_msh_crs = 0 ! create (=1) a mesh file or not (=0) + nn_crs_kz = 3 ! 0, volume-weighted MEAN of KZ + ! 1, MAX of KZ + ! 2, MIN of KZ + ! 3, 10^(MEAN(LOG(KZ)) + ! 4, MEDIANE of KZ + ln_crs_wn = .false. ! wn coarsened (T) or computed using horizontal divergence ( F ) + ! ! + ln_crs_top = .true. !coarsening online for the bio + / + +- Only ``nn_factx = 3`` is available and the coarsening only works for grids with a T-pivot point for + the north-fold lateral boundary condition (ORCA025, ORCA12, ORCA36, ...). +- ``nn_msh_crs = 1`` will activate the generation of the coarsened grid meshmask. +- ``nn_crs_kz`` is the operator to coarsen the vertical mixing coefficient. +- ``ln_crs_wn`` + + - when ``key_vvl`` is activated, this logical has no effect; + the coarsened vertical velocities are computed using horizontal divergence. + - when ``key_vvl`` is not activated, + + - coarsened vertical velocities are computed using horizontal divergence (``ln_crs_wn = .false.``) + - or coarsened vertical velocities are computed with an average operator (``ln_crs_wn = .true.``) +- ``ln_crs_top = .true.``: should be activated to run BCG model in coarsened space; + so only works when ``key_top`` is in the cpp list and eventually ``key_pisces`` or ``key_my_trc``. + +Choice of operator to coarsene KZ +--------------------------------- + +A sensiblity test has been done with an Age tracer to compare the different operators. +The 3 and 4 options seems to provide the best results. + +Some results can be found [xxx here] + +Example of xml files to output coarsened variables with XIOS +------------------------------------------------------------ + +In the [attachment:iodef.xml iodef.xml] file, a "nemo" context is defined and +some variable defined in [attachment:file_def.xml file_def.xml] are writted on the ocean-dynamic grid. +To write variables on the coarsened grid, and in particular the passive tracers, +a "nemo_crs" context should be defined in [attachment:iodef.xml iodef.xml] and +the associated variable are listed in [attachment:file_crs_def.xml file_crs_def.xml ]. + +Passive tracers tracers initial conditions +------------------------------------------ + +When initial conditions are provided in NetCDF files, the field might be: + +- on the coarsened grid +- or they can be on another grid and + interpolated `on-the-fly `_. + Example of namelist for PISCES : + + .. code-block:: fortran + + !----------------------------------------------------------------------- + &namtrc_dta ! Initialisation from data input file + !----------------------------------------------------------------------- + ! + sn_trcdta(1) = 'DIC_REG1' , -12 , 'DIC' , .false. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + sn_trcdta(2) = 'ALK_REG1' , -12 , 'ALK' , .false. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + sn_trcdta(3) = 'O2_REG1' , -1 , 'O2' , .true. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + sn_trcdta(5) = 'PO4_REG1' , -1 , 'PO4' , .true. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + sn_trcdta(7) = 'Si_REG1' , -1 , 'Si' , .true. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + sn_trcdta(10) = 'DOC_REG1' , -12 , 'DOC' , .false. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + sn_trcdta(14) = 'Fe_REG1' , -12 , 'Fe' , .false. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + sn_trcdta(23) = 'NO3_REG1' , -1 , 'NO3' , .true. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + rn_trfac(1) = 1.0e-06 ! multiplicative factor + rn_trfac(2) = 1.0e-06 ! - - - - + rn_trfac(3) = 44.6e-06 ! - - - - + rn_trfac(5) = 122.0e-06 ! - - - - + rn_trfac(7) = 1.0e-06 ! - - - - + rn_trfac(10) = 1.0e-06 ! - - - - + rn_trfac(14) = 1.0e-06 ! - - - - + rn_trfac(23) = 7.6e-06 ! - - - - + + cn_dir = './' ! root directory for the location of the data files + +PISCES forcing files +-------------------- + +They might be on the coarsened grid. + +Perspectives +============ + +For the future, a few options are on the table to implement coarsening for biogeochemistry in 4.0 and +future releases. +Those will be discussed in Autumn 2018 diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crs.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crs.F90 new file mode 100644 index 0000000..5cfaf57 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crs.F90 @@ -0,0 +1,318 @@ +MODULE crs + !!====================================================================== + !! *** MODULE crs_dom *** + !! Declare the coarse grid domain and other public variables + !! then allocate them if needed. + !!====================================================================== + !! History 2012-06 Editing (J. Simeon, G. Madec, C. Ethe, C. Calone) Original code + !!---------------------------------------------------------------------- + USE par_oce + USE dom_oce + USE in_out_manager + + IMPLICIT NONE + PUBLIC + + PUBLIC crs_dom_alloc ! Called from crsini.F90 + PUBLIC crs_dom_alloc2 ! Called from crsini.F90 + PUBLIC dom_grid_glo + PUBLIC dom_grid_crs + + ! Domain variables + INTEGER :: jpiglo_crs , & !: 1st dimension of global coarse grid domain + jpjglo_crs !: 2nd dimension of global coarse grid domain + INTEGER :: jpi_crs , & !: 1st dimension of local coarse grid domain + jpj_crs !: 2nd dimension of local coarse grid domain + INTEGER :: jpi_full , & !: 1st dimension of local parent grid domain + jpj_full !: 2nd dimension of local parent grid domain + + INTEGER :: nistr , njstr + INTEGER :: niend , njend + + INTEGER :: jpi_crsm1, jpj_crsm1 !: loop indices + INTEGER :: jpiglo_crsm1, jpjglo_crsm1 !: loop indices +!!$ INTEGER :: nperio_full, nperio_crs !: jperio of parent and coarse grids +!!$ INTEGER :: npolj_full, npolj_crs !: north fold mark + INTEGER :: jpiglo_full, jpjglo_full !: jpiglo / jpjglo + INTEGER :: npiglo, npjglo !: jpjglo + INTEGER :: Nis0_full, Njs0_full !: starting indices of internal sub-domain on parent grid + INTEGER :: Nie0_full, Nje0_full !: ending indices of internal sub-domain on parent grid + INTEGER :: Nis0_crs , Njs0_crs !: starting indices of internal sub-domain on coarse grid + INTEGER :: Nie0_crs , Nje0_crs !: ending indices of internal sub-domain on coarse grid + + INTEGER :: narea_full, narea_crs !: node + INTEGER :: jpnij_full, jpnij_crs !: =jpni*jpnj, the pe decomposition +!!$ INTEGER :: jpim1_full, jpjm1_full !: + INTEGER :: nimpp_full, njmpp_full !: global position of point (1,1) of subdomain on parent grid + INTEGER :: nimpp_crs, njmpp_crs !: set to 1,1 for now . Valid only for monoproc + + INTEGER, DIMENSION(:), ALLOCATABLE :: mis_crs, mie_crs, mis2_crs, mie2_crs ! starting and ending i-indices of parent subset + INTEGER, DIMENSION(:), ALLOCATABLE :: mjs_crs, mje_crs, mjs2_crs, mje2_crs ! starting and ending j-indices of parent subset + INTEGER, DIMENSION(:), ALLOCATABLE :: mjg_crs, mig_crs + INTEGER, DIMENSION(:), ALLOCATABLE :: mi0_crs, mi1_crs, mj0_crs, mj1_crs + INTEGER :: mxbinctr, mybinctr ! central point in grid box +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: jpiall_crs, jpiall_full !: dimensions of every subdomain +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: nis0all_crs, nis0all_full !: first, last indoor index for each i-domain +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: nie0all_crs, nie0all_full !: first, last indoor index for each j-domain +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: nimppt_crs, nimppt_full !: first, last indoor index for each j-domain +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: jpjall_crs, jpjall_full !: dimensions of every subdomain +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: njs0all_crs, njs0all_full !: first, last indoor index for each i-domain +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: nje0all_crs, nje0all_full !: first, last indoor index for each j-domain +!!$ INTEGER, DIMENSION(:), ALLOCATABLE :: njmppt_crs, njmppt_full !: first, last indoor index for each j-domain + + + ! Masks + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_crs, umask_crs, vmask_crs, fmask_crs + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: rnfmsk_crs + + ! Scale factors + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1t_crs, e2t_crs, e1e2t_crs ! horizontal scale factors grid type T + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1u_crs, e2u_crs ! horizontal scale factors grid type U + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1v_crs, e2v_crs ! horizontal scale factors grid type V + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1f_crs, e2f_crs ! horizontal scale factors grid type F + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_crs, e3u_crs, e3v_crs, e3f_crs, e3w_crs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_max_crs, e3u_max_crs, e3v_max_crs, e3f_max_crs, e3w_max_crs + + ! Surface + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e1e2w_crs, e2e3u_crs, e1e3v_crs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e1e2w_msk, e2e3u_msk, e1e3v_msk + ! vertical scale factors + ! Coordinates + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphit_crs, glamt_crs, gphif_crs, glamf_crs + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphiu_crs, glamu_crs, gphiv_crs, glamv_crs + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ff_crs + INTEGER, DIMENSION(:,:), ALLOCATABLE :: mbathy_crs, mbkt_crs, mbku_crs, mbkv_crs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: gdept_crs, gdepu_crs, gdepv_crs, gdepw_crs + + ! Weights + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: facsurfv, facsurfu, facvol_t, facvol_w + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ocean_volume_crs_t, ocean_volume_crs_w, bt_crs, r1_bt_crs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: crs_surfu_wgt, crs_surfv_wgt, crs_surfw_wgt, crs_volt_wgt + + ! CRS Namelist + INTEGER :: nn_factx = 3 !: reduction factor of x-dimension of the parent grid + INTEGER :: nn_facty = 3 !: reduction factor of y-dimension of the parent grid + INTEGER :: nn_binref = 0 !: 0 = binning starts north fold (equator could be asymmetric) + !: 1 = binning centers at equator (north fold my have artifacts) + !: for even reduction factors, equator placed in bin biased south + LOGICAL :: ln_msh_crs = .TRUE. !: =T Create a meshmask file for CRS + INTEGER :: nn_crs_kz = 0 !: type of Kz coarsening ( =0->VOL ; =1->MAX ; =2->MIN) + LOGICAL :: ln_crs_wn = .FALSE. !: coarsening wn or computation using horizontal divergence + ! + INTEGER :: nrestx, nresty !: for determining odd or even reduction factor + + + ! Grid reduction factors + REAL(wp) :: rfactx_r !: inverse of x-dim reduction factor + REAL(wp) :: rfacty_r !: inverse of y-dim reduction factor + REAL(wp) :: rfactxy + + ! Physical and dynamical ocean fields for output or passing to TOP, time-mean fields + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tsn_crs + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: un_crs, vn_crs, wn_crs + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: hdivn_crs + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: sshn_crs + ! + ! Surface fluxes to pass to TOP + REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: qsr_crs, fr_i_crs, wndm_crs + REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: emp_crs, emp_b_crs, sfx_crs + REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: utau_crs, vtau_crs + REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: rnf_crs + + ! Vertical diffusion + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avt_crs !: temperature vertical diffusivity coeff. [m2/s] at w-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avs_crs !: salinity vertical diffusivity coeff. [m2/s] at w-point + + ! Mixing and Mixed Layer Depth + INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: nmln_crs, hmld_crs, hmlp_crs, hmlpt_crs + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: crs.F90 15033 2021-06-21 10:24:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION crs_dom_alloc() + !!------------------------------------------------------------------- + !! *** FUNCTION crs_dom_alloc *** + !! ** Purpose : Allocate public crs arrays + !!------------------------------------------------------------------- + !! Local variables + INTEGER, DIMENSION(17) :: ierr + + ierr(:) = 0 + + ! Set up bins for coarse grid, horizontal only. + ALLOCATE( mis2_crs(jpiglo_crs), mie2_crs(jpiglo_crs), & + & mjs2_crs(jpjglo_crs), mje2_crs(jpjglo_crs), & + & mi0_crs (jpiglo_crs), mi1_crs (jpiglo_crs), & + & mj0_crs (jpjglo_crs), mj1_crs (jpjglo_crs), & + & mig_crs (jpi_crs) , mjg_crs (jpj_crs) , STAT=ierr(1) ) + + + ! Set up Mask and Mesh + ALLOCATE( tmask_crs(jpi_crs,jpj_crs,jpk) , fmask_crs(jpi_crs,jpj_crs,jpk) , & + & umask_crs(jpi_crs,jpj_crs,jpk) , vmask_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(2)) + + ALLOCATE( rnfmsk_crs(jpi_crs,jpj_crs), STAT=ierr(3) ) + + ALLOCATE( gphit_crs(jpi_crs,jpj_crs) , glamt_crs(jpi_crs,jpj_crs) , & + & gphiu_crs(jpi_crs,jpj_crs) , glamu_crs(jpi_crs,jpj_crs) , & + & gphiv_crs(jpi_crs,jpj_crs) , glamv_crs(jpi_crs,jpj_crs) , & + & gphif_crs(jpi_crs,jpj_crs) , glamf_crs(jpi_crs,jpj_crs) , & + & ff_crs(jpi_crs,jpj_crs) , STAT=ierr(4)) + + ALLOCATE( e1t_crs(jpi_crs,jpj_crs) , e2t_crs(jpi_crs,jpj_crs) , & + & e1u_crs(jpi_crs,jpj_crs) , e2u_crs(jpi_crs,jpj_crs) , & + & e1v_crs(jpi_crs,jpj_crs) , e2v_crs(jpi_crs,jpj_crs) , & + & e1f_crs(jpi_crs,jpj_crs) , e2f_crs(jpi_crs,jpj_crs) , & + & e1e2t_crs(jpi_crs,jpj_crs), STAT=ierr(5)) + + ALLOCATE( e3t_crs(jpi_crs,jpj_crs,jpk) , e3w_crs(jpi_crs,jpj_crs,jpk) , & + & e3u_crs(jpi_crs,jpj_crs,jpk) , e3v_crs(jpi_crs,jpj_crs,jpk) , & + & e3f_crs(jpi_crs,jpj_crs,jpk) , e1e2w_msk(jpi_crs,jpj_crs,jpk) , & + & e2e3u_msk(jpi_crs,jpj_crs,jpk) , e1e3v_msk(jpi_crs,jpj_crs,jpk) , & + & e1e2w_crs(jpi_crs,jpj_crs,jpk) , e2e3u_crs(jpi_crs,jpj_crs,jpk) , & + & e1e3v_crs(jpi_crs,jpj_crs,jpk) , e3t_max_crs(jpi_crs,jpj_crs,jpk), & + & e3w_max_crs(jpi_crs,jpj_crs,jpk), e3u_max_crs(jpi_crs,jpj_crs,jpk), & + & e3v_max_crs(jpi_crs,jpj_crs,jpk), STAT=ierr(6)) + + + ALLOCATE( facsurfv(jpi_crs,jpj_crs,jpk), facsurfu(jpi_crs,jpj_crs,jpk) , & + & facvol_t(jpi_crs,jpj_crs,jpk), facvol_w(jpi_crs,jpj_crs,jpk) , & + & ocean_volume_crs_t(jpi_crs,jpj_crs,jpk), ocean_volume_crs_w(jpi_crs,jpj_crs,jpk), & + & bt_crs(jpi_crs,jpj_crs,jpk) , r1_bt_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(7)) + + + ALLOCATE( crs_surfu_wgt(jpi_crs,jpj_crs,jpk), crs_surfv_wgt(jpi_crs,jpj_crs,jpk) , & + & crs_surfw_wgt(jpi_crs,jpj_crs,jpk), crs_volt_wgt(jpi_crs,jpj_crs,jpk) , STAT=ierr(8)) + + + ALLOCATE( mbathy_crs(jpi_crs,jpj_crs), mbkt_crs(jpi_crs,jpj_crs) , & + & mbku_crs(jpi_crs,jpj_crs) , mbkv_crs(jpi_crs,jpj_crs) , STAT=ierr(9)) + + ALLOCATE( gdept_crs(jpi_crs,jpj_crs,jpk), gdepu_crs(jpi_crs,jpj_crs,jpk) , & + & gdepv_crs(jpi_crs,jpj_crs,jpk), gdepw_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(10) ) + + + ALLOCATE( un_crs(jpi_crs,jpj_crs,jpk) , vn_crs (jpi_crs,jpj_crs,jpk) , & + & wn_crs(jpi_crs,jpj_crs,jpk) , hdivn_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(11)) + + ALLOCATE( sshn_crs(jpi_crs,jpj_crs), emp_crs (jpi_crs,jpj_crs), emp_b_crs(jpi_crs,jpj_crs), & + & qsr_crs(jpi_crs ,jpj_crs), wndm_crs(jpi_crs,jpj_crs), utau_crs(jpi_crs,jpj_crs) , & + & vtau_crs(jpi_crs,jpj_crs), rnf_crs(jpi_crs ,jpj_crs), & + & fr_i_crs(jpi_crs,jpj_crs), sfx_crs(jpi_crs ,jpj_crs), STAT=ierr(12) ) + + ALLOCATE( tsn_crs(jpi_crs,jpj_crs,jpk,jpts), avt_crs(jpi_crs,jpj_crs,jpk), & + & avs_crs(jpi_crs,jpj_crs,jpk), STAT=ierr(13) ) + + ALLOCATE( nmln_crs(jpi_crs,jpj_crs) , hmld_crs(jpi_crs,jpj_crs) , & + & hmlp_crs(jpi_crs,jpj_crs) , hmlpt_crs(jpi_crs,jpj_crs) , STAT=ierr(14) ) + +!!$ ALLOCATE( nimppt_crs (jpnij) , jpiall_crs (jpnij) , nis0all_crs (jpnij) , nie0all_crs (jpnij), & +!!$ & nimppt_full(jpnij) , jpiall_full(jpnij) , nis0all_full(jpnij) , nie0all_full(jpnij), & +!!$ njmppt_crs (jpnij) , jpjall_crs (jpnij) , njs0all_crs (jpnij) , nje0all_crs (jpnij), & +!!$ & njmppt_full(jpnij) , jpjall_full(jpnij) , njs0all_full(jpnij) , nje0all_full(jpnij) , STAT=ierr(15) ) + + crs_dom_alloc = MAXVAL(ierr) + ! + END FUNCTION crs_dom_alloc + + + INTEGER FUNCTION crs_dom_alloc2() + !!------------------------------------------------------------------- + !! *** FUNCTION crs_dom_alloc *** + !! ** Purpose : Allocate public crs arrays + !!------------------------------------------------------------------- + !! Local variables + INTEGER, DIMENSION(1) :: ierr + + ierr(:) = 0 + + ALLOCATE( mjs_crs(Nje0_crs) , mje_crs(Nje0_crs), mis_crs(Nie0_crs) , mie_crs(Nie0_crs), STAT=ierr(1) ) + crs_dom_alloc2 = MAXVAL(ierr) + + END FUNCTION crs_dom_alloc2 + + + SUBROUTINE dom_grid_glo + !!-------------------------------------------------------------------- + !! *** MODULE dom_grid_glo *** + !! + !! ** Purpose : +Return back to parent grid domain + !!--------------------------------------------------------------------- + + ! Return to parent grid domain + jpi = jpi_full + jpj = jpj_full +!!$ jpim1 = jpim1_full +!!$ jpjm1 = jpjm1_full +!!$ jperio = nperio_full + +!!$ npolj = npolj_full + jpiglo = jpiglo_full + jpjglo = jpjglo_full + + jpi = jpi_full + jpj = jpj_full + Nis0 = Nis0_full + Njs0 = Njs0_full + Nie0 = Nie0_full + Nje0 = Nje0_full + nimpp = nimpp_full + njmpp = njmpp_full + +!!$ jpiall (:) = jpiall_full (:) +!!$ nis0all(:) = nis0all_full(:) +!!$ nie0all(:) = nie0all_full(:) +!!$ nimppt (:) = nimppt_full (:) +!!$ jpjall (:) = jpjall_full (:) +!!$ njs0all(:) = njs0all_full(:) +!!$ nje0all(:) = nje0all_full(:) +!!$ njmppt (:) = njmppt_full (:) + + END SUBROUTINE dom_grid_glo + + + SUBROUTINE dom_grid_crs + !!-------------------------------------------------------------------- + !! *** MODULE dom_grid_crs *** + !! + !! ** Purpose : Save the parent grid information & Switch to coarse grid domain + !!--------------------------------------------------------------------- + ! + ! Switch to coarse grid domain + jpi = jpi_crs + jpj = jpj_crs +!!$ jpim1 = jpi_crsm1 +!!$ jpjm1 = jpj_crsm1 +!!$ jperio = nperio_crs + +!!$ npolj = npolj_crs + jpiglo = jpiglo_crs + jpjglo = jpjglo_crs + + + jpi = jpi_crs + jpj = jpj_crs + Nis0 = Nis0_crs + Nie0 = Nie0_crs + Nje0 = Nje0_crs + Njs0 = Njs0_crs + nimpp = nimpp_crs + njmpp = njmpp_crs + +!!$ jpiall (:) = jpiall_crs (:) +!!$ nis0all(:) = nis0all_crs(:) +!!$ nie0all(:) = nie0all_crs(:) +!!$ nimppt (:) = nimppt_crs (:) +!!$ jpjall (:) = jpjall_crs (:) +!!$ njs0all(:) = njs0all_crs(:) +!!$ nje0all(:) = nje0all_crs(:) +!!$ njmppt (:) = njmppt_crs (:) + ! + END SUBROUTINE dom_grid_crs + + !!====================================================================== +END MODULE crs \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsdom.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsdom.F90 new file mode 100644 index 0000000..c4c47aa --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsdom.F90 @@ -0,0 +1,2270 @@ +MODULE crsdom + !!=================================================================== + !! *** crs.F90 *** + !! Purpose: Interface for calculating quantities from a + !! higher-resolution grid for the coarse grid. + !! + !! Method: Given the user-defined reduction factor, + !! the averaging bins are set: + !! - nn_binref = 0, starting from the north + !! to the south in the model interior domain, + !! in this way the north fold and redundant halo cells + !! could be handled in a consistent manner and + !! the irregularities of bin size can be handled + !! more naturally by the presence of land + !! in the southern boundary. Thus the southernmost bin + !! could be of an irregular bin size. + !! Information on the parent grid is retained, specifically, + !! each coarse grid cell's volume and ocean surface + !! at the faces, relative to the parent grid. + !! - nn_binref = 1 (not yet available), starting + !! at a centralized bin at the equator, being only + !! truly centered for odd-numbered j-direction reduction + !! factors. + !! References: Aumont, O., J.C. Orr, D. Jamous, P. Monfray + !! O. Marti and G. Madec, 1998. A degradation + !! approach to accelerate simulations to steady-state + !! in a 3-D tracer transport model of the global ocean. + !! Climate Dynamics, 14:101-116. + !! History: + !! Original. May 2012. (J. Simeon, C. Calone, G. Madec, C. Ethe) + !!=================================================================== + USE dom_oce ! ocean space and time domain + USE crs ! domain for coarse grid + ! + USE in_out_manager + USE par_kind + USE crslbclnk + USE lib_mpp + + IMPLICIT NONE + + PRIVATE + + PUBLIC crs_dom_ope + PUBLIC crs_dom_e3, crs_dom_sfc, crs_dom_msk, crs_dom_hgr, crs_dom_coordinates + PUBLIC crs_dom_facvol, crs_dom_def, crs_dom_bat + + INTERFACE crs_dom_ope + MODULE PROCEDURE crs_dom_ope_3d, crs_dom_ope_2d + END INTERFACE + + REAL(wp) :: r_inf = 1e+36 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: crsdom.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_dom_msk + + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijie,ijis,ijje,ijjs,ij,je_2 + REAL(wp) :: zmask + + ! Initialize + + tmask_crs(:,:,:) = 0.0 + vmask_crs(:,:,:) = 0.0 + umask_crs(:,:,:) = 0.0 + fmask_crs(:,:,:) = 0.0 + + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) ; ij = je_2 + ENDIF + ELSE + je_2 = mje_crs(2) ; ij = mjs_crs(2) + ENDIF + DO jk = 1, jpkm1 + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) ; ijie = mie_crs(ji) + ! + zmask = 0.0 + zmask = SUM( tmask(ijis:ijie,ij:je_2,jk) ) + IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0_wp + + zmask = 0.0 + zmask = SUM( vmask(ijis:ijie,je_2 ,jk) ) + IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0_wp + + zmask = 0.0 + zmask = SUM(umask(ijie,ij:je_2,jk)) + IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0_wp + + fmask_crs(ji,je_2,jk) = fmask(ijie,2,jk) + ENDDO + ENDDO + ! + DO jk = 1, jpkm1 + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) ; ijie = mie_crs(ji) + DO jj = 3, Nje0_crs + ijjs = mjs_crs(jj) ; ijje = mje_crs(jj) + + zmask = 0.0 + zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) ) + IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0_wp + + zmask = 0.0 + zmask = SUM( vmask(ijis:ijie,ijje ,jk) ) + IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0_wp + + zmask = 0.0 + zmask = SUM( umask(ijie ,ijjs:ijje,jk) ) + IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0_wp + + fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk) + ENDDO + ENDDO + ENDDO + + ! + CALL crs_lbc_lnk( tmask_crs, 'T', 1.0_wp ) + CALL crs_lbc_lnk( vmask_crs, 'V', 1.0_wp ) + CALL crs_lbc_lnk( umask_crs, 'U', 1.0_wp ) + CALL crs_lbc_lnk( fmask_crs, 'F', 1.0_wp ) + ! + END SUBROUTINE crs_dom_msk + + + SUBROUTINE crs_dom_coordinates( p_gphi, p_glam, cd_type, p_gphi_crs, p_glam_crs ) + !!---------------------------------------------------------------- + !! *** SUBROUTINE crs_coordinates *** + !! ** Purpose : Determine the coordinates for the coarse grid + !! + !! ** Method : From the parent grid subset, search for the central + !! point. For an odd-numbered reduction factor, + !! the coordinate will be that of the central T-cell. + !! For an even-numbered reduction factor, of a non-square + !! coarse grid box, the coordinate will be that of + !! the east or north face or more likely. For a square + !! coarse grid box, the coordinate will be that of + !! the central f-corner. + !! + !! ** Input : p_gphi = parent grid gphi[t|u|v|f] + !! p_glam = parent grid glam[t|u|v|f] + !! cd_type = grid type (T,U,V,F) + !! ** Output : p_gphi_crs = coarse grid gphi[t|u|v|f] + !! p_glam_crs = coarse grid glam[t|u|v|f] + !! + !! History. 1 Jun. + !!---------------------------------------------------------------- + !! Arguments + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_gphi ! Parent grid latitude + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_glam ! Parent grid longitude + CHARACTER(len=1), INTENT(in) :: cd_type ! grid type (T,U,V,F) + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_gphi_crs ! Coarse grid latitude + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_glam_crs ! Coarse grid longitude + + !! Local variables + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijis, ijjs + + + SELECT CASE ( cd_type ) + CASE ( 'T' ) + DO jj = Njs0_crs, Nje0_crs + ijjs = mjs_crs(jj) + mybinctr + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) + mxbinctr + p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) + p_glam_crs(ji,jj) = p_glam(ijis,ijjs) + ENDDO + ENDDO + CASE ( 'U' ) + DO jj = Njs0_crs, Nje0_crs + ijjs = mjs_crs(jj) + mybinctr + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) + p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) + p_glam_crs(ji,jj) = p_glam(ijis,ijjs) + ENDDO + ENDDO + CASE ( 'V' ) + DO jj = Njs0_crs, Nje0_crs + ijjs = mjs_crs(jj) + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) + mxbinctr + p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) + p_glam_crs(ji,jj) = p_glam(ijis,ijjs) + ENDDO + ENDDO + CASE ( 'F' ) + DO jj = Njs0_crs, Nje0_crs + ijjs = mjs_crs(jj) + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) + p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) + p_glam_crs(ji,jj) = p_glam(ijis,ijjs) + ENDDO + ENDDO + END SELECT + + ! Retroactively add back the boundary halo cells. + CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0_wp ) + CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0_wp ) + + ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd + SELECT CASE ( cd_type ) + CASE ( 'T', 'V' ) + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) + mxbinctr + p_gphi_crs(ji,1) = p_gphi(ijis,1) + p_glam_crs(ji,1) = p_glam(ijis,1) + ENDDO + CASE ( 'U', 'F' ) + DO ji = 2, Nie0_crs + ijis = mis_crs(ji) + p_gphi_crs(ji,1) = p_gphi(ijis,1) + p_glam_crs(ji,1) = p_glam(ijis,1) + ENDDO + END SELECT + ! + END SUBROUTINE crs_dom_coordinates + + SUBROUTINE crs_dom_hgr( p_e1, p_e2, cd_type, p_e1_crs, p_e2_crs ) + !!---------------------------------------------------------------- + !! *** SUBROUTINE crs_dom_hgr *** + !! + !! ** Purpose : Get coarse grid horizontal scale factors and unmasked fraction + !! + !! ** Method : For grid types T,U,V,Fthe 2D scale factors of + !! the coarse grid are the sum of the east or north faces of the + !! parent grid subset comprising the coarse grid box. + !! - e1,e2 Scale factors + !! Valid arguments: + !! ** Inputs : p_e1, p_e2 = parent grid e1 or e2 (t,u,v,f) + !! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V) + !! ** Outputs : p_e1_crs, p_e2_crs = parent grid e1 or e2 (t,u,v,f) + !! + !! History. 4 Jun. Write for WGT and scale factors only + !!---------------------------------------------------------------- + !! + !! Arguments + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1 ! Parent grid U,V scale factors (e1) + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e2 ! Parent grid U,V scale factors (e2) + CHARACTER(len=1) , INTENT(in) :: cd_type ! grid type U,V + + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e1_crs ! Coarse grid box 2D quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e2_crs ! Coarse grid box 2D quantity + + !! Local variables + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijie,ijje,ijrs + + !!---------------------------------------------------------------- + ! Initialize + + DO jk = 1, jpk + DO ji = 2, Nie0_crs + ijie = mie_crs(ji) + DO jj = Njs0_crs, Nje0_crs + ijje = mje_crs(jj) ; ijrs = mje_crs(jj) - mjs_crs(jj) + ! Only for a factro 3 coarsening + SELECT CASE ( cd_type ) + CASE ( 'T' ) + IF( ijrs == 0 .OR. ijrs == 1 ) THEN + ! Si à la frontière sud on a pas assez de maille de la grille mère + p_e1_crs(ji,jj) = p_e1(ijie-1,ijje) * nn_factx + p_e2_crs(ji,jj) = p_e2(ijie-1,ijje) * nn_facty + ELSE + p_e1_crs(ji,jj) = p_e1(ijie-1,ijje-1) * nn_factx + p_e2_crs(ji,jj) = p_e2(ijie-1,ijje-1) * nn_facty + ENDIF + CASE ( 'U' ) + IF( ijrs == 0 .OR. ijrs == 1 ) THEN + ! Si à la frontière sud on a pas assez de maille de la grille mère + p_e1_crs(ji,jj) = p_e1(ijie,ijje) * nn_factx + p_e2_crs(ji,jj) = p_e2(ijie,ijje) * nn_facty + ELSE + p_e1_crs(ji,jj) = p_e1(ijie,ijje-1) * nn_factx + p_e2_crs(ji,jj) = p_e2(ijie,ijje-1) * nn_facty + ENDIF + CASE ( 'V' ) + p_e1_crs(ji,jj) = p_e1(ijie-1,ijje) * nn_factx + p_e2_crs(ji,jj) = p_e2(ijie-1,ijje) * nn_facty + CASE ( 'F' ) + p_e1_crs(ji,jj) = p_e1(ijie,ijje) * nn_factx + p_e2_crs(ji,jj) = p_e2(ijie,ijje) * nn_facty + END SELECT + ENDDO + ENDDO + ENDDO + + CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) + CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) + + END SUBROUTINE crs_dom_hgr + + + SUBROUTINE crs_dom_facvol( p_mask, cd_type, p_e1, p_e2, p_e3, p_fld1_crs, p_fld2_crs ) + !!---------------------------------------------------------------- + !! *** SUBROUTINE crsfun_wgt *** + !! ** Purpose : Three applications. + !! 1) SUM. Get coarse grid horizontal scale factors and unmasked fraction + !! 2) VOL. Get coarse grid box volumes + !! 3) WGT. Weighting multiplier for volume-weighted and/or + !! area-weighted averages. + !! Weights (i.e. the denominator) calculated here + !! to avoid IF-tests and division. + !! ** Method : 1) SUM. For grid types T,U,V,F (and W) the 2D scale factors of + !! the coarse grid are the sum of the east or north faces of the + !! parent grid subset comprising the coarse grid box. + !! The fractions of masked:total surface (3D) on the east, + !! north and top faces is, optionally, also output. + !! - Top face area sum + !! Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2 + !! - Top face ocean surface fraction + !! Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2 + !! - e1,e2 Scale factors + !! Valid arguments: + !! 2) VOL. For grid types W and T, the coarse grid box + !! volumes are output. Also optionally, the fraction of + !! masked:total volume of the parent grid subset is output (i.e. facvol). + !! 3) WGT. Based on the grid type, the denominator is pre-determined here to + !! perform area- or volume- weighted averages, + !! to avoid IF-tests and divisions. + !! ** Inputs : p_e1, p_e2 = parent grid e1 or e2 (t,u,v,f) + !! p_pmask = parent grid mask (T,U,V,F) + !! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V) + !! cd_op = applied operation (SUM, VOL, WGT) + !! p_e3 = (Optional) parent grid vertical level thickness (e3u or e3v) + !! ** Outputs : p_cfield2d_1 = (Optional) 2D field on coarse grid + !! p_cfield2d_2 = (Optional) 2D field on coarse grid + !! p_cfield3d_1 = (Optional) 3D field on coarse grid + !! p_cfield3d_2 = (Optional) 3D field on coarse grid + !! + !! History. 4 Jun. Write for WGT and scale factors only + !!---------------------------------------------------------------- + CHARACTER(len=1), INTENT(in ) :: cd_type ! grid type U,V + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: p_mask ! Parent grid U,V mask + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: p_e1 ! Parent grid U,V scale factors (e1) + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ) :: p_e2 ! Parent grid U,V scale factors (e2) + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld1_crs ! Coarse grid box 3D quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld2_crs ! Coarse grid box 3D quantity + ! + INTEGER :: ji, jj, jk , ii, ij, je_2 + REAL(wp) :: zdAm + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvol, zmask + !!---------------------------------------------------------------- + ! + ! + p_fld1_crs(:,:,:) = 0._wp + p_fld2_crs(:,:,:) = 0._wp + + DO jk = 1, jpk + zvol(:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) + END DO + + zmask(:,:,:) = 0._wp + IF( cd_type == 'W' ) THEN + zmask(:,:,1) = p_mask(:,:,1) + DO jk = 2, jpk + zmask(:,:,jk) = p_mask(:,:,jk-1) + ENDDO + ELSE + DO jk = 1, jpk + zmask(:,:,jk) = p_mask(:,:,jk) + ENDDO + ENDIF + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + p_fld1_crs(ii,2,jk) = zvol(ji,je_2 ,jk) + zvol(ji+1,je_2 ,jk) + zvol(ji+2,je_2 ,jk) & + & + zvol(ji,je_2-1,jk) + zvol(ji+1,je_2-1,jk) + zvol(ji+2,je_2-1,jk) + ! + zdAm = zvol(ji ,je_2,jk) * zmask(ji ,je_2,jk) & + & + zvol(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) & + & + zvol(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) + ! + p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk) + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + p_fld1_crs(ii,2,jk) = zvol(ji,je_2 ,jk) + zvol(ji+1,je_2 ,jk) + zvol(ji+2,je_2 ,jk) & + & + zvol(ji,je_2+1,jk) + zvol(ji+1,je_2+1,jk) + zvol(ji+2,je_2+1,jk) & + & + zvol(ji,je_2+2,jk) + zvol(ji+1,je_2+2,jk) + zvol(ji+2,je_2+2,jk) + ! + zdAm = zvol(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) & + & + zvol(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) & + & + zvol(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) & + & + zvol(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) & + & + zvol(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) & + & + zvol(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) & + & + zvol(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) & + & + zvol(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) & + & + zvol(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) + ! + p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk) + ENDDO + ENDDO + ENDIF + + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + ! + p_fld1_crs(ii,ij,jk) = zvol(ji,jj ,jk) + zvol(ji+1,jj ,jk) + zvol(ji+2,jj ,jk) & + & + zvol(ji,jj+1,jk) + zvol(ji+1,jj+1,jk) + zvol(ji+2,jj+1,jk) & + & + zvol(ji,jj+2,jk) + zvol(ji+1,jj+2,jk) + zvol(ji+2,jj+2,jk) + ! + zdAm = zvol(ji ,jj ,jk) * zmask(ji ,jj ,jk) & + & + zvol(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) & + & + zvol(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) & + & + zvol(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) & + & + zvol(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) & + & + zvol(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) & + & + zvol(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) & + & + zvol(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) & + & + zvol(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) + ! + p_fld2_crs(ii,ij,jk) = zdAm / p_fld1_crs(ii,ij,jk) + ENDDO + ENDDO + ENDDO + ! ! Retroactively add back the boundary halo cells. + CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0_wp ) + CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0_wp ) + ! + ! + END SUBROUTINE crs_dom_facvol + + + SUBROUTINE crs_dom_ope_3d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs, psgn ) + !!---------------------------------------------------------------- + !! *** SUBROUTINE crsfun_UV *** + !! ** Purpose : Average, area-weighted, of U or V on the east and north faces + !! + !! ** Method : The U and V velocities (3D) are determined as the area-weighted averages + !! on the east and north faces, respectively, + !! of the parent grid subset comprising the coarse grid box. + !! In the case of the V and F grid, the last jrow minus 1 is spurious. + !! ** Inputs : p_e1_e2 = parent grid e1 or e2 (t,u,v,f) + !! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V) + !! psgn = sign change over north fold (See lbclnk.F90) + !! p_pmask = parent grid mask (T,U,V,F) for scale factors; + !! for velocities (U or V) + !! p_e3 = parent grid vertical level thickness (e3u or e3v) + !! p_pfield = U or V on the parent grid + !! p_surf_crs = (Optional) Coarse grid weight for averaging + !! ** Outputs : p_cfield3d = 3D field on coarse grid + !! + !! History. 29 May. completed draft. + !! 4 Jun. Revision for WGT + !! 5 Jun. Streamline for area-weighted average only ; separate scale factor and weights. + !!---------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_fld ! T, U, V or W on parent grid + CHARACTER(len=3), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN + CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask + REAL(dp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2) + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V maska + REAL(wp), INTENT(in) :: psgn ! sign + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld_crs ! Coarse grid box 3D quantity + ! + INTEGER :: ji, jj, jk + INTEGER :: ii, ij, ijie, ijje, je_2 + REAL(wp) :: zflcrs, zsfcrs + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zsurf, zsurfmsk, zmask + !!---------------------------------------------------------------- + ! + p_fld_crs(:,:,:) = 0._wp + ! + SELECT CASE ( cd_op ) + ! + CASE ( 'VOL' ) + ! + ALLOCATE( zsurf(jpi,jpj,jpk), zsurfmsk(jpi,jpj,jpk) ) + ! + SELECT CASE ( cd_type ) + ! + CASE( 'T', 'W' ) + IF( cd_type == 'T' ) THEN + DO jk = 1, jpk + zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) + zsurfmsk(:,:,jk) = zsurf(:,:,jk) + ENDDO + ELSE + zsurf (:,:,1) = p_e12(:,:) * p_e3(:,:,1) + zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) + DO jk = 2, jpk + zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) + ENDDO + ENDIF + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2,jk) * zsurfmsk(ji ,je_2,jk) & + & + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk) & + & + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) + + zsfcrs = zsurf(ji,je_2,jk) + zsurf(ji+1,je_2,jk) + zsurf(ji+2,je_2,jk) + ! + p_fld_crs(ii,2,jk) = zflcrs + IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2,jk) = zflcrs / zsfcrs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2 ,jk) * zsurfmsk(ji ,je_2 ,jk) & + & + p_fld(ji+1,je_2 ,jk) * zsurfmsk(ji+1,je_2 ,jk) & + & + p_fld(ji+2,je_2 ,jk) * zsurfmsk(ji+2,je_2 ,jk) & + & + p_fld(ji ,je_2+1,jk) * zsurfmsk(ji ,je_2+1,jk) & + & + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) & + & + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) & + & + p_fld(ji ,je_2+2,jk) * zsurfmsk(ji ,je_2+2,jk) & + & + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) & + & + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) + + zsfcrs = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) & + & + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) & + & + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) + ! + p_fld_crs(ii,2,jk) = zflcrs + IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2,jk) = zflcrs / zsfcrs + ENDDO + ENDDO + ENDIF + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = p_fld(ji ,jj ,jk) * zsurfmsk(ji ,jj ,jk) & + & + p_fld(ji+1,jj ,jk) * zsurfmsk(ji+1,jj ,jk) & + & + p_fld(ji+2,jj ,jk) * zsurfmsk(ji+2,jj ,jk) & + & + p_fld(ji ,jj+1,jk) * zsurfmsk(ji ,jj+1,jk) & + & + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) & + & + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) & + & + p_fld(ji ,jj+2,jk) * zsurfmsk(ji ,jj+2,jk) & + & + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) & + & + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) + + zsfcrs = zsurf(ji,jj ,jk) + zsurf(ji+1,jj ,jk) + zsurf(ji+2,jj ,jk) & + & + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) & + & + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) + ! + p_fld_crs(ii,ij,jk) = zflcrs + IF( zsfcrs /= 0.0 ) p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs + ENDDO + ENDDO + ENDDO + CASE DEFAULT + CALL ctl_stop( 'STOP', 'error from crs_dom_ope_3d, you should not be there...' ) + END SELECT + + DEALLOCATE( zsurf, zsurfmsk ) + + CASE ( 'SUM' ) + + ALLOCATE( zsurfmsk(jpi,jpj,jpk) ) + + SELECT CASE ( cd_type ) + CASE( 'W' ) + IF( PRESENT( p_e3 ) ) THEN + zsurfmsk(:,:,1) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) + DO jk = 2, jpk + zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk-1) + ENDDO + ELSE + zsurfmsk(:,:,1) = p_e12(:,:) * p_mask(:,:,1) + DO jk = 2, jpk + zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk-1) + ENDDO + ENDIF + CASE DEFAULT + IF( PRESENT( p_e3 ) ) THEN + DO jk = 1, jpk + zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) + ENDDO + ELSE + DO jk = 1, jpk + zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk) + ENDDO + ENDIF + END SELECT + + SELECT CASE ( cd_type ) + + CASE( 'T', 'W' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2,jk) * zsurfmsk(ji ,je_2,jk) & + & + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk) & + & + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2 ,jk) * zsurfmsk(ji ,je_2 ,jk) & + & + p_fld(ji+1,je_2 ,jk) * zsurfmsk(ji+1,je_2 ,jk) & + & + p_fld(ji+2,je_2 ,jk) * zsurfmsk(ji+2,je_2 ,jk) & + & + p_fld(ji ,je_2+1,jk) * zsurfmsk(ji ,je_2+1,jk) & + & + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) & + & + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) & + & + p_fld(ji ,je_2+2,jk) * zsurfmsk(ji ,je_2+2,jk) & + & + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) & + & + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = p_fld(ji ,jj ,jk) * zsurfmsk(ji ,jj ,jk) & + & + p_fld(ji+1,jj ,jk) * zsurfmsk(ji+1,jj ,jk) & + & + p_fld(ji+2,jj ,jk) * zsurfmsk(ji+2,jj ,jk) & + & + p_fld(ji ,jj+1,jk) * zsurfmsk(ji ,jj+1,jk) & + & + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) & + & + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) & + & + p_fld(ji ,jj+2,jk) * zsurfmsk(ji ,jj+2,jk) & + & + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) & + & + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + CASE( 'V' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + ijje = mje_crs(2) + ENDIF + ELSE + ijje = mjs_crs(2) + ENDIF + ! + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,ijje,jk) * zsurfmsk(ji ,ijje,jk) & + & + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) & + & + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + ijje = mje_crs(ij) + zflcrs = p_fld(ji ,ijje,jk) * zsurfmsk(ji ,ijje,jk) & + & + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) & + & + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + CASE( 'U' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2,jk) * zsurfmsk(ijie,je_2,jk) + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2 ,jk) * zsurfmsk(ijie,je_2 ,jk) & + & + p_fld(ijie,je_2+1,jk) * zsurfmsk(ijie,je_2+1,jk) & + & + p_fld(ijie,je_2+2,jk) * zsurfmsk(ijie,je_2+2,jk) + + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,jj ,jk) * zsurfmsk(ijie,jj ,jk) & + & + p_fld(ijie,jj+1,jk) * zsurfmsk(ijie,jj+1,jk) & + & + p_fld(ijie,jj+2,jk) * zsurfmsk(ijie,jj+2,jk) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + END SELECT + + IF( PRESENT( p_surf_crs ) ) THEN + WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:,:) = p_fld_crs(:,:,:) / p_surf_crs(:,:,:) + ENDIF + + DEALLOCATE( zsurfmsk ) + + CASE ( 'MAX' ) ! search the max of unmasked grid cells + + ALLOCATE( zmask(jpi,jpj,jpk) ) + + SELECT CASE ( cd_type ) + CASE( 'W' ) + zmask(:,:,1) = p_mask(:,:,1) + DO jk = 2, jpk + zmask(:,:,jk) = p_mask(:,:,jk-1) + ENDDO + CASE ( 'T' ) + DO jk = 1, jpk + zmask(:,:,jk) = p_mask(:,:,jk) + ENDDO + END SELECT + + SELECT CASE ( cd_type ) + + CASE( 'T', 'W' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MAX( p_fld(ji ,je_2,jk) * zmask(ji ,je_2,jk) - ( 1.- zmask(ji ,je_2,jk) ) * r_inf , & + & p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) - ( 1.- zmask(ji+1,je_2,jk) ) * r_inf , & + & p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) - ( 1.- zmask(ji+2,je_2,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MAX( p_fld(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) - ( 1.- zmask(ji ,je_2 ,jk) ) * r_inf , & + & p_fld(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) - ( 1.- zmask(ji+1,je_2 ,jk) ) * r_inf , & + & p_fld(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) - ( 1.- zmask(ji+2,je_2 ,jk) ) * r_inf , & + & p_fld(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) - ( 1.- zmask(ji ,je_2+1,jk) ) * r_inf , & + & p_fld(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) - ( 1.- zmask(ji+1,je_2+1,jk) ) * r_inf , & + & p_fld(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) - ( 1.- zmask(ji+2,je_2+1,jk) ) * r_inf , & + & p_fld(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) - ( 1.- zmask(ji ,je_2+2,jk) ) * r_inf , & + & p_fld(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) - ( 1.- zmask(ji+1,je_2+2,jk) ) * r_inf , & + & p_fld(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) - ( 1.- zmask(ji+2,je_2+2,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = & + & MAX( p_fld(ji ,jj ,jk) * zmask(ji ,jj ,jk) - ( 1.- zmask(ji ,jj ,jk) ) * r_inf , & + & p_fld(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) - ( 1.- zmask(ji+1,jj ,jk) ) * r_inf , & + & p_fld(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) - ( 1.- zmask(ji+2,jj ,jk) ) * r_inf , & + & p_fld(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) - ( 1.- zmask(ji ,jj+1,jk) ) * r_inf , & + & p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) - ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf , & + & p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) - ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf , & + & p_fld(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) - ( 1.- zmask(ji ,jj+2,jk) ) * r_inf , & + & p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) - ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf , & + & p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) - ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf ) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + CASE( 'V' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + ijje = mje_crs(2) + ENDIF + ELSE + ijje = mjs_crs(2) + ENDIF + + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MAX( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + ijje = mje_crs(ij) + ! + zflcrs = & + & MAX( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + + CASE( 'U' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = & + & MAX( p_fld(ijie,je_2 ,jk) * p_mask(ijie,je_2 ,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , & + & p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , & + & p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijie = mie_crs(ii) + zflcrs = & + & MAX( p_fld(ijie,jj ,jk) * p_mask(ijie,jj ,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf , & + & p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf , & + & p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf ) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + END SELECT + + DEALLOCATE( zmask ) + + CASE ( 'MIN' ) ! Search the min of unmasked grid cells + + ALLOCATE( zmask(jpi,jpj,jpk) ) + + SELECT CASE ( cd_type ) + CASE( 'W' ) + zmask(:,:,1) = p_mask(:,:,1) + DO jk = 2, jpk + zmask(:,:,jk) = p_mask(:,:,jk-1) + ENDDO + CASE ( 'T' ) + DO jk = 1, jpk + zmask(:,:,jk) = p_mask(:,:,jk) + ENDDO + END SELECT + + SELECT CASE ( cd_type ) + + CASE( 'T', 'W' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MIN( p_fld(ji ,je_2,jk) * zmask(ji ,je_2,jk) + ( 1.- zmask(ji ,je_2,jk) ) * r_inf , & + & p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) + ( 1.- zmask(ji+1,je_2,jk) ) * r_inf , & + & p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) + ( 1.- zmask(ji+2,je_2,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MIN( p_fld(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) + ( 1.- zmask(ji ,je_2 ,jk) ) * r_inf , & + & p_fld(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) + ( 1.- zmask(ji+1,je_2 ,jk) ) * r_inf , & + & p_fld(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) + ( 1.- zmask(ji+2,je_2 ,jk) ) * r_inf , & + & p_fld(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) + ( 1.- zmask(ji ,je_2+1,jk) ) * r_inf , & + & p_fld(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) + ( 1.- zmask(ji+1,je_2+1,jk) ) * r_inf , & + & p_fld(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) + ( 1.- zmask(ji+2,je_2+1,jk) ) * r_inf , & + & p_fld(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) + ( 1.- zmask(ji ,je_2+2,jk) ) * r_inf , & + & p_fld(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) + ( 1.- zmask(ji+1,je_2+2,jk) ) * r_inf , & + & p_fld(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) + ( 1.- zmask(ji+2,je_2+2,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = & + & MIN( p_fld(ji ,jj ,jk) * zmask(ji ,jj ,jk) + ( 1.- zmask(ji ,jj ,jk) ) * r_inf , & + & p_fld(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) + ( 1.- zmask(ji+1,jj ,jk) ) * r_inf , & + & p_fld(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) + ( 1.- zmask(ji+2,jj ,jk) ) * r_inf , & + & p_fld(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) + ( 1.- zmask(ji ,jj+1,jk) ) * r_inf , & + & p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) + ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf , & + & p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) + ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf , & + & p_fld(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) + ( 1.- zmask(ji ,jj+2,jk) ) * r_inf , & + & p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) + ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf , & + & p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) + ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf ) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + CASE( 'V' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + ijje = mje_crs(2) + ENDIF + ELSE + ijje = mjs_crs(2) + ENDIF + + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MIN( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + ijje = mje_crs(ij) + zflcrs = & + & MIN( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & + & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + + CASE( 'U' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = & + & MIN( p_fld(ijie,je_2 ,jk) * p_mask(ijie,je_2 ,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , & + & p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , & + & p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ) + ! + p_fld_crs(ii,2,jk) = zflcrs + ENDDO + ENDDO + ENDIF + ! + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijie = mie_crs(ii) + zflcrs = & + & MIN( p_fld(ijie,jj ,jk) * p_mask(ijie,jj ,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf , & + & p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf , & + & p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf ) + ! + p_fld_crs(ii,ij,jk) = zflcrs + ! + ENDDO + ENDDO + ENDDO + + END SELECT + ! + DEALLOCATE( zmask ) + ! + END SELECT + ! + CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn ) + ! + END SUBROUTINE crs_dom_ope_3d + + SUBROUTINE crs_dom_ope_2d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs, psgn ) + !!---------------------------------------------------------------- + !! *** SUBROUTINE crsfun_UV *** + !! ** Purpose : Average, area-weighted, of U or V on the east and north faces + !! + !! ** Method : The U and V velocities (3D) are determined as the area-weighted averages + !! on the east and north faces, respectively, + !! of the parent grid subset comprising the coarse grid box. + !! In the case of the V and F grid, the last jrow minus 1 is spurious. + !! ** Inputs : p_e1_e2 = parent grid e1 or e2 (t,u,v,f) + !! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V) + !! psgn = sign change over north fold (See lbclnk.F90) + !! p_pmask = parent grid mask (T,U,V,F) for scale factors; + !! for velocities (U or V) + !! p_e3 = parent grid vertical level thickness (e3u or e3v) + !! p_pfield = U or V on the parent grid + !! p_surf_crs = (Optional) Coarse grid weight for averaging + !! ** Outputs : p_cfield3d = 3D field on coarse grid + !! + !! History. 29 May. completed draft. + !! 4 Jun. Revision for WGT + !! 5 Jun. Streamline for area-weighted average only ; separate scale factor and weights. + !!---------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p_fld ! T, U, V or W on parent grid + CHARACTER(len=3), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN + CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask + REAL(dp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2) + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) + REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V mask + REAL(wp), INTENT(in) :: psgn + REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(out) :: p_fld_crs ! Coarse grid box 3D quantity + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijie, ijje, ii, ij, je_2 + REAL(wp) :: zflcrs, zsfcrs + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsurfmsk + !!---------------------------------------------------------------- + ! + p_fld_crs(:,:) = 0._wp + ! + SELECT CASE ( cd_op ) + + CASE ( 'VOL' ) + + ALLOCATE( zsurfmsk(jpi,jpj) ) + zsurfmsk(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2) * zsurfmsk(ji ,je_2) & + & + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2) & + & + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2) + + zsfcrs = zsurfmsk(ji,je_2) + zsurfmsk(ji+1,je_2) + zsurfmsk(ji+2,je_2) + ! + p_fld_crs(ii,2) = zflcrs + IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2) = zflcrs / zsfcrs + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2 ) * zsurfmsk(ji ,je_2 ) & + & + p_fld(ji+1,je_2 ) * zsurfmsk(ji+1,je_2 ) & + & + p_fld(ji+2,je_2 ) * zsurfmsk(ji+2,je_2 ) & + & + p_fld(ji ,je_2+1) * zsurfmsk(ji ,je_2+1) & + & + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1) & + & + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1) & + & + p_fld(ji ,je_2+2) * zsurfmsk(ji ,je_2+2) & + & + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2) & + & + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2) + + zsfcrs = zsurfmsk(ji,je_2 ) + zsurfmsk(ji+1,je_2 ) + zsurfmsk(ji+2,je_2 ) & + & + zsurfmsk(ji,je_2+1) + zsurfmsk(ji+1,je_2+1) + zsurfmsk(ji+2,je_2+1) & + & + zsurfmsk(ji,je_2+2) + zsurfmsk(ji+1,je_2+2) + zsurfmsk(ji+2,je_2+2) + ! + p_fld_crs(ii,2) = zflcrs + IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2) = zflcrs / zsfcrs + ENDDO + ENDIF + ! + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = p_fld(ji ,jj ) * zsurfmsk(ji ,jj ) & + & + p_fld(ji+1,jj ) * zsurfmsk(ji+1,jj ) & + & + p_fld(ji+2,jj ) * zsurfmsk(ji+2,jj ) & + & + p_fld(ji ,jj+1) * zsurfmsk(ji ,jj+1) & + & + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1) & + & + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1) & + & + p_fld(ji ,jj+2) * zsurfmsk(ji ,jj+2) & + & + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2) & + & + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2) + + zsfcrs = zsurfmsk(ji,jj ) + zsurfmsk(ji+1,jj ) + zsurfmsk(ji+2,jj ) & + & + zsurfmsk(ji,jj+1) + zsurfmsk(ji+1,jj+1) + zsurfmsk(ji+2,jj+1) & + & + zsurfmsk(ji,jj+2) + zsurfmsk(ji+1,jj+2) + zsurfmsk(ji+2,jj+2) + ! + p_fld_crs(ii,ij) = zflcrs + IF( zsfcrs /= 0.0 ) p_fld_crs(ii,ij) = zflcrs / zsfcrs + ENDDO + ENDDO + + DEALLOCATE( zsurfmsk ) + + CASE ( 'SUM' ) + + ALLOCATE( zsurfmsk(jpi,jpj) ) + IF( PRESENT( p_e3 ) ) THEN + zsurfmsk(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) + ELSE + zsurfmsk(:,:) = p_e12(:,:) * p_mask(:,:,1) + ENDIF + + SELECT CASE ( cd_type ) + + CASE( 'T', 'W' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2) * zsurfmsk(ji ,je_2) & + & + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2) & + & + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2) + ! + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,je_2 ) * zsurfmsk(ji ,je_2 ) & + & + p_fld(ji+1,je_2 ) * zsurfmsk(ji+1,je_2 ) & + & + p_fld(ji+2,je_2 ) * zsurfmsk(ji+2,je_2 ) & + & + p_fld(ji ,je_2+1) * zsurfmsk(ji ,je_2+1) & + & + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1) & + & + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1) & + & + p_fld(ji ,je_2+2) * zsurfmsk(ji ,je_2+2) & + & + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2) & + & + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2) + ! + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + ! + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = p_fld(ji ,jj ) * zsurfmsk(ji ,jj ) & + & + p_fld(ji+1,jj ) * zsurfmsk(ji+1,jj ) & + & + p_fld(ji+2,jj ) * zsurfmsk(ji+2,jj ) & + & + p_fld(ji ,jj+1) * zsurfmsk(ji ,jj+1) & + & + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1) & + & + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1) & + & + p_fld(ji ,jj+2) * zsurfmsk(ji ,jj+2) & + & + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2) & + & + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2) + ! + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + CASE( 'V' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + ijje = mje_crs(2) + ENDIF + ELSE + ijje = mjs_crs(2) + ENDIF + + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = p_fld(ji ,ijje) * zsurfmsk(ji ,ijje) & + & + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje) & + & + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje) + ! + p_fld_crs(ii,2) = zflcrs + ENDDO + + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijje = mje_crs(ij) + zflcrs = p_fld(ji ,ijje) * zsurfmsk(ji ,ijje) & + & + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje) & + & + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje) + ! + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + CASE( 'U' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2) * zsurfmsk(ijie,je_2) + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2 ) * zsurfmsk(ijie,je_2 ) & + & + p_fld(ijie,je_2+1) * zsurfmsk(ijie,je_2+1) & + & + p_fld(ijie,je_2+2) * zsurfmsk(ijie,je_2+2) + + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,jj ) * zsurfmsk(ijie,jj ) & + & + p_fld(ijie,jj+1) * zsurfmsk(ijie,jj+1) & + & + p_fld(ijie,jj+2) * zsurfmsk(ijie,jj+2) + ! + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + END SELECT + + IF( PRESENT( p_surf_crs ) ) THEN + WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:) = p_fld_crs(:,:) / p_surf_crs(:,:) + ENDIF + + DEALLOCATE( zsurfmsk ) + + CASE ( 'MAX' ) + + SELECT CASE ( cd_type ) + + CASE( 'T', 'W' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MAX( p_fld(ji ,je_2) * p_mask(ji ,je_2,1) - ( 1.- p_mask(ji ,je_2,1) ) * r_inf , & + & p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) - ( 1.- p_mask(ji+1,je_2,1) ) * r_inf , & + & p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) - ( 1.- p_mask(ji+2,je_2,1) ) * r_inf ) + ! + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + zflcrs = & + & MAX( p_fld(ji ,je_2 ) * p_mask(ji ,je_2 ,1) - ( 1.- p_mask(ji ,je_2 ,1) ) * r_inf , & + & p_fld(ji+1,je_2 ) * p_mask(ji+1,je_2 ,1) - ( 1.- p_mask(ji+1,je_2 ,1) ) * r_inf , & + & p_fld(ji+2,je_2 ) * p_mask(ji+2,je_2 ,1) - ( 1.- p_mask(ji+2,je_2 ,1) ) * r_inf , & + & p_fld(ji ,je_2+1) * p_mask(ji ,je_2+1,1) - ( 1.- p_mask(ji ,je_2+1,1) ) * r_inf , & + & p_fld(ji+1,je_2+1) * p_mask(ji+1,je_2+1,1) - ( 1.- p_mask(ji+1,je_2+1,1) ) * r_inf , & + & p_fld(ji+2,je_2+1) * p_mask(ji+2,je_2+1,1) - ( 1.- p_mask(ji+2,je_2+1,1) ) * r_inf , & + & p_fld(ji ,je_2+2) * p_mask(ji ,je_2+2,1) - ( 1.- p_mask(ji ,je_2+2,1) ) * r_inf , & + & p_fld(ji+1,je_2+2) * p_mask(ji+1,je_2+2,1) - ( 1.- p_mask(ji+1,je_2+2,1) ) * r_inf , & + & p_fld(ji+2,je_2+2) * p_mask(ji+2,je_2+2,1) - ( 1.- p_mask(ji+2,je_2+2,1) ) * r_inf ) + ! + p_fld_crs(ii,2) = zflcrs + ENDIF + + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = & + & MAX( p_fld(ji ,jj ) * p_mask(ji ,jj ,1) - ( 1.- p_mask(ji ,jj ,1) ) * r_inf , & + & p_fld(ji+1,jj ) * p_mask(ji+1,jj ,1) - ( 1.- p_mask(ji+1,jj ,1) ) * r_inf , & + & p_fld(ji+2,jj ) * p_mask(ji+2,jj ,1) - ( 1.- p_mask(ji+2,jj ,1) ) * r_inf , & + & p_fld(ji ,jj+1) * p_mask(ji ,jj+1,1) - ( 1.- p_mask(ji ,jj+1,1) ) * r_inf , & + & p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) - ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf , & + & p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) - ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf , & + & p_fld(ji ,jj+2) * p_mask(ji ,jj+2,1) - ( 1.- p_mask(ji ,jj+2,1) ) * r_inf , & + & p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) - ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf , & + & p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) - ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf ) + ! + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + CASE( 'V' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + ijje = mje_crs(2) + ENDIF + ELSE + ijje = mjs_crs(2) + ENDIF + + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = MAX( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ) + ! + p_fld_crs(ii,2) = zflcrs + ENDDO + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijje = mje_crs(ij) + ! + zflcrs = MAX( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ) + ! + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + CASE( 'U' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2) * p_mask(ijie,je_2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = & + & MAX( p_fld(ijie,je_2 ) * p_mask(ijie,je_2 ,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf , & + & p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf , & + & p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf ) + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijie = mie_crs(ii) + zflcrs = & + & MAX( p_fld(ijie,jj ) * p_mask(ijie,jj ,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf , & + & p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf , & + & p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf ) + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + END SELECT + + CASE ( 'MIN' ) ! Search the min of unmasked grid cells + + SELECT CASE ( cd_type ) + + CASE( 'T', 'W' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = & + & MIN( p_fld(ji ,je_2) * p_mask(ji ,je_2,1) + ( 1.- p_mask(ji ,je_2,1) ) * r_inf , & + & p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) + ( 1.- p_mask(ji+1,je_2,1) ) * r_inf , & + & p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) + ( 1.- p_mask(ji+2,je_2,1) ) * r_inf ) + ! + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + zflcrs = & + & MIN( p_fld(ji ,je_2 ) * p_mask(ji ,je_2 ,1) + ( 1.- p_mask(ji ,je_2 ,1) ) * r_inf , & + & p_fld(ji+1,je_2 ) * p_mask(ji+1,je_2 ,1) + ( 1.- p_mask(ji+1,je_2 ,1) ) * r_inf , & + & p_fld(ji+2,je_2 ) * p_mask(ji+2,je_2 ,1) + ( 1.- p_mask(ji+2,je_2 ,1) ) * r_inf , & + & p_fld(ji ,je_2+1) * p_mask(ji ,je_2+1,1) + ( 1.- p_mask(ji ,je_2+1,1) ) * r_inf , & + & p_fld(ji+1,je_2+1) * p_mask(ji+1,je_2+1,1) + ( 1.- p_mask(ji+1,je_2+1,1) ) * r_inf , & + & p_fld(ji+2,je_2+1) * p_mask(ji+2,je_2+1,1) + ( 1.- p_mask(ji+2,je_2+1,1) ) * r_inf , & + & p_fld(ji ,je_2+2) * p_mask(ji ,je_2+2,1) + ( 1.- p_mask(ji ,je_2+2,1) ) * r_inf , & + & p_fld(ji+1,je_2+2) * p_mask(ji+1,je_2+2,1) + ( 1.- p_mask(ji+1,je_2+2,1) ) * r_inf , & + & p_fld(ji+2,je_2+2) * p_mask(ji+2,je_2+2,1) + ( 1.- p_mask(ji+2,je_2+2,1) ) * r_inf ) + ! + p_fld_crs(ii,2) = zflcrs + ENDIF + + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + zflcrs = & + & MIN( p_fld(ji ,jj ) * p_mask(ji ,jj ,1) + ( 1.- p_mask(ji ,jj ,1) ) * r_inf , & + & p_fld(ji+1,jj ) * p_mask(ji+1,jj ,1) + ( 1.- p_mask(ji+1,jj ,1) ) * r_inf , & + & p_fld(ji+2,jj ) * p_mask(ji+2,jj ,1) + ( 1.- p_mask(ji+2,jj ,1) ) * r_inf , & + & p_fld(ji ,jj+1) * p_mask(ji ,jj+1,1) + ( 1.- p_mask(ji ,jj+1,1) ) * r_inf , & + & p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) + ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf , & + & p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) + ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf , & + & p_fld(ji ,jj+2) * p_mask(ji ,jj+2,1) + ( 1.- p_mask(ji ,jj+2,1) ) * r_inf , & + & p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) + ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf , & + & p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) + ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf ) + ! + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + CASE( 'V' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + ijje = mje_crs(2) + ENDIF + ELSE + ijje = mjs_crs(2) + ENDIF + + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + zflcrs = MIN( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ) + ! + p_fld_crs(ii,2) = zflcrs + ENDDO + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijje = mje_crs(ij) + ! + zflcrs = MIN( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , & + & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ) + ! + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + CASE( 'U' ) + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = p_fld(ijie,je_2) * p_mask(ijie,je_2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf + + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ijie = mie_crs(ii) + zflcrs = & + & MIN( p_fld(ijie,je_2 ) * p_mask(ijie,je_2 ,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf , & + & p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf , & + & p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf ) + p_fld_crs(ii,2) = zflcrs + ENDDO + ENDIF + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ijie = mie_crs(ii) + zflcrs = & + & MIN( p_fld(ijie,jj ) * p_mask(ijie,jj ,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf , & + & p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf , & + & p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf ) + p_fld_crs(ii,ij) = zflcrs + ! + ENDDO + ENDDO + + END SELECT + ! + END SELECT + ! + CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn ) + ! + END SUBROUTINE crs_dom_ope_2d + + SUBROUTINE crs_dom_e3( p_e1, p_e2, p_e3, p_sfc_crs, cd_type, p_mask, p_e3_crs, p_e3_max_crs) + !!---------------------------------------------------------------- + !! Arguments + CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T mask + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1, p_e2 ! 2D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_e3 ! 3D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in) :: p_sfc_crs ! Coarse grid box east or north face quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_crs ! Coarse grid box east or north face quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_max_crs ! Coarse grid box east or north face quantity + + !! Local variables + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ijie, ijje, ii, ij, je_2 + REAL(wp) :: ze3crs + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask, zsurf + + !!---------------------------------------------------------------- + + p_e3_crs (:,:,:) = 0. + p_e3_max_crs(:,:,:) = 1. + + + SELECT CASE ( cd_type ) + CASE( 'W' ) + zmask(:,:,1) = p_mask(:,:,1) + DO jk = 2, jpk + zmask(:,:,jk) = p_mask(:,:,jk-1) + ENDDO + CASE DEFAULT + DO jk = 1, jpk + zmask(:,:,jk) = p_mask(:,:,jk) + ENDDO + END SELECT + + DO jk = 1, jpk + zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) + ENDDO + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1 , jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ze3crs = zsurf(ji ,je_2,jk) * zmask(ji ,je_2,jk) & + & + zsurf(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) & + & + zsurf(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) + + p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,ij,jk) + ! + ze3crs = MAX( p_e3(ji ,je_2,jk) * zmask(ji ,je_2,jk), & + & p_e3(ji+1,je_2,jk) * zmask(ji+1,je_2,jk), & + & p_e3(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) ) + ! + p_e3_max_crs(ii,2,jk) = ze3crs + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1 , jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ze3crs = zsurf(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) & + & + zsurf(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) & + & + zsurf(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) & + & + zsurf(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) & + & + zsurf(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) & + & + zsurf(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) & + & + zsurf(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) & + & + zsurf(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) & + & + zsurf(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) + + p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) + ! + ze3crs = MAX( p_e3(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk), & + & p_e3(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk), & + & p_e3(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk), & + & p_e3(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk), & + & p_e3(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk), & + & p_e3(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk), & + & p_e3(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk), & + & p_e3(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk), & + & p_e3(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) ) + + p_e3_max_crs(ii,2,jk) = ze3crs + ENDDO + ENDDO + ENDIF + DO jk = 1 , jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ze3crs = zsurf(ji ,jj ,jk) * zmask(ji ,jj ,jk) & + & + zsurf(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) & + & + zsurf(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) & + & + zsurf(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) & + & + zsurf(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) & + & + zsurf(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) & + & + zsurf(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) & + & + zsurf(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) & + & + zsurf(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) + + p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) + ! + ze3crs = MAX( p_e3(ji ,jj ,jk) * zmask(ji ,jj ,jk), & + & p_e3(ji+1,jj ,jk) * zmask(ji+1,jj ,jk), & + & p_e3(ji+2,jj ,jk) * zmask(ji+2,jj ,jk), & + & p_e3(ji ,jj+1,jk) * zmask(ji ,jj+1,jk), & + & p_e3(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk), & + & p_e3(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk), & + & p_e3(ji ,jj+2,jk) * zmask(ji ,jj+2,jk), & + & p_e3(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk), & + & p_e3(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) ) + + p_e3_max_crs(ii,ij,jk) = ze3crs + ENDDO + ENDDO + ENDDO + + CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0_wp, pfillval=1.0_wp ) + CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) + ! + ! + END SUBROUTINE crs_dom_e3 + + SUBROUTINE crs_dom_sfc( p_mask, cd_type, p_surf_crs, p_surf_crs_msk, p_e1, p_e2, p_e3 ) + + !! Arguments + CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in) :: p_mask ! Parent grid T mask + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in), OPTIONAL :: p_e1, p_e2 ! 3D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in), OPTIONAL :: p_e3 ! 3D tracer T or W on parent grid + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs ! Coarse grid box east or north face quantity + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs_msk ! Coarse grid box east or north face quantity + + !! Local variables + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ii, ij, je_2 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zsurf, zsurfmsk + !!---------------------------------------------------------------- + ! Initialize + + ! + SELECT CASE ( cd_type ) + + CASE ('W') + DO jk = 1, jpk + zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) + ENDDO + zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) + DO jk = 2, jpk + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) + ENDDO + + CASE ('V') + DO jk = 1, jpk + zsurf(:,:,jk) = p_e1(:,:) * p_e3(:,:,jk) + ENDDO + DO jk = 1, jpk + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) + ENDDO + + CASE ('U') + DO jk = 1, jpk + zsurf(:,:,jk) = p_e2(:,:) * p_e3(:,:,jk) + ENDDO + DO jk = 1, jpk + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) + ENDDO + + CASE DEFAULT + DO jk = 1, jpk + zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) + ENDDO + DO jk = 1, jpk + zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) + ENDDO + END SELECT + + IF( Njs0_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 + IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN + je_2 = mje_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ! + p_surf_crs (ii,2,jk) = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) & + & + zsurf(ji,je_2-1,jk) + zsurf(ji+1,je_2-1,jk) + zsurf(ji+2,je_2-1,jk) ! Why ????? + ! + p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji,je_2,jk) + zsurfmsk(ji+1,je_2,jk) + zsurfmsk(ji+2,je_2,jk) + ! + ENDDO + ENDDO + ENDIF + ELSE + je_2 = mjs_crs(2) + DO jk = 1, jpk + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ! + p_surf_crs (ii,2,jk) = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) & + & + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) & + & + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) + + p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji,je_2 ,jk) + zsurfmsk(ji+1,je_2 ,jk) + zsurfmsk(ji+2,je_2 ,jk) & + & + zsurfmsk(ji,je_2+1,jk) + zsurfmsk(ji+1,je_2+1,jk) + zsurfmsk(ji+2,je_2+1,jk) & + & + zsurfmsk(ji,je_2+2,jk) + zsurfmsk(ji+1,je_2+2,jk) + zsurfmsk(ji+2,je_2+2,jk) + ENDDO + ENDDO + ENDIF + + DO jk = 1, jpk + DO jj = njstr, njend, nn_facty + DO ji = nistr, niend, nn_factx + ii = ( ji - mis_crs(2) ) * rfactx_r + 2 + ij = ( jj - njstr ) * rfacty_r + 3 + ! + p_surf_crs (ii,ij,jk) = zsurf(ji,jj ,jk) + zsurf(ji+1,jj ,jk) + zsurf(ji+2,jj ,jk) & + & + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) & + & + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) + + p_surf_crs_msk(ii,ij,jk) = zsurfmsk(ji,jj ,jk) + zsurfmsk(ji+1,jj ,jk) + zsurfmsk(ji+2,jj ,jk) & + & + zsurfmsk(ji,jj+1,jk) + zsurfmsk(ji+1,jj+1,jk) + zsurfmsk(ji+2,jj+1,jk) & + & + zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk) + ENDDO + ENDDO + ENDDO + + CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0_wp, pfillval=1.0_wp ) + CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0_wp, pfillval=1.0_wp ) + + END SUBROUTINE crs_dom_sfc + + SUBROUTINE crs_dom_def + !!---------------------------------------------------------------- + !! *** SUBROUTINE crs_dom_def *** + !! ** Purpose : Three applications. + !! 1) Define global domain indice of the croasening grid + !! 2) Define local domain indice of the croasening grid + !! 3) Define the processor domain indice for a croasening grid + !!---------------------------------------------------------------- + !! + !! local variables + + INTEGER :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn ! dummy indices + INTEGER :: ierr ! allocation error status + + +!!$ ! 1.a. Define global domain indices : take into account the interior domain only ( removes i/j=1 , i/j=jpiglo/jpjglo ) then add 2/3 grid points +!!$ jpiglo_crs = INT( (jpiglo - 2) / nn_factx ) + 2 +!!$ ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 2 ! the -2 removes j=1, j=jpj +!!$ ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 3 +!!$ jpjglo_crs = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 3 +!!$ jpiglo_crsm1 = jpiglo_crs - 1 +!!$ jpjglo_crsm1 = jpjglo_crs - 1 +!!$ +!!$ jpi_crs = ( jpiglo_crs - 2 * nn_hls + (jpni-1) ) / jpni + 2 * nn_hls +!!$ jpj_crs = ( jpjglo_crsm1 - 2 * nn_hls + (jpnj-1) ) / jpnj + 2 * nn_hls +!!$ +!!$ IF( noso < 0 ) jpj_crs = jpj_crs + 1 ! add a local band on southern processors +!!$ +!!$ jpi_crsm1 = jpi_crs - 1 +!!$ jpj_crsm1 = jpj_crs - 1 +!!$ nperio_crs = jperio +!!$ npolj_crs = npolj +!!$ +!!$ ierr = crs_dom_alloc() ! allocate most coarse grid arrays +!!$ +!!$ ! 2.a Define processor domain +!!$ IF( .NOT. lk_mpp ) THEN +!!$ nimpp_crs = 1 +!!$ njmpp_crs = 1 +!!$ Nis0_crs = 1 +!!$ Njs0_crs = 1 +!!$ Nie0_crs = jpi_crs +!!$ Nje0_crs = jpj_crs +!!$ ELSE +!!$ ! Initialisation of most local variables - +!!$ nimpp_crs = 1 +!!$ njmpp_crs = 1 +!!$ Nis0_crs = 1 +!!$ Njs0_crs = 1 +!!$ Nie0_crs = jpi_crs +!!$ Nje0_crs = jpj_crs +!!$ +!!$ ! Calculs suivant une découpage en j +!!$ DO jn = 1, jpnij, jpni +!!$ IF( jn < ( jpnij - jpni + 1 ) ) THEN +!!$ nje0all_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn ) - 1) ) / nn_facty, wp ) ) & +!!$ & - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) ) +!!$ ELSE +!!$ nje0all_crs(jn) = AINT( REAL( nje0all(jn) / nn_facty, wp ) ) + 1 +!!$ ENDIF +!!$ IF( noso < 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 1 +!!$ SELECT CASE( ibonjt(jn) ) +!!$ CASE ( -1 ) +!!$ IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 1 +!!$ jpjall_crs (jn) = nje0all_crs(jn) + nn_hls +!!$ njs0all_crs(jn) = njs0all(jn) +!!$ +!!$ CASE ( 0 ) +!!$ +!!$ njs0all_crs(jn) = njs0all(jn) +!!$ IF( njs0all(jn) == 1 ) nje0all_crs(jn) = nje0all_crs(jn) + 1 +!!$ nje0all_crs(jn) = nje0all_crs(jn) + nn_hls +!!$ jpjall_crs (jn) = nje0all_crs(jn) + nn_hls +!!$ +!!$ CASE ( 1, 2 ) +!!$ +!!$ nje0all_crs(jn) = nje0all_crs(jn) + nn_hls +!!$ jpjall_crs (jn) = nje0all_crs(jn) +!!$ njs0all_crs(jn) = njs0all(jn) +!!$ +!!$ CASE DEFAULT +!!$ CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' ) +!!$ END SELECT +!!$ IF( jpjall_crs(jn) > jpj_crs ) jpj_crs = jpj_crs + 1 +!!$ +!!$ IF(njs0all_crs(jn) == 1 ) THEN +!!$ njmppt_crs(jn) = 1 +!!$ ELSE +!!$ njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) ) +!!$ ENDIF +!!$ +!!$ DO jj = jn + 1, jn + jpni - 1 +!!$ nje0all_crs(jj) = nje0all_crs(jn) +!!$ jpjall_crs (jj) = jpjall_crs(jn) +!!$ njs0all_crs(jj) = njs0all_crs(jn) +!!$ njmppt_crs (jj) = njmppt_crs(jn) +!!$ ENDDO +!!$ ENDDO +!!$ Nje0_crs = nje0all_crs(narea) +!!$ jpj_crs = jpjall_crs (narea) +!!$ Njs0_crs = njs0all_crs(narea) +!!$ njmpp_crs = njmppt_crs (narea) +!!$ +!!$ ! Calcul suivant un decoupage en i +!!$ DO jn = 1, jpni +!!$ IF( jn == 1 ) THEN +!!$ nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) ) +!!$ ELSE +!!$ nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) ) & +!!$ & - AINT( REAL( ( nimppt(jn-1) - 1 + jpiall(jn-1) ) / nn_factx, wp) ) +!!$ ENDIF +!!$ +!!$ SELECT CASE( ibonit(jn) ) +!!$ CASE ( -1 ) +!!$ nie0all_crs(jn) = nie0all_crs(jn) + nn_hls +!!$ jpiall_crs (jn) = nie0all_crs(jn) + nn_hls +!!$ nis0all_crs(jn) = nis0all(jn) +!!$ +!!$ CASE ( 0 ) +!!$ nie0all_crs(jn) = nie0all_crs(jn) + nn_hls +!!$ jpiall_crs (jn) = nie0all_crs(jn) + nn_hls +!!$ nis0all_crs(jn) = nis0all(jn) +!!$ +!!$ CASE ( 1, 2 ) +!!$ IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 ) nie0all_crs(jn) = nie0all_crs(jn) + 1 +!!$ nie0all_crs(jn) = nie0all_crs(jn) + nn_hls +!!$ jpiall_crs (jn) = nie0all_crs(jn) +!!$ nis0all_crs(jn) = nis0all(jn) +!!$ +!!$ CASE DEFAULT +!!$ CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (2) ...' ) +!!$ END SELECT +!!$ +!!$ nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1 +!!$ DO jj = jn + jpni , jpnij, jpni +!!$ nie0all_crs(jj) = nie0all_crs(jn) +!!$ jpiall_crs (jj) = jpiall_crs (jn) +!!$ nis0all_crs(jj) = nis0all_crs(jn) +!!$ nimppt_crs (jj) = nimppt_crs (jn) +!!$ ENDDO +!!$ ENDDO +!!$ +!!$ Nie0_crs = nie0all_crs(narea) +!!$ jpi_crs = jpiall_crs (narea) +!!$ Nis0_crs = nis0all_crs(narea) +!!$ nimpp_crs = nimppt_crs (narea) +!!$ +!!$ DO ji = 1, jpi_crs +!!$ mig_crs(ji) = ji + nimpp_crs - 1 +!!$ ENDDO +!!$ DO jj = 1, jpj_crs +!!$ mjg_crs(jj) = jj + njmpp_crs - 1! +!!$ ENDDO +!!$ +!!$ DO ji = 1, jpiglo_crs +!!$ mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) ) +!!$ mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs ) ) +!!$ ENDDO +!!$ +!!$ DO jj = 1, jpjglo_crs +!!$ mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) ) +!!$ mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs ) ) +!!$ ENDDO +!!$ +!!$ ENDIF +!!$ +!!$ ! Save the parent grid information +!!$ jpi_full = jpi +!!$ jpj_full = jpj +!!$ jpim1_full = jpim1 +!!$ jpjm1_full = jpjm1 +!!$ nperio_full = jperio +!!$ +!!$ npolj_full = npolj +!!$ jpiglo_full = jpiglo +!!$ jpjglo_full = jpjglo +!!$ +!!$ jpj_full = jpj +!!$ jpi_full = jpi +!!$ Nis0_full = Nis0 +!!$ Njs0_full = Njs0 +!!$ Nie0_full = Nie0 +!!$ Nje0_full = Nje0 +!!$ nimpp_full = nimpp +!!$ njmpp_full = njmpp +!!$ +!!$ jpiall_full (:) = jpiall (:) +!!$ nis0all_full(:) = nis0all(:) +!!$ nie0all_full(:) = nie0all(:) +!!$ nimppt_full (:) = nimppt (:) +!!$ jpjall_full (:) = jpjall (:) +!!$ njs0all_full(:) = njs0all(:) +!!$ nje0all_full(:) = nje0all(:) +!!$ njmppt_full (:) = njmppt (:) + + CALL dom_grid_crs !swich de grille + + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'crs_init : coarse grid dimensions' + WRITE(numout,*) '~~~~~~~ coarse domain global j-dimension jpjglo = ', jpjglo + WRITE(numout,*) '~~~~~~~ coarse domain global i-dimension jpiglo = ', jpiglo + WRITE(numout,*) '~~~~~~~ coarse domain local i-dimension jpi = ', jpi + WRITE(numout,*) '~~~~~~~ coarse domain local j-dimension jpj = ', jpj + WRITE(numout,*) + WRITE(numout,*) ' narea = ' , narea + WRITE(numout,*) ' jpi = ' , jpi + WRITE(numout,*) ' jpj = ' , jpj + WRITE(numout,*) ' Nis0 = ' , Nis0 + WRITE(numout,*) ' Njs0 = ' , Njs0 + WRITE(numout,*) ' Nie0 = ' , Nie0 + WRITE(numout,*) ' Nje0 = ' , Nje0 + WRITE(numout,*) ' Nie0_full=' , Nie0_full + WRITE(numout,*) ' Nis0_full=' , Nis0_full + WRITE(numout,*) ' nimpp = ' , nimpp + WRITE(numout,*) ' njmpp = ' , njmpp + WRITE(numout,*) ' njmpp_full = ', njmpp_full + WRITE(numout,*) + ENDIF + + CALL dom_grid_glo + + mxbinctr = INT( nn_factx * 0.5 ) + mybinctr = INT( nn_facty * 0.5 ) + + nrestx = MOD( nn_factx, 2 ) ! check if even- or odd- numbered reduction factor + nresty = MOD( nn_facty, 2 ) + + IF ( nrestx == 0 ) THEN + mxbinctr = mxbinctr - 1 + ENDIF + + IF ( nresty == 0 ) THEN + mybinctr = mybinctr - 1 +!!$ IF ( jperio == 3 .OR. jperio == 4 ) nperio_crs = jperio + 2 +!!$ IF ( jperio == 5 .OR. jperio == 6 ) nperio_crs = jperio - 2 +!!$ +!!$ IF ( npolj == 3 ) npolj_crs = 5 +!!$ IF ( npolj == 5 ) npolj_crs = 3 + ENDIF + + rfactxy = nn_factx * nn_facty + + ! 2.b. Set up bins for coarse grid, horizontal only. + ierr = crs_dom_alloc2() + + mis2_crs(:) = 0 ; mie2_crs(:) = 0 + mjs2_crs(:) = 0 ; mje2_crs(:) = 0 + + + SELECT CASE ( nn_binref ) + + CASE ( 0 ) + +!!$ SELECT CASE ( jperio ) +!!$ +!!$ +!!$ CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold +!!$ +!!$ DO ji = 2, jpiglo_crsm1 +!!$ ijie = ( ji * nn_factx ) - nn_factx !cc +!!$ ijis = ijie - nn_factx + 1 +!!$ mis2_crs(ji) = ijis +!!$ mie2_crs(ji) = ijie +!!$ ENDDO +!!$ IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie2_crs(jpiglo_crsm1) = jpiglo - 2 +!!$ +!!$ ! Handle first the northernmost bin +!!$ IF ( nn_facty == 2 ) THEN ; ijjgloT = jpjglo - 1 +!!$ ELSE ; ijjgloT = jpjglo +!!$ ENDIF +!!$ +!!$ DO jj = 2, jpjglo_crs +!!$ ijje = ijjgloT - nn_facty * ( jj - 3 ) +!!$ ijjs = ijje - nn_facty + 1 +!!$ mjs2_crs(jpjglo_crs-jj+2) = ijjs +!!$ mje2_crs(jpjglo_crs-jj+2) = ijje +!!$ ENDDO +!!$ +!!$ CASE ( 2 ) +!!$ WRITE(numout,*) 'crs_init, jperio=2 not supported' +!!$ +!!$ CASE ( 5, 6 ) ! F-pivot at North Fold +!!$ +!!$ DO ji = 2, jpiglo_crsm1 +!!$ ijie = ( ji * nn_factx ) - nn_factx +!!$ ijis = ijie - nn_factx + 1 +!!$ mis2_crs(ji) = ijis +!!$ mie2_crs(ji) = ijie +!!$ ENDDO +!!$ IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1) = jpiglo - 2 +!!$ +!!$ ! Treat the northernmost bin separately. +!!$ jj = 2 +!!$ ijje = jpj - nn_facty * ( jj - 2 ) +!!$ IF ( nn_facty == 3 ) THEN ; ijjs = ijje - 1 +!!$ ELSE ; ijjs = ijje - nn_facty + 1 +!!$ ENDIF +!!$ mjs2_crs(jpj_crs-jj+1) = ijjs +!!$ mje2_crs(jpj_crs-jj+1) = ijje +!!$ +!!$ ! Now bin the rest, any remainder at the south is lumped in the southern bin +!!$ DO jj = 3, jpjglo_crsm1 +!!$ ijje = jpjglo - nn_facty * ( jj - 2 ) +!!$ ijjs = ijje - nn_facty + 1 +!!$ IF ( ijjs <= nn_facty ) ijjs = 2 +!!$ mjs2_crs(jpj_crs-jj+1) = ijjs +!!$ mje2_crs(jpj_crs-jj+1) = ijje +!!$ ENDDO +!!$ +!!$ CASE DEFAULT +!!$ WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4, 5, 6 supported' +!!$ +!!$ END SELECT + + CASE (1 ) + WRITE(numout,*) 'crs_init. Equator-centered bins option not yet available' + + END SELECT + + ! Pad the boundaries, do not know if it is necessary + mis2_crs(2) = 1 ; mis2_crs(jpiglo_crs) = mie2_crs(jpiglo_crs - 1) + 1 + mie2_crs(2) = nn_factx ; mie2_crs(jpiglo_crs) = jpiglo + ! + mjs2_crs(1) = 1 + mje2_crs(1) = 1 + ! + mje2_crs(2) = mjs2_crs(3)-1 ; mje2_crs(jpjglo_crs) = jpjglo + mjs2_crs(2) = 1 ; mjs2_crs(jpjglo_crs) = mje2_crs(jpjglo_crs) - nn_facty + 1 + + IF( .NOT. lk_mpp ) THEN + mis_crs(:) = mis2_crs(:) + mie_crs(:) = mie2_crs(:) + mjs_crs(:) = mjs2_crs(:) + mje_crs(:) = mje2_crs(:) + ELSE + DO jj = 1, Nje0_crs + mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1 + mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1 + ENDDO + DO ji = 1, Nie0_crs + mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1 + mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1 + ENDDO + ENDIF + ! + nistr = mis_crs(2) ; niend = mis_crs(jpi_crs - 1) + njstr = mjs_crs(3) ; njend = mjs_crs(jpj_crs - 1) + ! + END SUBROUTINE crs_dom_def + + SUBROUTINE crs_dom_bat + !!---------------------------------------------------------------- + !! *** SUBROUTINE crs_dom_bat *** + !! ** Purpose : coarsenig bathy + !!---------------------------------------------------------------- + !! + !! local variables + INTEGER :: ji,jj,jk ! dummy indices + REAL(wp), DIMENSION(jpi_crs, jpj_crs) :: zmbk + !!---------------------------------------------------------------- + + mbathy_crs(:,:) = jpkm1 + mbkt_crs(:,:) = 1 + mbku_crs(:,:) = 1 + mbkv_crs(:,:) = 1 + + + DO jj = 1, jpj_crs + DO ji = 1, jpi_crs + jk = 0 + DO WHILE( tmask_crs(ji,jj,jk+1) > 0.) + jk = jk + 1 + ENDDO + mbathy_crs(ji,jj) = float( jk ) + ENDDO + ENDDO + + zmbk(:,:) = 0.0 + zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0_wp) ; mbathy_crs(:,:) = NINT( zmbk(:,:) ) + + + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' crsini : mbkt is ocean bottom k-index of T-, U-, V- and W-levels ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~' + ! + mbkt_crs(:,:) = MAX( mbathy_crs(:,:) , 1 ) ! bottom k-index of T-level (=1 over land) + ! ! bottom k-index of W-level = mbkt+1 + + DO jj = 1, jpj_crsm1 ! bottom k-index of u- (v-) level + DO ji = 1, jpi_crsm1 + mbku_crs(ji,jj) = MIN( mbkt_crs(ji+1,jj ) , mbkt_crs(ji,jj) ) + mbkv_crs(ji,jj) = MIN( mbkt_crs(ji ,jj+1) , mbkt_crs(ji,jj) ) + END DO + END DO + + ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk + zmbk(:,:) = 1.e0; + zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0_wp) ; mbku_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) + zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0_wp) ; mbkv_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) + ! + END SUBROUTINE crs_dom_bat + + +END MODULE crsdom \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsdomwri.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsdomwri.F90 new file mode 100644 index 0000000..a517189 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsdomwri.F90 @@ -0,0 +1,203 @@ +MODULE crsdomwri + !!====================================================================== + !! Coarse Ocean initialization : write the coarse ocean domain mesh and mask files + !!====================================================================== + !! History : 3.6 ! 2012-06 (J. Simeon, C. Calone, C Ethe ) from domwri, reduced and modified for coarse grid + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! crs_dom_wri : create and write mesh and mask file(s) + !!---------------------------------------------------------------------- + USE timing ! Timing + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + USE par_kind, ONLY: wp + USE lib_mpp ! MPP library + USE iom_def + USE iom + USE crs ! coarse grid domain + USE crsdom ! coarse grid domain + USE crslbclnk ! crs mediator to lbclnk + + IMPLICIT NONE + PRIVATE + + PUBLIC crs_dom_wri ! routine called by crsini.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: crsdomwri.F90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_dom_wri + !!---------------------------------------------------------------------- + !! *** ROUTINE crs_dom_wri *** + !! + !! ** Purpose : Create the NetCDF file(s) which contain(s) all the + !! ocean domain informations (mesh and mask arrays). This (these) + !! file(s) is (are) used for visualisation (SAXO software) and + !! diagnostic computation. + !! + !! ** Method : Write in a file all the arrays generated in routines + !! crsini for meshes and mask. In three separate files: + !! domain size, horizontal grid-point position, + !! masks, depth and vertical scale factors + !! + !! ** Output files : mesh_hgr_crs.nc, mesh_zgr_crs.nc, mesh_mask.nc + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: inum ! local units for 'mesh_mask.nc' file + CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) + ! ! workspace + REAL(wp), DIMENSION(jpi_crs,jpj_crs ) :: zprt, zprw + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk) :: zdepu, zdepv + !!---------------------------------------------------------------------- + ! + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'crs_dom_wri : create NetCDF mesh and mask file' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + + clnam = 'mesh_mask_crs' ! filename (mesh and mask informations) + + + ! ! ============================ + ! ! create 'mesh_mask.nc' file + ! ! ============================ + ! + CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) + + CALL iom_rstput( 0, 0, inum, 'tmask', tmask_crs, ktype = jp_i1 ) ! land-sea mask + CALL iom_rstput( 0, 0, inum, 'umask', umask_crs, ktype = jp_i1 ) + CALL iom_rstput( 0, 0, inum, 'vmask', vmask_crs, ktype = jp_i1 ) + CALL iom_rstput( 0, 0, inum, 'fmask', fmask_crs, ktype = jp_i1 ) + + CALL dom_uniq_crs( zprw, 'T' ) + zprt = tmask_crs(:,:,1) * zprw + CALL iom_rstput( 0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1 ) + CALL dom_uniq_crs( zprw, 'U' ) + zprt = umask_crs(:,:,1) * zprw + CALL iom_rstput( 0, 0, inum, 'umaskutil', zprt, ktype = jp_i1 ) + CALL dom_uniq_crs( zprw, 'V' ) + zprt = vmask_crs(:,:,1) * zprw + CALL iom_rstput( 0, 0, inum, 'vmaskutil', zprt, ktype = jp_i1 ) + CALL dom_uniq_crs( zprw, 'F' ) + zprt = fmask_crs(:,:,1) * zprw + CALL iom_rstput( 0, 0, inum, 'fmaskutil', zprt, ktype = jp_i1 ) + !======================================================== + ! ! horizontal mesh + CALL iom_rstput( 0, 0, inum, 'glamt', glamt_crs, ktype = jp_r4 ) ! ! latitude + CALL iom_rstput( 0, 0, inum, 'glamu', glamu_crs, ktype = jp_r4 ) + CALL iom_rstput( 0, 0, inum, 'glamv', glamv_crs, ktype = jp_r4 ) + CALL iom_rstput( 0, 0, inum, 'glamf', glamf_crs, ktype = jp_r4 ) + + CALL iom_rstput( 0, 0, inum, 'gphit', gphit_crs, ktype = jp_r4 ) ! ! longitude + CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu_crs, ktype = jp_r4 ) + CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv_crs, ktype = jp_r4 ) + CALL iom_rstput( 0, 0, inum, 'gphif', gphif_crs, ktype = jp_r4 ) + + CALL iom_rstput( 0, 0, inum, 'e1t', e1t_crs, ktype = jp_r8 ) ! ! e1 scale factors + CALL iom_rstput( 0, 0, inum, 'e1u', e1u_crs, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e1v', e1v_crs, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e1f', e1f_crs, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum, 'e2t', e2t_crs, ktype = jp_r8 ) ! ! e2 scale factors + CALL iom_rstput( 0, 0, inum, 'e2u', e2u_crs, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e2v', e2v_crs, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e2f', e2f_crs, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum, 'ff', ff_crs, ktype = jp_r8 ) ! ! coriolis factor + + !======================================================== + ! ! vertical mesh +! ! note that mbkt is set to 1 over land ==> use surface tmask_crs + zprt(:,:) = tmask_crs(:,:,1) * REAL( mbkt_crs(:,:) , wp ) + CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i2 ) ! ! nb of ocean T-points + ! + CALL iom_rstput( 0, 0, inum, 'e3t', e3t_crs ) + CALL iom_rstput( 0, 0, inum, 'e3w', e3w_crs ) + CALL iom_rstput( 0, 0, inum, 'e3u', e3u_crs ) + CALL iom_rstput( 0, 0, inum, 'e3v', e3v_crs ) + ! + CALL iom_rstput( 0, 0, inum, 'gdept', gdept_crs, ktype = jp_r4 ) + DO jk = 1,jpk + DO jj = 1, jpj_crsm1 + DO ji = 1, jpi_crsm1 ! jes what to do for jpim1??vector opt. + zdepu(ji,jj,jk) = MIN( gdept_crs(ji,jj,jk) , gdept_crs(ji+1,jj ,jk) ) * umask_crs(ji,jj,jk) + zdepv(ji,jj,jk) = MIN( gdept_crs(ji,jj,jk) , gdept_crs(ji ,jj+1,jk) ) * vmask_crs(ji,jj,jk) + END DO + END DO + END DO + CALL crs_lbc_lnk( zdepu,'U', 1.0_wp ) ; CALL crs_lbc_lnk( zdepv,'V', 1.0_wp ) + ! + CALL iom_rstput( 0, 0, inum, 'gdepu', zdepu, ktype = jp_r4 ) + CALL iom_rstput( 0, 0, inum, 'gdepv', zdepv, ktype = jp_r4 ) + CALL iom_rstput( 0, 0, inum, 'gdepw', gdepw_crs, ktype = jp_r4 ) + ! + CALL iom_rstput( 0, 0, inum, 'gdept_1d', gdept_1d ) ! ! reference z-coord. + CALL iom_rstput( 0, 0, inum, 'gdepw_1d', gdepw_1d ) + CALL iom_rstput( 0, 0, inum, 'e3t_1d' , e3t_1d ) + CALL iom_rstput( 0, 0, inum, 'e3w_1d' , e3w_1d ) + ! + CALL iom_rstput( 0, 0, inum, 'ocean_volume_t', ocean_volume_crs_t ) + CALL iom_rstput( 0, 0, inum, 'facvol_t' , facvol_t ) + CALL iom_rstput( 0, 0, inum, 'facvol_w' , facvol_w ) + CALL iom_rstput( 0, 0, inum, 'facsurfu' , facsurfu ) + CALL iom_rstput( 0, 0, inum, 'facsurfv' , facsurfv ) + CALL iom_rstput( 0, 0, inum, 'e1e2w_msk', e1e2w_msk ) + CALL iom_rstput( 0, 0, inum, 'e2e3u_msk', e2e3u_msk ) + CALL iom_rstput( 0, 0, inum, 'e1e3v_msk', e1e3v_msk ) + CALL iom_rstput( 0, 0, inum, 'e1e2w' , e1e2w_crs ) + CALL iom_rstput( 0, 0, inum, 'e2e3u' , e2e3u_crs ) + CALL iom_rstput( 0, 0, inum, 'e1e3v' , e1e3v_crs ) + CALL iom_rstput( 0, 0, inum, 'bt' , bt_crs ) + CALL iom_rstput( 0, 0, inum, 'r1_bt' , r1_bt_crs ) + ! + CALL iom_rstput( 0, 0, inum, 'crs_surfu_wgt', crs_surfu_wgt ) + CALL iom_rstput( 0, 0, inum, 'crs_surfv_wgt', crs_surfv_wgt ) + CALL iom_rstput( 0, 0, inum, 'crs_volt_wgt' , crs_volt_wgt ) + ! ! ============================ + ! ! close the files + ! ! ============================ + CALL iom_close( inum ) + ! + END SUBROUTINE crs_dom_wri + + + SUBROUTINE dom_uniq_crs( puniq, cdgrd ) + !!---------------------------------------------------------------------- + !! *** ROUTINE crs_dom_uniq_crs *** + !! + !! ** Purpose : identify unique point of a grid (TUVF) + !! + !! ** Method : 1) apply crs_lbc_lnk on an array with different values for each element + !! 2) check which elements have been changed + !!---------------------------------------------------------------------- + CHARACTER(len=1) , INTENT(in ) :: cdgrd ! + REAL(wp), DIMENSION(:,:), INTENT(inout) :: puniq ! + ! + REAL(wp) :: zshift ! shift value link to the process number + INTEGER :: ji ! dummy loop indices + LOGICAL , DIMENSION(jpi_crs,jpj_crs,1) :: lluniq ! store whether each point is unique or not + REAL(wp), DIMENSION(jpi_crs,jpj_crs ) :: ztstref + !!---------------------------------------------------------------------- + ! + ! build an array with different values for each element + ! in mpp: make sure that these values are different even between process + ! -> apply a shift value according to the process number + zshift = (jpi_crs+1.) * (jpj_crs+1.) * ( narea - 1 ) ! we should use jpimax_crs but not existing + ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi_crs*jpj_crs) /), (/ jpi_crs, jpj_crs /) ) + ! + puniq(:,:) = ztstref(:,:) ! default definition + CALL crs_lbc_lnk( puniq,cdgrd, 1.0_wp ) ! apply boundary conditions + lluniq(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed + ! + puniq(:,:) = REAL( COUNT( lluniq(:,:,:), dim = 3 ), wp ) + ! + END SUBROUTINE dom_uniq_crs + + !!====================================================================== + +END MODULE crsdomwri \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsfld.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsfld.F90 new file mode 100644 index 0000000..6bbb7c3 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsfld.F90 @@ -0,0 +1,243 @@ +MODULE crsfld + !!====================================================================== + !! *** MODULE crsdfld *** + !! Ocean coarsening : coarse ocean fields + !!===================================================================== + !! 2012-07 (J. Simeon, C. Calone, G. Madec, C. Ethe) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! crs_fld : create the standard output files for coarse grid and prep + !! other variables needed to be passed to TOP + !!---------------------------------------------------------------------- + USE crs + USE crsdom + USE crslbclnk + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + USE zdf_oce ! vertical physics: ocean fields + USE ldftra ! ocean active tracers: lateral diffusivity & EIV coefficients + USE zdfddm ! vertical physics: double diffusion + ! + USE in_out_manager ! I/O manager + USE iom ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + PUBLIC crs_fld ! routines called by step.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: crsfld.F90 13472 2020-09-16 13:05:19Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_fld( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE crs_fld *** + !! + !! ** Purpose : Basic output of coarsened dynamics and tracer fields + !! NETCDF format is used by default + !! 1. Accumulate in time the dimensionally-weighted fields + !! 2. At time of output, rescale [1] by dimension and time + !! to yield the spatial and temporal average. + !! See. sbcmod.F90 + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kmm ! time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: z2dcrsu, z2dcrsv ! local scalars + REAL(wp) :: zztmp ! - - + ! + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, ze3w ! 3D workspace for e3 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zt , zs , z3d + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk) :: zt_crs, zs_crs + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('crs_fld') + + ! Depth work arrrays + DO jk = 1 , jpk + ze3t(:,:,jk) = e3t(:,:,jk,Kmm) + ze3u(:,:,jk) = e3u(:,:,jk,Kmm) + ze3v(:,:,jk) = e3v(:,:,jk,Kmm) + ze3w(:,:,jk) = e3w(:,:,jk,Kmm) + END DO + + IF( kt == nit000 ) THEN + tsn_crs (:,:,:,:) = 0._wp ! temp/sal array, now + un_crs (:,:,: ) = 0._wp ! u-velocity + vn_crs (:,:,: ) = 0._wp ! v-velocity + wn_crs (:,:,: ) = 0._wp ! w + avs_crs (:,:,: ) = 0._wp ! avt + hdivn_crs(:,:,: ) = 0._wp ! hdiv + sshn_crs (:,: ) = 0._wp ! ssh + utau_crs (:,: ) = 0._wp ! taux + vtau_crs (:,: ) = 0._wp ! tauy + wndm_crs (:,: ) = 0._wp ! wind speed + qsr_crs (:,: ) = 0._wp ! qsr + emp_crs (:,: ) = 0._wp ! emp + emp_b_crs(:,: ) = 0._wp ! emp + rnf_crs (:,: ) = 0._wp ! runoff + fr_i_crs (:,: ) = 0._wp ! ice cover + ENDIF + + CALL iom_swap( "nemo_crs" ) ! swap on the coarse grid + + ! 2. Coarsen fields at each time step + ! -------------------------------------------------------- + + ! Temperature + zt(:,:,:) = ts(:,:,:,jp_tem,Kmm) ; zt_crs(:,:,:) = 0._wp + CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) + tsn_crs(:,:,:,jp_tem) = zt_crs(:,:,:) + + CALL iom_put( "toce", tsn_crs(:,:,:,jp_tem) ) ! temp + CALL iom_put( "sst" , tsn_crs(:,:,1,jp_tem) ) ! sst + + + ! Salinity + zs(:,:,:) = ts(:,:,:,jp_sal,Kmm) ; zs_crs(:,:,:) = 0._wp + CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) + tsn_crs(:,:,:,jp_sal) = zt_crs(:,:,:) + + CALL iom_put( "soce" , tsn_crs(:,:,:,jp_sal) ) ! sal + CALL iom_put( "sss" , tsn_crs(:,:,1,jp_sal) ) ! sss + + ! U-velocity + CALL crs_dom_ope( CASTSP(uu(:,:,:,Kmm)), 'SUM', 'U', umask, un_crs, p_e12=CASTDP(e2u), p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) + ! + zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zt(ji,jj,jk) = uu(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) ) + zs(ji,jj,jk) = uu(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) ) + END_3D + CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=CASTDP(e2u), p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) + CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=CASTDP(e2u), p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) + + CALL iom_put( "uoce" , un_crs ) ! i-current + CALL iom_put( "uocet" , zt_crs ) ! uT + CALL iom_put( "uoces" , zs_crs ) ! uS + + ! V-velocity + CALL crs_dom_ope( CASTSP(vv(:,:,:,Kmm)), 'SUM', 'V', vmask, vn_crs, p_e12=CASTDP(e1v), p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) + ! + zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zt(ji,jj,jk) = vv(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) ) + zs(ji,jj,jk) = vv(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) ) + END_3D + CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=CASTDP(e1v), p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) + CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=CASTDP(e1v), p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) + + CALL iom_put( "voce" , vn_crs ) ! i-current + CALL iom_put( "vocet" , zt_crs ) ! vT + CALL iom_put( "voces" , zs_crs ) ! vS + + IF( iom_use( "ke") ) THEN ! kinetic energy + z3d(:,:,jk) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zztmp = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + z3d(ji,jj,jk) = 0.25_wp * zztmp * ( & + & uu(ji-1,jj,jk,Kmm)**2 * e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) & + & + uu(ji ,jj,jk,Kmm)**2 * e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) & + & + vv(ji,jj-1,jk,Kmm)**2 * e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) & + & + vv(ji,jj ,jk,Kmm)**2 * e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) ) + END_3D + CALL lbc_lnk( 'crsfld', z3d, 'T', 1.0_wp ) + ! + CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) + CALL iom_put( "ke", zt_crs ) + ENDIF + ! Horizontal divergence ( following OCE/DYN/divhor.F90 ) + DO jk = 1, jpkm1 + DO ji = 2, jpi_crsm1 + DO jj = 2, jpj_crsm1 + IF( tmask_crs(ji,jj,jk ) > 0 ) THEN + z2dcrsu = ( un_crs(ji ,jj ,jk) * crs_surfu_wgt(ji ,jj ,jk) ) & + & - ( un_crs(ji-1,jj ,jk) * crs_surfu_wgt(ji-1,jj ,jk) ) + z2dcrsv = ( vn_crs(ji ,jj ,jk) * crs_surfv_wgt(ji ,jj ,jk) ) & + & - ( vn_crs(ji ,jj-1,jk) * crs_surfv_wgt(ji ,jj-1,jk) ) + ! + hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) / crs_volt_wgt(ji,jj,jk) + ENDIF + END DO + END DO + END DO + CALL crs_lbc_lnk( hdivn_crs, 'T', 1.0_wp ) + ! + CALL iom_put( "hdiv", hdivn_crs ) + + + ! W-velocity + IF( ln_crs_wn ) THEN + CALL crs_dom_ope( ww, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0_wp ) + ! CALL crs_dom_ope( ww, 'VOL', 'W', tmask, wn_crs, p_e12=e1e2t, p_e3=ze3w ) + ELSE + wn_crs(:,:,jpk) = 0._wp + DO jk = jpkm1, 1, -1 + wn_crs(:,:,jk) = wn_crs(:,:,jk+1) - e3t_crs(:,:,jk) * hdivn_crs(:,:,jk) + ENDDO + ENDIF + CALL iom_put( "woce", wn_crs ) ! vertical velocity + ! free memory + + ! avs + SELECT CASE ( nn_crs_kz ) + CASE ( 0 ) + CALL crs_dom_ope( avt, 'VOL', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + CALL crs_dom_ope( avs, 'VOL', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + CASE ( 1 ) + CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + CALL crs_dom_ope( avs, 'MAX', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + CASE ( 2 ) + CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + CALL crs_dom_ope( avs, 'MIN', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) + END SELECT + ! + CALL iom_put( "avt", avt_crs ) ! Kz on T + CALL iom_put( "avs", avs_crs ) ! Kz on S + + ! sbc fields + CALL crs_dom_ope( CASTSP(ssh(:,:,Kmm)) , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t , psgn=1.0_wp ) + CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=CASTDP(e2u) , p_surf_crs=e2u_crs , psgn=1.0_wp ) + CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=CASTDP(e1v) , p_surf_crs=e1v_crs , psgn=1.0_wp ) + CALL crs_dom_ope( wndm , 'SUM', 'T', tmask, wndm_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( rnf , 'MAX', 'T', tmask, rnf_crs , psgn=1.0_wp ) + CALL crs_dom_ope( qsr , 'SUM', 'T', tmask, qsr_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( emp , 'SUM', 'T', tmask, emp_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( sfx , 'SUM', 'T', tmask, sfx_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) + + CALL iom_put( "ssh" , sshn_crs ) ! ssh output + CALL iom_put( "utau" , utau_crs ) ! i-tau output + CALL iom_put( "vtau" , vtau_crs ) ! j-tau output + CALL iom_put( "wspd" , wndm_crs ) ! wind speed output + CALL iom_put( "runoffs" , rnf_crs ) ! runoff output + CALL iom_put( "qsr" , qsr_crs ) ! qsr output + CALL iom_put( "empmr" , emp_crs ) ! water flux output + CALL iom_put( "saltflx" , sfx_crs ) ! salt flux output + CALL iom_put( "ice_cover", fr_i_crs ) ! ice cover output + + ! + CALL iom_swap( "nemo" ) ! return back on high-resolution grid + ! + IF( ln_timing ) CALL timing_stop('crs_fld') + ! + END SUBROUTINE crs_fld + + !!====================================================================== +END MODULE crsfld \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsini.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsini.F90 new file mode 100644 index 0000000..5f2ab0e --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crsini.F90 @@ -0,0 +1,248 @@ +MODULE crsini + !!====================================================================== + !! *** MODULE crsini *** + !! Manage the grid coarsening module initialization + !!====================================================================== + !! History 2012-05 (J. Simeon, G. Madec, C. Ethe, C. Calone) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! crs_init : + !!---------------------------------------------------------------------- + USE par_kind, ONLY: wp + USE par_oce ! For parameter jpi,jpj + USE dom_oce ! For parameters in par_oce + USE crs ! Coarse grid domain + USE phycst, ONLY: omega, rad ! physical constants + USE crsdom + USE crsdomwri + USE crslbclnk + ! + USE iom + USE in_out_manager + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + PUBLIC crs_init ! called by nemogcm.F90 module + + !! * Substitutions +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: crsini.F90 13237 2020-07-03 09:12:53Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_init( Kmm ) + !!------------------------------------------------------------------- + !! *** SUBROUTINE crs_init + !! ** Purpose : Initialization of the grid coarsening module + !! 1. Read namelist + !! X2. MOVE TO crs_dom.F90 Set the domain definitions for coarse grid + !! a. Define the coarse grid starting/ending indices on parent grid + !! Here is where the T-pivot or F-pivot grids are discerned + !! b. TODO. Include option for north-centric or equator-centric binning. + !! (centered only for odd reduction factors; even reduction bins bias equator to the south) + !! 3. Mask and mesh creation. => calls to crsfun + !! a. Use crsfun_mask to generate tmask,umask, vmask, fmask. + !! b. Use crsfun_coordinates to get coordinates + !! c. Use crsfun_UV to get horizontal scale factors + !! d. Use crsfun_TW to get initial vertical scale factors + !! 4. Volumes and weights jes.... TODO. Updates for vvl? Where to do this? crsstp.F90? + !! a. Calculate initial coarse grid box volumes: pvol_T, pvol_W + !! b. Calculate initial coarse grid surface-averaging weights + !! c. Calculate initial coarse grid volume-averaging weights + !! + !! X5. MOVE TO crs_dom_wri.F90 Using iom_rstput output the initial meshmask. + !! ?. Another set of "masks" to generate + !! are the u- and v- surface areas for U- and V- area-weighted means. + !! Need to put this somewhere in section 3? + !! jes. What do to about the vvl? GM. could separate the weighting (denominator), so + !! output C*dA or C*dV as summation not mran, then do mean (division) at moment of output. + !! As is, crsfun takes into account vvl. + !! Talked about pre-setting the surface array to avoid IF/ENDIF and division. + !! But have then to make that preset array here and elsewhere. + !! that is called every timestep... + !! + !! - Read in pertinent data ? + !!------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! time level index + ! + INTEGER :: ji,jj,jk ! dummy indices + INTEGER :: ierr ! allocation error status + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, ze3w + + NAMELIST/namcrs/ nn_factx, nn_facty, nn_binref, ln_msh_crs, nn_crs_kz, ln_crs_wn + !!---------------------------------------------------------------------- + ! + !--------------------------------------------------------- + ! 1. Read Namelist file + !--------------------------------------------------------- + ! + READ ( numnam_ref, namcrs, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in reference namelist' ) + READ ( numnam_cfg, namcrs, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcrs in configuration namelist' ) + IF(lwm) WRITE ( numond, namcrs ) + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'crs_init : Initializing the grid coarsening module' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) ' Namelist namcrs ' + WRITE(numout,*) ' coarsening factor in i-direction nn_factx = ', nn_factx + WRITE(numout,*) ' coarsening factor in j-direction nn_facty = ', nn_facty + WRITE(numout,*) ' bin centering preference nn_binref = ', nn_binref + WRITE(numout,*) ' create a mesh file (=T) ln_msh_crs = ', ln_msh_crs + WRITE(numout,*) ' type of Kz coarsening (0,1,2) nn_crs_kz = ', nn_crs_kz + WRITE(numout,*) ' ww coarsened or computed using hdiv ln_crs_wn = ', ln_crs_wn + ENDIF + + rfactx_r = 1. / nn_factx + rfacty_r = 1. / nn_facty + + !--------------------------------------------------------- + ! 2. Define Global Dimensions of the coarsened grid + !--------------------------------------------------------- + CALL crs_dom_def + + !--------------------------------------------------------- + ! 3. Mask and Mesh + !--------------------------------------------------------- + + ! Set up the masks and meshes + + ! 3.a. Get the masks + + CALL crs_dom_msk + + + ! 3.b. Get the coordinates + ! Odd-numbered reduction factor, center coordinate on T-cell + ! Even-numbered reduction factor, center coordinate on U-,V- faces or f-corner. + ! + IF ( nresty /= 0 .AND. nrestx /= 0 ) THEN + CALL crs_dom_coordinates( gphit, glamt, 'T', gphit_crs, glamt_crs ) + CALL crs_dom_coordinates( gphiu, glamu, 'U', gphiu_crs, glamu_crs ) + CALL crs_dom_coordinates( gphiv, glamv, 'V', gphiv_crs, glamv_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) + ELSEIF ( nresty /= 0 .AND. nrestx == 0 ) THEN + CALL crs_dom_coordinates( gphiu, glamu, 'T', gphit_crs, glamt_crs ) + CALL crs_dom_coordinates( gphiu, glamu, 'U', gphiu_crs, glamu_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'V', gphiv_crs, glamv_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) + ELSEIF ( nresty == 0 .AND. nrestx /= 0 ) THEN + CALL crs_dom_coordinates( gphiv, glamv, 'T', gphit_crs, glamt_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'U', gphiu_crs, glamu_crs ) + CALL crs_dom_coordinates( gphiv, glamv, 'V', gphiv_crs, glamv_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) + ELSE + CALL crs_dom_coordinates( gphif, glamf, 'T', gphit_crs, glamt_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'U', gphiu_crs, glamu_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'V', gphiv_crs, glamv_crs ) + CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) + ENDIF + + + ! 3.c. Get the horizontal mesh + + ! 3.c.1 Horizontal scale factors + + CALL crs_dom_hgr( e1t, e2t, 'T', e1t_crs, e2t_crs ) + CALL crs_dom_hgr( e1u, CASTDP(e2u), 'U', e1u_crs, e2u_crs ) + CALL crs_dom_hgr( CASTDP(e1v), e2v, 'V', e1v_crs, e2v_crs ) + CALL crs_dom_hgr( e1f, e2f, 'F', e1f_crs, e2f_crs ) + + e1e2t_crs(:,:) = e1t_crs(:,:) * e2t_crs(:,:) + + + ! 3.c.2 Coriolis factor + +!!gm Not sure CRS needs Coriolis parameter.... +!!gm If needed, then update this to have Coriolis at both f- and t-points + + ff_crs(:,:) = 2. * omega * SIN( rad * gphif_crs(:,:) ) + + CALL ctl_warn( 'crsini: CAUTION, CRS only designed for Coriolis defined on the sphere' ) + + + ! 3.d.1 mbathy ( vertical k-levels of bathymetry ) + + CALL crs_dom_bat + + ! + DO jk = 1, jpk + ze3t(:,:,jk) = e3t(:,:,jk,Kmm) + ze3u(:,:,jk) = e3u(:,:,jk,Kmm) + ze3v(:,:,jk) = e3v(:,:,jk,Kmm) + ze3w(:,:,jk) = e3w(:,:,jk,Kmm) + END DO + + ! 3.d.2 Surfaces + CALL crs_dom_sfc( tmask, 'W', e1e2w_crs, e1e2w_msk, p_e1=CASTSP(e1t), p_e2=CASTSP(e2t) ) + CALL crs_dom_sfc( umask, 'U', e2e3u_crs, e2e3u_msk, p_e2=e2u, p_e3=ze3u ) + CALL crs_dom_sfc( vmask, 'V', e1e3v_crs, e1e3v_msk, p_e1=e1v, p_e3=ze3v ) + + facsurfu(:,:,:) = umask_crs(:,:,:) * e2e3u_msk(:,:,:) / e2e3u_crs(:,:,:) + facsurfv(:,:,:) = vmask_crs(:,:,:) * e1e3v_msk(:,:,:) / e1e3v_crs(:,:,:) + + ! 3.d.3 Vertical scale factors + ! + CALL crs_dom_e3( e1t, e2t, ze3t, e1e2w_crs, 'T', tmask, e3t_crs, e3t_max_crs) + CALL crs_dom_e3( e1u, CASTDP(e2u), ze3u, e2e3u_crs, 'U', umask, e3u_crs, e3u_max_crs) + CALL crs_dom_e3( CASTDP(e1v), e2v, ze3v, e1e3v_crs, 'V', vmask, e3v_crs, e3v_max_crs) + CALL crs_dom_e3( e1t, e2t, ze3w, e1e2w_crs, 'W', tmask, e3w_crs, e3w_max_crs) + + ! Replace 0 by e3t_0 or e3w_0 + DO jk = 1, jpk + DO ji = 1, jpi_crs + DO jj = 1, jpj_crs + IF( e3t_crs(ji,jj,jk) == 0._wp ) e3t_crs(ji,jj,jk) = e3t_1d(jk) + IF( e3w_crs(ji,jj,jk) == 0._wp ) e3w_crs(ji,jj,jk) = e3w_1d(jk) + IF( e3u_crs(ji,jj,jk) == 0._wp ) e3u_crs(ji,jj,jk) = e3t_1d(jk) + IF( e3v_crs(ji,jj,jk) == 0._wp ) e3v_crs(ji,jj,jk) = e3t_1d(jk) + ENDDO + ENDDO + ENDDO + + ! 3.d.3 Vertical depth (meters) + CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=ze3t, psgn=1.0_wp ) + CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0_wp ) + + + !--------------------------------------------------------- + ! 4. Coarse grid ocean volume and averaging weights + !--------------------------------------------------------- + ! 4.a. Ocean volume or area unmasked and masked + CALL crs_dom_facvol( tmask, 'T', e1t, e2t, ze3t, ocean_volume_crs_t, facvol_t ) + ! + bt_crs(:,:,:) = ocean_volume_crs_t(:,:,:) * facvol_t(:,:,:) + ! + r1_bt_crs(:,:,:) = 0._wp + WHERE( bt_crs /= 0._wp ) r1_bt_crs(:,:,:) = 1._wp / bt_crs(:,:,:) + + CALL crs_dom_facvol( tmask, 'W', e1t, e2t, ze3w, ocean_volume_crs_w, facvol_w ) + ! + !--------------------------------------------------------- + ! 5. Write out coarse meshmask (see OCE/DOM/domwri.F90 for ideas later) + !--------------------------------------------------------- + + IF( ln_msh_crs ) THEN + CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain + CALL crs_dom_wri + CALL dom_grid_glo ! Return to parent grid domain + ENDIF + + !--------------------------------------------------------- + ! 7. Finish and clean-up + !--------------------------------------------------------- + ! + END SUBROUTINE crs_init + + !!====================================================================== +END MODULE crsini \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crslbclnk.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crslbclnk.F90 new file mode 100644 index 0000000..b7e4d19 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/CRS/crslbclnk.F90 @@ -0,0 +1,89 @@ +MODULE crslbclnk + !!====================================================================== + !! *** MODULE crslbclnk *** + !! A temporary solution for lbclnk for coarsened grid. + !! Ocean : lateral boundary conditions for grid coarsening + !!===================================================================== + !! History : ! 2012-06 (J. Simeon, G. Madec, C. Ethe, C. Calone) Original code + !!---------------------------------------------------------------------- + USE par_kind, ONLY: wp + USE dom_oce + USE crs + ! + USE lbclnk + USE in_out_manager + + INTERFACE crs_lbc_lnk + MODULE PROCEDURE crs_lbc_lnk_3d, crs_lbc_lnk_2d + END INTERFACE + + PUBLIC crs_lbc_lnk + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: crslbclnk.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_lbc_lnk_3d( pt3d1, cd_type1, psgn, kfillmode, pfillval ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE crs_lbc_lnk *** + !! + !! ** Purpose : set lateral boundary conditions for coarsened grid + !! + !! ** Method : Swap domain indices from full to coarse domain + !! before arguments are passed directly to lbc_lnk. + !! Upon exiting, switch back to full domain indices. + !!---------------------------------------------------------------------- + CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! grid type + REAL(wp) , INTENT(in ) :: psgn ! control of the sign + REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1 ! 3D array on which the lbc is applied + INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = cst) + REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + ! + LOGICAL :: ll_grid_crs + !!---------------------------------------------------------------------- + ! + ll_grid_crs = ( jpi == jpi_crs ) + ! + IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain + ! + CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn, kfillmode = kfillmode, pfillval = pfillval ) + ! + IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain + ! + END SUBROUTINE crs_lbc_lnk_3d + + + SUBROUTINE crs_lbc_lnk_2d(pt2d, cd_type, psgn, kfillmode, pfillval ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE crs_lbc_lnk *** + !! + !! ** Purpose : set lateral boundary conditions for coarsened grid + !! + !! ** Method : Swap domain indices from full to coarse domain + !! before arguments are passed directly to lbc_lnk. + !! Upon exiting, switch back to full domain indices. + !!---------------------------------------------------------------------- + CHARACTER(len=1) , INTENT(in ) :: cd_type ! grid type + REAL(wp) , INTENT(in ) :: psgn ! control of the sign + REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied + INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + ! + LOGICAL :: ll_grid_crs + !!---------------------------------------------------------------------- + ! + ll_grid_crs = ( jpi == jpi_crs ) + ! + IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain + ! + CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn, kfillmode = kfillmode, pfillval = pfillval ) + ! + IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain + ! + END SUBROUTINE crs_lbc_lnk_2d + + !!====================================================================== +END MODULE crslbclnk \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/dia25h.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/dia25h.F90 new file mode 100644 index 0000000..411a3f5 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/dia25h.F90 @@ -0,0 +1,322 @@ +MODULE dia25h + !!====================================================================== + !! *** MODULE diaharm *** + !! Harmonic analysis of tidal constituents + !!====================================================================== + !! History : 3.6 ! 2014 (E O'Dea) Original code + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain + USE zdf_oce ! ocean vertical physics + USE zdfgls , ONLY : hmxl_n + ! + USE in_out_manager ! I/O units + USE iom ! I/0 library + USE wet_dry + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_25h_init ! routine called by nemogcm.F90 + PUBLIC dia_25h ! routine called by diawri.F90 + + LOGICAL, PUBLIC :: ln_dia25h !: 25h mean output + + ! variables for calculating 25-hourly means + INTEGER , SAVE :: cnt_25h ! Counter for 25 hour means + REAL(wp), SAVE :: r1_25 = 0.04_wp ! =1/25 + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: tn_25h , sn_25h + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: sshn_25h + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: un_25h , vn_25h , wn_25h + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avt_25h , avm_25h + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: en_25h , rmxln_25h + +!! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dia25h.F90 15249 2021-09-13 09:59:09Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_25h_init( Kbb ) + !!--------------------------------------------------------------------------- + !! *** ROUTINE dia_25h_init *** + !! + !! ** Purpose: Initialization of 25h mean namelist + !! + !! ** Method : Read namelist + !!--------------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb ! Time level index + ! + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: ierror ! Local integer for memory allocation + INTEGER :: ji, jj, jk + ! + NAMELIST/nam_dia25h/ ln_dia25h + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, nam_dia25h, IOSTAT=ios, ERR= 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_dia25h in reference namelist' ) + READ ( numnam_cfg, nam_dia25h, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_dia25h in configuration namelist' ) + IF(lwm) WRITE ( numond, nam_dia25h ) + + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'dia_25h_init : Output 25 hour mean diagnostics' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist nam_dia25h : set 25h outputs ' + WRITE(numout,*) ' Switch for 25h diagnostics (T) or not (F) ln_dia25h = ', ln_dia25h + ENDIF + IF( .NOT. ln_dia25h ) RETURN + ! ------------------- ! + ! 1 - Allocate memory ! + ! ------------------- ! + ! ! ocean arrays + ALLOCATE( tn_25h (A2D(0),jpk), sn_25h (A2D(0),jpk), sshn_25h(A2D(0)) , & + & un_25h (A2D(0),jpk), vn_25h (A2D(0),jpk), wn_25h(A2D(0),jpk), & + & avt_25h(A2D(0),jpk), avm_25h(A2D(0),jpk), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'dia_25h: unable to allocate ocean arrays' ) ; RETURN + ENDIF + IF( ln_zdftke ) THEN ! TKE physics + ALLOCATE( en_25h(A2D(0),jpk), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'dia_25h: unable to allocate en_25h' ) ; RETURN + ENDIF + ENDIF + IF( ln_zdfgls ) THEN ! GLS physics + ALLOCATE( en_25h(A2D(0),jpk), rmxln_25h(A2D(0),jpk), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'dia_25h: unable to allocate en_25h and rmxln_25h' ) ; RETURN + ENDIF + ENDIF + ! ------------------------- ! + ! 2 - Assign Initial Values ! + ! ------------------------- ! + cnt_25h = 1 ! sets the first value of sum at timestep 1 (note - should strictly be at timestep zero so before values used where possible) + DO_3D( 0, 0, 0, 0, 1, jpk ) + tn_25h (ji,jj,jk) = ts (ji,jj,jk,jp_tem,Kbb) + sn_25h (ji,jj,jk) = ts (ji,jj,jk,jp_sal,Kbb) + un_25h (ji,jj,jk) = uu (ji,jj,jk,Kbb) + vn_25h (ji,jj,jk) = vv (ji,jj,jk,Kbb) + avt_25h(ji,jj,jk) = avt(ji,jj,jk) + avm_25h(ji,jj,jk) = avm(ji,jj,jk) + END_3D + DO_2D( 0, 0, 0, 0 ) + sshn_25h(ji,jj) = ssh(ji,jj,Kbb) + END_2D + IF( ln_zdftke ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + en_25h(ji,jj,jk) = en(ji,jj,jk) + END_3D + ENDIF + IF( ln_zdfgls ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + en_25h (ji,jj,jk) = en (ji,jj,jk) + rmxln_25h(ji,jj,jk) = hmxl_n(ji,jj,jk) + END_3D + ENDIF +#if defined key_si3 + CALL ctl_stop('STOP', 'dia_25h not setup yet to do tidemean ice') +#endif + ! + END SUBROUTINE dia_25h_init + + + SUBROUTINE dia_25h( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_25h *** + !! + !! ** Purpose : Write diagnostics with M2/S2 tide removed + !! + !! ** Method : 25hr mean outputs for shelf seas + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !! + INTEGER :: ji, jj, jk + INTEGER :: iyear0, nimonth0,iday0 ! start year,imonth,day + LOGICAL :: ll_print = .FALSE. ! =T print and flush numout + REAL(dp) :: zsto, zout, zmax, zjulian, zmdi ! local scalars + INTEGER :: i_steps ! no of timesteps per hour + REAL(wp), DIMENSION(A2D(0) ) :: zw2d, un_dm, vn_dm ! workspace + REAL(wp), DIMENSION(A2D(0),jpk) :: zw3d ! workspace + REAL(wp), DIMENSION(A2D(0),3) :: zwtmb ! workspace + !!---------------------------------------------------------------------- + + ! 0. Initialisation + ! ----------------- + ! Define frequency of summing to create 25 h mean + IF( MOD( 3600,NINT(rn_Dt) ) == 0 ) THEN + i_steps = 3600/NINT(rn_Dt) + ELSE + CALL ctl_stop('STOP', 'dia_wri_tide: timestep must give MOD(3600,rn_Dt) = 0 otherwise no hourly values are possible') + ENDIF + + ! local variable for debugging + ll_print = ll_print .AND. lwp + + ! wn_25h could not be initialised in dia_25h_init, so we do it here instead + IF( kt == nn_it000 ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + wn_25h(ji,jj,jk) = ww(ji,jj,jk) + END_3D + ENDIF + + ! Sum of 25 hourly instantaneous values to give a 25h mean from 24hours every day + IF( MOD( kt, i_steps ) == 0 .AND. kt /= nn_it000 ) THEN + + IF (lwp) THEN + WRITE(numout,*) 'dia_wri_tide : Summing instantaneous hourly diagnostics at timestep ',kt + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + + DO_3D( 0, 0, 0, 0, 1, jpk ) + tn_25h (ji,jj,jk) = tn_25h (ji,jj,jk) + ts (ji,jj,jk,jp_tem,Kmm) + sn_25h (ji,jj,jk) = sn_25h (ji,jj,jk) + ts (ji,jj,jk,jp_sal,Kmm) + un_25h (ji,jj,jk) = un_25h (ji,jj,jk) + uu (ji,jj,jk,Kmm) + vn_25h (ji,jj,jk) = vn_25h (ji,jj,jk) + vv (ji,jj,jk,Kmm) + wn_25h (ji,jj,jk) = wn_25h (ji,jj,jk) + ww (ji,jj,jk) + avt_25h (ji,jj,jk) = avt_25h (ji,jj,jk) + avt(ji,jj,jk) + avm_25h (ji,jj,jk) = avm_25h (ji,jj,jk) + avm(ji,jj,jk) + END_3D + DO_2D( 0, 0, 0, 0 ) + sshn_25h(ji,jj) = sshn_25h(ji,jj) + ssh(ji,jj,Kmm) + END_2D + IF( ln_zdftke ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + en_25h(ji,jj,jk) = en_25h(ji,jj,jk) + en(ji,jj,jk) + END_3D + ENDIF + IF( ln_zdfgls ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + en_25h (ji,jj,jk) = en_25h (ji,jj,jk) + en (ji,jj,jk) + rmxln_25h(ji,jj,jk) = rmxln_25h(ji,jj,jk) + hmxl_n(ji,jj,jk) + END_3D + ENDIF + cnt_25h = cnt_25h + 1 + ! + IF (lwp) THEN + WRITE(numout,*) 'dia_tide : Summed the following number of hourly values so far',cnt_25h + ENDIF + ! + ENDIF ! MOD( kt, i_steps ) == 0 + + ! Write data for 25 hour mean output streams + IF( cnt_25h == 25 .AND. MOD( kt, i_steps*24) == 0 .AND. kt /= nn_it000 ) THEN + ! + IF(lwp) THEN + WRITE(numout,*) 'dia_wri_tide : Writing 25 hour mean tide diagnostics at timestep', kt + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + ! + tn_25h (:,:,:) = tn_25h (:,:,:) * r1_25 + sn_25h (:,:,:) = sn_25h (:,:,:) * r1_25 + sshn_25h(:,:) = sshn_25h(:,:) * r1_25 + un_25h (:,:,:) = un_25h (:,:,:) * r1_25 + vn_25h (:,:,:) = vn_25h (:,:,:) * r1_25 + wn_25h (:,:,:) = wn_25h (:,:,:) * r1_25 + avt_25h (:,:,:) = avt_25h (:,:,:) * r1_25 + avm_25h (:,:,:) = avm_25h (:,:,:) * r1_25 + IF( ln_zdftke ) THEN + en_25h(:,:,:) = en_25h(:,:,:) * r1_25 + ENDIF + IF( ln_zdfgls ) THEN + en_25h (:,:,:) = en_25h (:,:,:) * r1_25 + rmxln_25h(:,:,:) = rmxln_25h(:,:,:) * r1_25 + ENDIF + ! + IF(lwp) WRITE(numout,*) 'dia_wri_tide : Mean calculated by dividing 25 hour sums and writing output' + zmdi=1.e+20 !missing data indicator for masking + ! write tracers (instantaneous) + DO_3D( 0, 0, 0, 0, 1, jpk ) + zw3d(ji,jj,jk) = tn_25h(ji,jj,jk)*tmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END_3D + CALL iom_put("temper25h", zw3d) ! potential temperature + DO_3D( 0, 0, 0, 0, 1, jpk ) + zw3d(ji,jj,jk) = sn_25h(ji,jj,jk)*tmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END_3D + CALL iom_put( "salin25h", zw3d ) ! salinity + DO_2D( 0, 0, 0, 0 ) + zw2d(ji,jj) = sshn_25h(ji,jj)*tmask(ji,jj,1) + zmdi*(1.0-tmask(ji,jj,1)) + END_2D + IF( ll_wd ) THEN + CALL iom_put( "ssh25h", zw2d+ssh_ref ) ! sea surface + ELSE + CALL iom_put( "ssh25h", zw2d ) ! sea surface + ENDIF + ! Write velocities (instantaneous) + DO_3D( 0, 0, 0, 0, 1, jpk ) + zw3d(ji,jj,jk) = un_25h(ji,jj,jk)*umask(ji,jj,jk) + zmdi*(1.0-umask(ji,jj,jk)) + END_3D + CALL iom_put("vozocrtx25h", zw3d) ! i-current + DO_3D( 0, 0, 0, 0, 1, jpk ) + zw3d(ji,jj,jk) = vn_25h(ji,jj,jk)*vmask(ji,jj,jk) + zmdi*(1.0-vmask(ji,jj,jk)) + END_3D + CALL iom_put("vomecrty25h", zw3d ) ! j-current + DO_3D( 0, 0, 0, 0, 1, jpk ) + zw3d(ji,jj,jk) = wn_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END_3D + CALL iom_put("vovecrtz25h", zw3d ) ! k-current + ! Write vertical physics + DO_3D( 0, 0, 0, 0, 1, jpk ) + zw3d(ji,jj,jk) = avt_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END_3D + CALL iom_put("avt25h", zw3d ) ! diffusivity + DO_3D( 0, 0, 0, 0, 1, jpk ) + zw3d(ji,jj,jk) = avm_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END_3D + CALL iom_put("avm25h", zw3d) ! viscosity + IF( ln_zdftke ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + zw3d(ji,jj,jk) = en_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END_3D + CALL iom_put("tke25h", zw3d) ! tke + ENDIF + IF( ln_zdfgls ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + zw3d(ji,jj,jk) = en_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END_3D + CALL iom_put("tke25h", zw3d) ! tke + DO_3D( 0, 0, 0, 0, 1, jpk ) + zw3d(ji,jj,jk) = rmxln_25h(ji,jj,jk)*wmask(ji,jj,jk) + zmdi*(1.0-tmask(ji,jj,jk)) + END_3D + CALL iom_put( "mxln25h",zw3d) + ENDIF + ! + ! After the write reset the values to cnt=1 and sum values equal current value + DO_3D( 0, 0, 0, 0, 1, jpk ) + tn_25h (ji,jj,jk) = ts (ji,jj,jk,jp_tem,Kmm) + sn_25h (ji,jj,jk) = ts (ji,jj,jk,jp_sal,Kmm) + un_25h (ji,jj,jk) = uu (ji,jj,jk,Kmm) + vn_25h (ji,jj,jk) = vv (ji,jj,jk,Kmm) + wn_25h (ji,jj,jk) = ww (ji,jj,jk) + avt_25h (ji,jj,jk) = avt(ji,jj,jk) + avm_25h (ji,jj,jk) = avm(ji,jj,jk) + END_3D + DO_2D( 0, 0, 0, 0 ) + sshn_25h(ji,jj) = ssh(ji,jj,Kmm) + END_2D + IF( ln_zdftke ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + en_25h(ji,jj,jk) = en(ji,jj,jk) + END_3D + ENDIF + IF( ln_zdfgls ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + en_25h (ji,jj,jk) = en (ji,jj,jk) + rmxln_25h(ji,jj,jk) = hmxl_n(ji,jj,jk) + END_3D + ENDIF + cnt_25h = 1 + IF(lwp) WRITE(numout,*) 'dia_wri_tide : & + & After 25hr mean write, reset sum to current value and cnt_25h to one for overlapping average', cnt_25h + ENDIF ! cnt_25h .EQ. 25 .AND. MOD( kt, i_steps * 24) == 0 .AND. kt .NE. nn_it000 + ! + END SUBROUTINE dia_25h + + !!====================================================================== +END MODULE dia25h \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diaar5.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diaar5.F90 new file mode 100644 index 0000000..af124f7 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diaar5.F90 @@ -0,0 +1,422 @@ +MODULE diaar5 + !!====================================================================== + !! *** MODULE diaar5 *** + !! AR5 diagnostics + !!====================================================================== + !! History : 3.2 ! 2009-11 (S. Masson) Original code + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + merge TRC-TRA + !!---------------------------------------------------------------------- + !! dia_ar5 : AR5 diagnostics + !! dia_ar5_init : initialisation of AR5 diagnostics + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE eosbn2 ! equation of state (eos_bn2 routine) + USE phycst ! physical constant + USE in_out_manager ! I/O manager + USE zdfddm + USE zdf_oce + ! + USE lib_mpp ! distribued memory computing library + USE iom ! I/O manager library + USE fldread ! type FLD_N + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_ar5 ! routine called in step.F90 module + PUBLIC dia_ar5_alloc ! routine called in nemogcm.F90 module + PUBLIC dia_ar5_hst ! heat/salt transport + + REAL(wp) :: vol0 ! ocean volume (interior domain) + REAL(wp) :: area_tot ! total ocean surface (interior domain) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,: ) :: thick0 ! ocean thickness (interior domain) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sn0 ! initial salinity + + LOGICAL :: l_ar5 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diaar5.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + FUNCTION dia_ar5_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ar5_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: dia_ar5_alloc + !!---------------------------------------------------------------------- + ! + ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk), STAT=dia_ar5_alloc ) + ! + CALL mpp_sum ( 'diaar5', dia_ar5_alloc ) + IF( dia_ar5_alloc /= 0 ) CALL ctl_stop( 'STOP', 'dia_ar5_alloc: failed to allocate arrays' ) + ! + END FUNCTION dia_ar5_alloc + + + SUBROUTINE dia_ar5( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ar5 *** + !! + !! ** Purpose : compute and output some AR5 diagnostics + !!---------------------------------------------------------------------- + ! + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER, INTENT( in ) :: Kmm ! ocean time level index + ! + INTEGER :: ji, jj, jk, iks, ikb ! dummy loop arguments + REAL(wp) :: zvolssh, zvol, zssh_steric, zztmp, zarho, ztemp, zsal, zmass, zsst + REAL(wp) :: zaw, zbw, zrw + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zarea_ssh , zbotpres ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d, zpe ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d, zrhd, ztpot, zgdept ! 3D workspace (zgdept: needed to use the substitute) + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztsn ! 4D workspace + + !!-------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('dia_ar5') + + IF( kt == nit000 ) CALL dia_ar5_init + + IF( l_ar5 ) THEN + ALLOCATE( zarea_ssh(jpi,jpj), zbotpres(jpi,jpj), z2d(jpi,jpj) ) + ALLOCATE( zrhd(jpi,jpj,jpk) ) + ALLOCATE( ztsn(jpi,jpj,jpk,jpts) ) + zarea_ssh(:,:) = e1e2t(:,:) * ssh(:,:,Kmm) + ENDIF + ! + CALL iom_put( 'e2u' , e2u (:,:) ) + CALL iom_put( 'e1v' , e1v (:,:) ) + CALL iom_put( 'areacello', e1e2t(:,:) ) + ! + IF( iom_use( 'volcello' ) .OR. iom_use( 'masscello' ) ) THEN + zrhd(:,:,jpk) = 0._wp ! ocean volume ; rhd is used as workspace + DO jk = 1, jpkm1 + zrhd(:,:,jk) = e1e2t(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk) + END DO + DO jk = 1, jpk + z3d(:,:,jk) = rho0 * e3t(:,:,jk,Kmm) * tmask(:,:,jk) + END DO + CALL iom_put( 'volcello' , zrhd(:,:,:) ) ! WARNING not consistent with CMIP DR where volcello is at ca. 2000 + CALL iom_put( 'masscello' , z3d (:,:,:) ) ! ocean mass + ENDIF + ! + IF( iom_use( 'e3tb' ) ) THEN ! bottom layer thickness + DO_2D( 1, 1, 1, 1 ) + ikb = mbkt(ji,jj) + z2d(ji,jj) = e3t(ji,jj,ikb,Kmm) + END_2D + CALL iom_put( 'e3tb', z2d ) + ENDIF + ! + IF( iom_use( 'voltot' ) .OR. iom_use( 'sshtot' ) .OR. iom_use( 'sshdyn' ) ) THEN + ! ! total volume of liquid seawater + zvolssh =glob_sum( 'diaar5', CASTDP(zarea_ssh(:,:)) ) + zvol = vol0 + zvolssh + + CALL iom_put( 'voltot', zvol ) + CALL iom_put( 'sshtot', zvolssh / area_tot ) + CALL iom_put( 'sshdyn', ssh(:,:,Kmm) - (zvolssh / area_tot) ) + ! + ENDIF + + IF( iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) ) THEN + ! + ztsn(:,:,:,jp_tem) = ts(:,:,:,jp_tem,Kmm) ! thermosteric ssh + ztsn(:,:,:,jp_sal) = sn0(:,:,:) + ALLOCATE( zgdept(jpi,jpj,jpk) ) + DO jk = 1, jpk + zgdept(:,:,jk) = gdept(:,:,jk,Kmm) + END DO + CALL eos( CASTDP(ztsn), zrhd, zgdept) ! now in situ density using initial salinity + ! + zbotpres(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice + DO jk = 1, jpkm1 + zbotpres(:,:) = zbotpres(:,:) + e3t(:,:,jk,Kmm) * zrhd(:,:,jk) + END DO + IF( ln_linssh ) THEN + IF( ln_isfcav ) THEN + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + iks = mikt(ji,jj) + zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * zrhd(ji,jj,iks) + riceload(ji,jj) + END_2D + ELSE + zbotpres(:,:) = zbotpres(:,:) + ssh(:,:,Kmm) * zrhd(:,:,1) + END IF +!!gm +!!gm riceload should be added in both ln_linssh=T or F, no? +!!gm + END IF + ! + zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) ) + zssh_steric = - zarho / area_tot + CALL iom_put( 'sshthster', zssh_steric ) + + ! ! steric sea surface height + zbotpres(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice + DO jk = 1, jpkm1 + zbotpres(:,:) = zbotpres(:,:) + e3t(:,:,jk,Kmm) * rhd(:,:,jk) + END DO + IF( ln_linssh ) THEN + IF ( ln_isfcav ) THEN + DO ji = 1,jpi + DO jj = 1,jpj + iks = mikt(ji,jj) + zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * rhd(ji,jj,iks) + riceload(ji,jj) + END DO + END DO + ELSE + zbotpres(:,:) = zbotpres(:,:) + ssh(:,:,Kmm) * rhd(:,:,1) + END IF + END IF + ! + zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) ) + zssh_steric = - zarho / area_tot + CALL iom_put( 'sshsteric', zssh_steric ) + ! ! ocean bottom pressure + zztmp = rho0 * grav * 1.e-4_wp ! recover pressure from pressure anomaly and cover to dbar = 1.e4 Pa + zbotpres(:,:) = zztmp * ( zbotpres(:,:) + ssh(:,:,Kmm) + thick0(:,:) ) + CALL iom_put( 'botpres', zbotpres ) + ! + DEALLOCATE( zgdept ) + ! + ENDIF + + IF( iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) ) THEN + ! ! Mean density anomalie, temperature and salinity + ztsn(:,:,:,:) = 0._wp ! ztsn(:,:,1,jp_tem/sal) is used here as 2D Workspace for temperature & salinity + DO_3D( 1, 1, 1, 1, 1, jpkm1 ) + zztmp = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) + ztsn(ji,jj,1,jp_tem) = ztsn(ji,jj,1,jp_tem) + zztmp * ts(ji,jj,jk,jp_tem,Kmm) + ztsn(ji,jj,1,jp_sal) = ztsn(ji,jj,1,jp_sal) + zztmp * ts(ji,jj,jk,jp_sal,Kmm) + END_3D + + IF( ln_linssh ) THEN + IF( ln_isfcav ) THEN + DO ji = 1, jpi + DO jj = 1, jpj + iks = mikt(ji,jj) + ztsn(ji,jj,1,jp_tem) = ztsn(ji,jj,1,jp_tem) + zarea_ssh(ji,jj) * ts(ji,jj,iks,jp_tem,Kmm) + ztsn(ji,jj,1,jp_sal) = ztsn(ji,jj,1,jp_sal) + zarea_ssh(ji,jj) * ts(ji,jj,iks,jp_sal,Kmm) + END DO + END DO + ELSE + ztsn(:,:,1,jp_tem) = ztsn(:,:,1,jp_tem) + zarea_ssh(:,:) * ts(:,:,1,jp_tem,Kmm) + ztsn(:,:,1,jp_sal) = ztsn(:,:,1,jp_sal) + zarea_ssh(:,:) * ts(:,:,1,jp_sal,Kmm) + END IF + ENDIF + ! + ztemp =glob_sum( 'diaar5', CASTDP(ztsn(:,:,1,jp_tem)) ) + zsal =glob_sum( 'diaar5', CASTDP(ztsn(:,:,1,jp_sal)) ) + zmass = rho0 * ( zarho + zvol ) + ! + CALL iom_put( 'masstot', zmass ) + CALL iom_put( 'temptot', ztemp / zvol ) + CALL iom_put( 'saltot' , zsal / zvol ) + ! + ENDIF + + IF( ln_teos10 ) THEN ! ! potential temperature (TEOS-10 case) + IF( iom_use( 'toce_pot') .OR. iom_use( 'temptot_pot' ) .OR. iom_use( 'sst_pot' ) & + .OR. iom_use( 'ssttot' ) .OR. iom_use( 'tosmint_pot' ) ) THEN + ! + ALLOCATE( ztpot(jpi,jpj,jpk) ) + ztpot(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + ztpot(:,:,jk) =eos_pt_from_ct( CASTSP(ts(:,:,jk,jp_tem,Kmm)), CASTSP(ts(:,:,jk,jp_sal,Kmm)) ) + END DO + ! + CALL iom_put( 'toce_pot', ztpot(:,:,:) ) ! potential temperature (TEOS-10 case) + CALL iom_put( 'sst_pot' , ztpot(:,:,1) ) ! surface temperature + ! + IF( iom_use( 'temptot_pot' ) ) THEN ! Output potential temperature in case we use TEOS-10 + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 + z2d(:,:) = z2d(:,:) + e1e2t(:,:) * e3t(:,:,jk,Kmm) * ztpot(:,:,jk) + END DO + ztemp =glob_sum( 'diaar5', CASTDP(z2d(:,:)) ) + CALL iom_put( 'temptot_pot', ztemp / zvol ) + ENDIF + ! + IF( iom_use( 'ssttot' ) ) THEN ! Output potential temperature in case we use TEOS-10 + zsst = glob_sum( 'diaar5', e1e2t(:,:) * ztpot(:,:,1) ) + CALL iom_put( 'ssttot', zsst / area_tot ) + ENDIF + ! Vertical integral of temperature + IF( iom_use( 'tosmint_pot') ) THEN + z2d(:,:) = 0._wp + DO_3D( 1, 1, 1, 1, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + rho0 * e3t(ji,jj,jk,Kmm) * ztpot(ji,jj,jk) + END_3D + CALL iom_put( 'tosmint_pot', z2d ) + ENDIF + DEALLOCATE( ztpot ) + ENDIF + ELSE + IF( iom_use('ssttot') ) THEN ! Output sst in case we use EOS-80 + zsst = glob_sum( 'diaar5', e1e2t(:,:) * ts(:,:,1,jp_tem,Kmm) ) + CALL iom_put('ssttot', zsst / area_tot ) + ENDIF + ENDIF + + IF( iom_use( 'tnpeo' )) THEN + ! Work done against stratification by vertical mixing + ! Exclude points where rn2 is negative as convection kicks in here and + ! work is not being done against stratification + ALLOCATE( zpe(jpi,jpj) ) + zpe(:,:) = 0._wp + IF( ln_zdfddm ) THEN + DO_3D( 1, 1, 1, 1, 2, jpk ) + IF( rn2(ji,jj,jk) > 0._wp ) THEN + zrw = ( gdept(ji,jj,jk,Kmm) - gdepw(ji,jj,jk,Kmm) ) / e3w(ji,jj,jk,Kmm) + ! + zaw = rab_n(ji,jj,jk,jp_tem) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_tem)* zrw + zbw = rab_n(ji,jj,jk,jp_sal) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_sal)* zrw + ! + zpe(ji, jj) = zpe(ji,jj) & + & - grav * ( avt(ji,jj,jk) * zaw * (ts(ji,jj,jk-1,jp_tem,Kmm) - ts(ji,jj,jk,jp_tem,Kmm) ) & + & - avs(ji,jj,jk) * zbw * (ts(ji,jj,jk-1,jp_sal,Kmm) - ts(ji,jj,jk,jp_sal,Kmm) ) ) + ENDIF + END_3D + ELSE + DO_3D( 1, 1, 1, 1, 1, jpk ) + zpe(ji,jj) = zpe(ji,jj) + avt(ji,jj,jk) * MIN(0._wp,rn2(ji,jj,jk)) * rho0 * e3w(ji,jj,jk,Kmm) + END_3D + ENDIF + CALL iom_put( 'tnpeo', zpe ) + DEALLOCATE( zpe ) + ENDIF + + IF( l_ar5 ) THEN + DEALLOCATE( zarea_ssh , zbotpres, z2d ) + DEALLOCATE( ztsn ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('dia_ar5') + ! + END SUBROUTINE dia_ar5 + + + SUBROUTINE dia_ar5_hst( ktra, cptr, puflx, pvflx ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ar5_htr *** + !!---------------------------------------------------------------------- + !! Wrapper for heat transport calculations + !! Called from all advection and/or diffusion routines + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ktra ! tracer index + CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf' + REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: puflx ! u-flux of advection/diffusion + REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: pvflx ! v-flux of advection/diffusion + ! + INTEGER :: ji, jj, jk + REAL(wp), DIMENSION(A2D(nn_hls)) :: z2d + + z2d(:,:) = puflx(:,:,1) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + puflx(ji,jj,jk) + END_3D + + IF( cptr == 'adv' ) THEN + IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d(:,:) ) ! advective heat transport in i-direction + IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0 * z2d(:,:) ) ! advective salt transport in i-direction + ELSE IF( cptr == 'ldf' ) THEN + IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * z2d(:,:) ) ! diffusive heat transport in i-direction + IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0 * z2d(:,:) ) ! diffusive salt transport in i-direction + ENDIF + ! + z2d(:,:) = pvflx(:,:,1) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + pvflx(ji,jj,jk) + END_3D + + IF( cptr == 'adv' ) THEN + IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d(:,:) ) ! advective heat transport in j-direction + IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0 * z2d(:,:) ) ! advective salt transport in j-direction + ELSE IF( cptr == 'ldf' ) THEN + IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * z2d(:,:) ) ! diffusive heat transport in j-direction + IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0 * z2d(:,:) ) ! diffusive salt transport in j-direction + ENDIF + + END SUBROUTINE dia_ar5_hst + + + SUBROUTINE dia_ar5_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ar5_init *** + !! + !! ** Purpose : initialization for AR5 diagnostic computation + !!---------------------------------------------------------------------- + INTEGER :: inum + INTEGER :: ik, idep + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zztmp + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zsaldta ! Jan/Dec levitus salinity + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zvol0 + ! + !!---------------------------------------------------------------------- + ! + l_ar5 = .FALSE. + IF( iom_use( 'voltot' ) .OR. iom_use( 'sshtot' ) .OR. iom_use( 'sshdyn' ) .OR. & + & iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) .OR. & + & iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) .OR. & + & iom_use( 'uadv_heattr' ) .OR. iom_use( 'udiff_heattr' ) .OR. & + & iom_use( 'uadv_salttr' ) .OR. iom_use( 'udiff_salttr' ) .OR. & + & iom_use( 'vadv_heattr' ) .OR. iom_use( 'vdiff_heattr' ) .OR. & + & iom_use( 'vadv_salttr' ) .OR. iom_use( 'vdiff_salttr' ) .OR. & + & iom_use( 'rhop' ) ) L_ar5 = .TRUE. + + IF( l_ar5 ) THEN + ! + ! ! allocate dia_ar5 arrays + IF( dia_ar5_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' ) + + area_tot = glob_sum( 'diaar5', e1e2t(:,:) ) + + ALLOCATE( zvol0(jpi,jpj) ) + zvol0 (:,:) = 0._wp + thick0(:,:) = 0._wp + DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! interpolation of salinity at the last ocean level (i.e. the partial step) + idep = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) + zvol0 (ji,jj) = zvol0 (ji,jj) + idep * e1e2t(ji,jj) + thick0(ji,jj) = thick0(ji,jj) + idep + END_3D + vol0 =glob_sum( 'diaar5', CASTDP(zvol0) ) + DEALLOCATE( zvol0 ) + + IF( iom_use( 'sshthster' ) ) THEN + ALLOCATE( zsaldta(jpi,jpj,jpk,jpts) ) + CALL iom_open ( 'sali_ref_clim_monthly', inum ) + CALL iom_get ( inum, jpdom_global, 'vosaline' , zsaldta(:,:,:,1), 1 ) + CALL iom_get ( inum, jpdom_global, 'vosaline' , zsaldta(:,:,:,2), 12 ) + CALL iom_close( inum ) + + sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) ) + sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) + IF( ln_zps ) THEN ! z-coord. partial steps + DO_2D( 1, 1, 1, 1 ) ! interpolation of salinity at the last ocean level (i.e. the partial step) + ik = mbkt(ji,jj) + IF( ik > 1 ) THEN + zztmp = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) + sn0(ji,jj,ik) = ( 1._wp - zztmp ) * sn0(ji,jj,ik) + zztmp * sn0(ji,jj,ik-1) + ENDIF + END_2D + ENDIF + ! + DEALLOCATE( zsaldta ) + ENDIF + ! + ENDIF + ! + END SUBROUTINE dia_ar5_init + + !!====================================================================== +END MODULE diaar5 \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diacfl.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diacfl.F90 new file mode 100644 index 0000000..200e7d2 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diacfl.F90 @@ -0,0 +1,161 @@ +MODULE diacfl + !!====================================================================== + !! *** MODULE diacfl *** + !! Output CFL diagnostics to ascii file + !!====================================================================== + !! History : 3.4 ! 2010-03 (E. Blockley) Original code + !! 3.6 ! 2014-06 (T. Graham) Removed CPP key & Updated to vn3.6 + !! 4.0 ! 2017-09 (G. Madec) style + comments + !!---------------------------------------------------------------------- + !! dia_cfl : Compute and output Courant numbers at each timestep + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE domvvl ! + ! + USE lib_mpp ! distribued memory computing + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE in_out_manager ! I/O manager + USE iom ! + USE timing ! Performance output + + IMPLICIT NONE + PRIVATE + + CHARACTER(LEN=50) :: clname="cfl_diagnostics.ascii" ! ascii filename + INTEGER :: numcfl ! outfile unit + ! + INTEGER, DIMENSION(3) :: nCu_loc, nCv_loc, nCw_loc ! U, V, and W run max locations in the global domain + REAL(wp) :: rCu_max, rCv_max, rCw_max ! associated run max Courant number + + PUBLIC dia_cfl ! routine called by step.F90 + PUBLIC dia_cfl_init ! routine called by nemogcm + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diacfl.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_cfl ( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_cfl *** + !! + !! ** Purpose : Compute the Courant numbers Cu=u*dt/dx and Cv=v*dt/dy + !! and output to ascii file 'cfl_diagnostics.ascii' + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zCu_max, zCv_max, zCw_max ! local scalars + INTEGER , DIMENSION(3) :: iloc_u , iloc_v , iloc_w , iloc ! workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zCu_cfl, zCv_cfl, zCw_cfl ! workspace + LOGICAL , DIMENSION(jpi,jpj,jpk) :: llmsk + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dia_cfl') + ! + llmsk( 1:nn_hls,:,:) = .FALSE. ! exclude halos from the checked region + llmsk(Nie0+1: jpi,:,:) = .FALSE. + llmsk(:, 1:nn_hls,:) = .FALSE. + llmsk(:,Nje0+1: jpj,:) = .FALSE. + ! + DO_3D( 0, 0, 0, 0, 1, jpk ) ! calculate Courant numbers + zCu_cfl(ji,jj,jk) = ABS( uu(ji,jj,jk,Kmm) ) * rDt / e1u (ji,jj) ! for i-direction + zCv_cfl(ji,jj,jk) = ABS( vv(ji,jj,jk,Kmm) ) * rDt / e2v (ji,jj) ! for j-direction + zCw_cfl(ji,jj,jk) = ABS( ww(ji,jj,jk) ) * rDt / e3w(ji,jj,jk,Kmm) ! for k-direction + END_3D + ! + ! write outputs + IF( iom_use('cfl_cu') ) THEN + llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL iom_put( 'cfl_cu', MAXVAL( zCu_cfl, mask = llmsk, dim=3 ) ) + ENDIF + IF( iom_use('cfl_cv') ) THEN + llmsk(Nis0:Nie0,Njs0:Nje0,:) = vmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL iom_put( 'cfl_cv', MAXVAL( zCv_cfl, mask = llmsk, dim=3 ) ) + ENDIF + IF( iom_use('cfl_cw') ) THEN + llmsk(Nis0:Nie0,Njs0:Nje0,:) = wmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL iom_put( 'cfl_cw', MAXVAL( zCw_cfl, mask = llmsk, dim=3 ) ) + ENDIF + + ! ! calculate maximum values and locations + llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL mpp_maxloc( 'diacfl', REAL(zCu_cfl,dp), llmsk, zCu_max, iloc_u ) + llmsk(Nis0:Nie0,Njs0:Nje0,:) = vmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL mpp_maxloc( 'diacfl', REAL(zCv_cfl,dp), llmsk, zCv_max, iloc_v ) + llmsk(Nis0:Nie0,Njs0:Nje0,:) = wmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL mpp_maxloc( 'diacfl', REAL(zCw_cfl,dp), llmsk, zCw_max, iloc_w ) + ! + IF( lwp ) THEN ! write out to file + WRITE(numcfl,FMT='(2x,i6,3x,a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) + WRITE(numcfl,FMT='(11x, a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') 'Max Cv', zCv_max, iloc_v(1), iloc_v(2), iloc_v(3) + WRITE(numcfl,FMT='(11x, a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') 'Max Cw', zCw_max, iloc_w(1), iloc_w(2), iloc_w(3) + ENDIF + ! + ! ! update maximum Courant numbers from whole run if applicable + IF( zCu_max > rCu_max ) THEN ; rCu_max = zCu_max ; nCu_loc(:) = iloc_u(:) ; ENDIF + IF( zCv_max > rCv_max ) THEN ; rCv_max = zCv_max ; nCv_loc(:) = iloc_v(:) ; ENDIF + IF( zCw_max > rCw_max ) THEN ; rCw_max = zCw_max ; nCw_loc(:) = iloc_w(:) ; ENDIF + + ! ! at end of run output max Cu and Cv and close ascii file + IF( kt == nitend .AND. lwp ) THEN + ! to ascii file + WRITE(numcfl,*) '******************************************' + WRITE(numcfl,FMT='(3x,a12,6x,f7.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cu', rCu_max, nCu_loc(1), nCu_loc(2), nCu_loc(3) + WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', rDt/rCu_max + WRITE(numcfl,*) '******************************************' + WRITE(numcfl,FMT='(3x,a12,6x,f7.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cv', rCv_max, nCv_loc(1), nCv_loc(2), nCv_loc(3) + WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', rDt/rCv_max + WRITE(numcfl,*) '******************************************' + WRITE(numcfl,FMT='(3x,a12,6x,f7.4,1x,i4,1x,i4,1x,i4)') 'Run Max Cw', rCw_max, nCw_loc(1), nCw_loc(2), nCw_loc(3) + WRITE(numcfl,FMT='(3x,a8,11x,f15.1)') ' => dt/C', rDt/rCw_max + CLOSE( numcfl ) + ! + ! to ocean output + WRITE(numout,*) + WRITE(numout,*) 'dia_cfl : Maximum Courant number information for the run ' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) ' Max Cu = ', rCu_max, ' at (i,j,k) = (',nCu_loc(1),nCu_loc(2),nCu_loc(3),') => dt/C = ', rDt/rCu_max + WRITE(numout,*) ' Max Cv = ', rCv_max, ' at (i,j,k) = (',nCv_loc(1),nCv_loc(2),nCv_loc(3),') => dt/C = ', rDt/rCv_max + WRITE(numout,*) ' Max Cw = ', rCw_max, ' at (i,j,k) = (',nCw_loc(1),nCw_loc(2),nCw_loc(3),') => dt/C = ', rDt/rCw_max + ENDIF + ! + IF( ln_timing ) CALL timing_stop('dia_cfl') + ! + END SUBROUTINE dia_cfl + + + SUBROUTINE dia_cfl_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_cfl_init *** + !! + !! ** Purpose : create output file, initialise arrays + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dia_cfl : Outputting CFL diagnostics to ',TRIM(clname), ' file' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) + ! + ! create output ascii file + CALL ctl_opn( numcfl, clname, 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', 1, numout, lwp, 1 ) + WRITE(numcfl,*) 'Timestep Direction Max C i j k' + WRITE(numcfl,*) '******************************************' + ENDIF + ! + rCu_max = 0._wp + rCv_max = 0._wp + rCw_max = 0._wp + ! + END SUBROUTINE dia_cfl_init + + !!====================================================================== +END MODULE diacfl diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diadct.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diadct.F90 new file mode 100644 index 0000000..eb57e5e --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diadct.F90 @@ -0,0 +1,1266 @@ +MODULE diadct + !!====================================================================== + !! *** MODULE diadct *** + !! Ocean diagnostics: Compute the transport trough a sec. + !!====================================================================== + !! History : OPA ! 02/1999 (Y Drillet) original code + !! ! 10/2001 (Y Drillet, R Bourdalle Badie) + !! NEMO 1.0 ! 10/2005 (M Laborie) F90 + !! 3.0 ! 04/2007 (G Garric) Ice sections + !! - ! 04/2007 (C Bricaud) test on sec%nb_point, initialisation of ztransp1,ztransp2,... + !! 3.4 ! 09/2011 (C Bricaud) + !!---------------------------------------------------------------------- +#if ! defined key_agrif + !! ==>> CAUTION: does not work with agrif + !!---------------------------------------------------------------------- + !! dia_dct : Compute the transport through a sec. + !! dia_dct_init : Read namelist. + !! readsec : Read sections description and pathway + !! removepoints : Remove points which are common to 2 procs + !! transport : Compute transport for each sections + !! dia_dct_wri : Write tranports results in ascii files + !! interp : Compute temperature/salinity/density at U-point or V-point + !! + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE in_out_manager ! I/O manager + USE daymod ! calendar + USE dianam ! build name of file + USE lib_mpp ! distributed memory computing library +#if defined key_si3 + USE ice +#endif + USE domvvl + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_dct ! routine called by step.F90 + PUBLIC dia_dct_init ! routine called by nemogcm.F90 + + ! !!** namelist variables ** + LOGICAL, PUBLIC :: ln_diadct !: Calculate transport thru a section or not + INTEGER :: nn_dct ! Frequency of computation + INTEGER :: nn_dctwri ! Frequency of output + INTEGER :: nn_secdebug ! Number of the section to debug + + INTEGER, PARAMETER :: nb_class_max = 10 + INTEGER, PARAMETER :: nb_sec_max = 150 + INTEGER, PARAMETER :: nb_point_max = 2000 + INTEGER, PARAMETER :: nb_type_class = 10 + INTEGER, PARAMETER :: nb_3d_vars = 3 + INTEGER, PARAMETER :: nb_2d_vars = 2 + INTEGER :: nb_sec + + TYPE POINT_SECTION + INTEGER :: I,J + END TYPE POINT_SECTION + + TYPE COORD_SECTION + REAL(wp) :: lon,lat + END TYPE COORD_SECTION + + TYPE SECTION + CHARACTER(len=60) :: name ! name of the sec + LOGICAL :: llstrpond ! true if you want the computation of salt and heat transports + LOGICAL :: ll_ice_section ! ice surface and ice volume computation + LOGICAL :: ll_date_line ! = T if the section crosses the date-line + TYPE(COORD_SECTION), DIMENSION(2) :: coordSec ! longitude and latitude of the extremities of the sec + INTEGER :: nb_class ! number of boundaries for density classes + INTEGER, DIMENSION(nb_point_max) :: direction ! vector direction of the point in the section + CHARACTER(len=40),DIMENSION(nb_class_max) :: classname ! characteristics of the class + REAL(wp), DIMENSION(nb_class_max) :: zsigi ! in-situ density classes (99 if you don't want) + REAL(wp), DIMENSION(nb_class_max) :: zsigp ! potential density classes (99 if you don't want) + REAL(wp), DIMENSION(nb_class_max) :: zsal ! salinity classes (99 if you don't want) + REAL(wp), DIMENSION(nb_class_max) :: ztem ! temperature classes(99 if you don't want) + REAL(wp), DIMENSION(nb_class_max) :: zlay ! level classes (99 if you don't want) + REAL(wp), DIMENSION(nb_type_class,nb_class_max) :: transport ! transport output + REAL(wp) :: slopeSection ! slope of the section + INTEGER :: nb_point ! number of points in the section + TYPE(POINT_SECTION),DIMENSION(nb_point_max) :: listPoint ! list of points in the sections + END TYPE SECTION + + TYPE(SECTION),DIMENSION(nb_sec_max) :: secs ! Array of sections + + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: transports_3d + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: transports_2d + + + !! * Substitutions +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diadct.F90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + INTEGER FUNCTION diadct_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION diadct_alloc *** + !!---------------------------------------------------------------------- + + ALLOCATE( transports_3d(nb_3d_vars,nb_sec_max,nb_point_max,jpk), & + & transports_2d(nb_2d_vars,nb_sec_max,nb_point_max) , STAT=diadct_alloc ) + + CALL mpp_sum( 'diadct', diadct_alloc ) + IF( diadct_alloc /= 0 ) CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' ) + + END FUNCTION diadct_alloc + + SUBROUTINE dia_dct_init + !!--------------------------------------------------------------------- + !! *** ROUTINE diadct *** + !! + !! ** Purpose: Read the namelist parameters + !! Open output files + !! + !!--------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/nam_diadct/ln_diadct, nn_dct, nn_dctwri, nn_secdebug + !!--------------------------------------------------------------------- + + READ ( numnam_ref, nam_diadct, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diadct in reference namelist' ) + + READ ( numnam_cfg, nam_diadct, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diadct in configuration namelist' ) + IF(lwm) WRITE ( numond, nam_diadct ) + + IF( lwp ) THEN + WRITE(numout,*) " " + WRITE(numout,*) "diadct_init: compute transports through sections " + WRITE(numout,*) "~~~~~~~~~~~~~~~~~~~~~" + WRITE(numout,*) " Calculate transport thru sections: ln_diadct = ", ln_diadct + WRITE(numout,*) " Frequency of computation: nn_dct = ", nn_dct + WRITE(numout,*) " Frequency of write: nn_dctwri = ", nn_dctwri + + IF ( nn_secdebug .GE. 1 .AND. nn_secdebug .LE. nb_sec_max )THEN + WRITE(numout,*)" Debug section number: ", nn_secdebug + ELSE IF ( nn_secdebug == 0 )THEN ; WRITE(numout,*)" No section to debug" + ELSE IF ( nn_secdebug == -1 )THEN ; WRITE(numout,*)" Debug all sections" + ELSE ; WRITE(numout,*)" Wrong value for nn_secdebug : ",nn_secdebug + ENDIF + ENDIF + + IF( ln_diadct ) THEN + ! control + IF(nn_dct .GE. nn_dctwri .AND. MOD(nn_dct,nn_dctwri) .NE. 0) & + & CALL ctl_stop( 'diadct: nn_dct should be smaller and a multiple of nn_dctwri' ) + + ! allocate dia_dct arrays + IF( diadct_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' ) + + !Read section_ijglobal.diadct + CALL readsec + + !open output file + IF( lwm ) THEN + CALL ctl_opn( numdct_vol, 'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + CALL ctl_opn( numdct_heat, 'heat_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + CALL ctl_opn( numdct_salt, 'salt_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + ENDIF + + ! Initialise arrays to zero + transports_3d(:,:,:,:)=0.0 + transports_2d(:,:,:) =0.0 + ! + ENDIF + ! + END SUBROUTINE dia_dct_init + + + SUBROUTINE dia_dct( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE diadct *** + !! + !! Purpose :: Compute section transports and write it in numdct files + !! + !! Method :: All arrays initialised to zero in dct_init + !! Each nn_dct time step call subroutine 'transports' for + !! each section to sum the transports over each grid cell. + !! Each nn_dctwri time step: + !! Divide the arrays by the number of summations to gain + !! an average value + !! Call dia_dct_sum to sum relevant grid boxes to obtain + !! totals for each class (density, depth, temp or sal) + !! Call dia_dct_wri to write the transports into file + !! Reinitialise all relevant arrays to zero + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kmm ! time level index + ! + INTEGER :: jsec ! loop on sections + INTEGER :: itotal ! nb_sec_max*nb_type_class*nb_class_max + LOGICAL :: lldebug =.FALSE. ! debug a section + INTEGER , DIMENSION(1) :: ish ! work array for mpp_sum + INTEGER , DIMENSION(3) :: ish2 ! " + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zwork ! " + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:):: zsum ! " + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dia_dct') + + IF( lk_mpp )THEN + itotal = nb_sec_max*nb_type_class*nb_class_max + ALLOCATE( zwork(itotal) , zsum(nb_sec_max,nb_type_class,nb_class_max) ) + ENDIF + + ! Initialise arrays + zwork(:) = 0.0 + zsum(:,:,:) = 0.0 + + IF( lwp .AND. kt==nit000+nn_dct-1 ) THEN + WRITE(numout,*) " " + WRITE(numout,*) "diadct: compute transport" + WRITE(numout,*) "~~~~~~~~~~~~~~~~~~~~~~~~~" + WRITE(numout,*) "nb_sec = ",nb_sec + ENDIF + + + ! Compute transport and write only at nn_dctwri + IF( MOD(kt,nn_dct)==0 ) THEN + + DO jsec=1,nb_sec + + !debug this section computing ? + lldebug=.FALSE. + IF( (jsec==nn_secdebug .OR. nn_secdebug==-1) .AND. kt==nit000+nn_dct-1 ) lldebug=.TRUE. + + !Compute transport through section + CALL transport(Kmm,secs(jsec),lldebug,jsec) + + ENDDO + + IF( MOD(kt,nn_dctwri)==0 )THEN + + IF( kt==nit000+nn_dctwri-1 )WRITE(numout,*)" diadct: average transports and write at kt = ",kt + + !! divide arrays by nn_dctwri/nn_dct to obtain average + transports_3d(:,:,:,:)=transports_3d(:,:,:,:)/(nn_dctwri/nn_dct) + transports_2d(:,:,:) =transports_2d(:,:,:) /(nn_dctwri/nn_dct) + + ! Sum over each class + DO jsec=1,nb_sec + CALL dia_dct_sum(Kmm,secs(jsec),jsec) + ENDDO + + !Sum on all procs + IF( lk_mpp )THEN + ish(1) = nb_sec_max*nb_type_class*nb_class_max + ish2 = (/nb_sec_max,nb_type_class,nb_class_max/) + DO jsec=1,nb_sec ; zsum(jsec,:,:) = secs(jsec)%transport(:,:) ; ENDDO + zwork(:)= RESHAPE(zsum(:,:,:), ish ) + CALL mpp_sum('diadct', zwork, ish(1)) + zsum(:,:,:)= RESHAPE(zwork,ish2) + DO jsec=1,nb_sec ; secs(jsec)%transport(:,:) = zsum(jsec,:,:) ; ENDDO + ENDIF + + !Write the transport + DO jsec=1,nb_sec + + IF( lwm )CALL dia_dct_wri(kt,jsec,secs(jsec)) + + !nullify transports values after writing + transports_3d(:,jsec,:,:)=0. + transports_2d(:,jsec,: )=0. + secs(jsec)%transport(:,:)=0. + + ENDDO + + ENDIF + + ENDIF + + IF( lk_mpp )THEN + itotal = nb_sec_max*nb_type_class*nb_class_max + DEALLOCATE( zwork , zsum ) + ENDIF + + IF( ln_timing ) CALL timing_stop('dia_dct') + ! + END SUBROUTINE dia_dct + + + SUBROUTINE readsec + !!--------------------------------------------------------------------- + !! *** ROUTINE readsec *** + !! + !! ** Purpose: + !! Read a binary file(section_ijglobal.diadct) + !! generated by the tools "NEMOGCM/TOOLS/SECTIONS_DIADCT" + !! + !! + !!--------------------------------------------------------------------- + INTEGER :: iptglo , iptloc ! Global and local number of points for a section + INTEGER :: isec, iiglo, ijglo, iiloc, ijloc,iost,i1 ,i2 ! temporary integer + INTEGER :: jsec, jpt ! dummy loop indices + INTEGER, DIMENSION(2) :: icoord + LOGICAL :: llbon, lldebug ! local logical + CHARACTER(len=160) :: clname ! filename + CHARACTER(len=200) :: cltmp + CHARACTER(len=200) :: clformat !automatic format + TYPE(POINT_SECTION),DIMENSION(nb_point_max) ::coordtemp !contains listpoints coordinates read in the file + INTEGER, DIMENSION(nb_point_max) :: directemp !contains listpoints directions read in the files + !!------------------------------------------------------------------------------------- + + !open input file + !--------------- + CALL ctl_opn( numdct_in, 'section_ijglobal.diadct', 'OLD', 'UNFORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + + !--------------- + !Read input file + !--------------- + + DO jsec=1,nb_sec_max !loop on the nb_sec sections + + IF ( jsec==nn_secdebug .OR. nn_secdebug==-1 ) & + & WRITE(numout,*)'debuging for section number: ',jsec + + !initialization + !--------------- + secs(jsec)%name='' + secs(jsec)%llstrpond = .FALSE. ; secs(jsec)%ll_ice_section = .FALSE. + secs(jsec)%ll_date_line = .FALSE. ; secs(jsec)%nb_class = 0 + secs(jsec)%zsigi = 99._wp ; secs(jsec)%zsigp = 99._wp + secs(jsec)%zsal = 99._wp ; secs(jsec)%ztem = 99._wp + secs(jsec)%zlay = 99._wp + secs(jsec)%transport = 0._wp ; secs(jsec)%nb_point = 0 + + !read section's number / name / computing choices / classes / slopeSection / points number + !----------------------------------------------------------------------------------------- + READ(numdct_in,iostat=iost)isec + IF (iost .NE. 0 )EXIT !end of file + WRITE(cltmp,'(a,i4.4,a,i4.4)')'diadct: read sections : Problem of section number: isec= ',isec,' and jsec= ',jsec + IF( jsec .NE. isec ) CALL ctl_stop( cltmp ) + + IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )WRITE(numout,*)"isec ",isec + + READ(numdct_in)secs(jsec)%name + READ(numdct_in)secs(jsec)%llstrpond + READ(numdct_in)secs(jsec)%ll_ice_section + READ(numdct_in)secs(jsec)%ll_date_line + READ(numdct_in)secs(jsec)%coordSec + READ(numdct_in)secs(jsec)%nb_class + READ(numdct_in)secs(jsec)%zsigi + READ(numdct_in)secs(jsec)%zsigp + READ(numdct_in)secs(jsec)%zsal + READ(numdct_in)secs(jsec)%ztem + READ(numdct_in)secs(jsec)%zlay + READ(numdct_in)secs(jsec)%slopeSection + READ(numdct_in)iptglo + + !debug + !----- + + IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN + + WRITE(clformat,'(a,i2,a)') '(A40,', nb_class_max,'(f8.3,1X))' + + WRITE(numout,*) " Section name : ",TRIM(secs(jsec)%name) + WRITE(numout,*) " Compute heat and salt transport ? ",secs(jsec)%llstrpond + WRITE(numout,*) " Compute ice transport ? ",secs(jsec)%ll_ice_section + WRITE(numout,*) " Section crosses date-line ? ",secs(jsec)%ll_date_line + WRITE(numout,*) " Slope section : ",secs(jsec)%slopeSection + WRITE(numout,*) " Number of points in the section: ",iptglo + WRITE(numout,*) " Number of classes ",secs(jsec)%nb_class + WRITE(numout,clformat)" Insitu density classes : ",secs(jsec)%zsigi + WRITE(numout,clformat)" Potential density classes : ",secs(jsec)%zsigp + WRITE(numout,clformat)" Salinity classes : ",secs(jsec)%zsal + WRITE(numout,clformat)" Temperature classes : ",secs(jsec)%ztem + WRITE(numout,clformat)" Depth classes : ",secs(jsec)%zlay + ENDIF + + IF( iptglo /= 0 )THEN + + !read points'coordinates and directions + !-------------------------------------- + coordtemp(:) = POINT_SECTION(0,0) !list of points read + directemp(:) = 0 !value of directions of each points + DO jpt=1,iptglo + READ(numdct_in) i1, i2 + coordtemp(jpt)%I = i1 + coordtemp(jpt)%J = i2 + ENDDO + READ(numdct_in) directemp(1:iptglo) + + !debug + !----- + IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN + WRITE(numout,*)" List of points in global domain:" + DO jpt=1,iptglo + WRITE(numout,*)' # I J ',jpt,coordtemp(jpt),directemp(jpt) + ENDDO + ENDIF + + !Now each proc selects only points that are in its domain: + !-------------------------------------------------------- + iptloc = 0 ! initialize number of points selected + DO jpt = 1, iptglo ! loop on listpoint read in the file + ! + iiglo=coordtemp(jpt)%I ! global coordinates of the point + ijglo=coordtemp(jpt)%J ! " + + IF( iiglo==jpiglo .AND. nimpp==1 ) iiglo = 2 !!gm BUG: Hard coded periodicity ! + + iiloc=iiglo-nimpp+1 ! local coordinates of the point + ijloc=ijglo-njmpp+1 ! " + + !verify if the point is on the local domain:(1,Nie0)*(1,Nje0) + IF( iiloc >= 1 .AND. iiloc <= Nie0 .AND. & + ijloc >= 1 .AND. ijloc <= Nje0 )THEN + iptloc = iptloc + 1 ! count local points + secs(jsec)%listPoint(iptloc) = POINT_SECTION(mi0(iiglo),mj0(ijglo)) ! store local coordinates + secs(jsec)%direction(iptloc) = directemp(jpt) ! store local direction + ENDIF + ! + END DO + + secs(jsec)%nb_point=iptloc !store number of section's points + + !debug + !----- + IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN + WRITE(numout,*)" List of points selected by the proc:" + DO jpt = 1,iptloc + iiglo = secs(jsec)%listPoint(jpt)%I + nimpp - 1 + ijglo = secs(jsec)%listPoint(jpt)%J + njmpp - 1 + WRITE(numout,*)' # I J : ',iiglo,ijglo + ENDDO + ENDIF + + IF(jsec==nn_secdebug .AND. secs(jsec)%nb_point .NE. 0)THEN + DO jpt = 1,iptloc + iiglo = secs(jsec)%listPoint(jpt)%I + nimpp - 1 + ijglo = secs(jsec)%listPoint(jpt)%J + njmpp - 1 + ENDDO + ENDIF + + !remove redundant points between processors + !------------------------------------------ + lldebug = .FALSE. ; IF ( jsec==nn_secdebug .OR. nn_secdebug==-1 ) lldebug = .TRUE. + IF( iptloc .NE. 0 )THEN + CALL removepoints(secs(jsec),'I','top_list',lldebug) + CALL removepoints(secs(jsec),'I','bot_list',lldebug) + CALL removepoints(secs(jsec),'J','top_list',lldebug) + CALL removepoints(secs(jsec),'J','bot_list',lldebug) + ENDIF + IF(jsec==nn_secdebug .AND. secs(jsec)%nb_point .NE. 0)THEN + DO jpt = 1,secs(jsec)%nb_point + iiglo = secs(jsec)%listPoint(jpt)%I + nimpp - 1 + ijglo = secs(jsec)%listPoint(jpt)%J + njmpp - 1 + ENDDO + ENDIF + + !debug + !----- + IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )THEN + WRITE(numout,*)" List of points after removepoints:" + iptloc = secs(jsec)%nb_point + DO jpt = 1,iptloc + iiglo = secs(jsec)%listPoint(jpt)%I + nimpp - 1 + ijglo = secs(jsec)%listPoint(jpt)%J + njmpp - 1 + WRITE(numout,*)' # I J : ',iiglo,ijglo + CALL FLUSH(numout) + ENDDO + ENDIF + + ELSE ! iptglo = 0 + IF( jsec==nn_secdebug .OR. nn_secdebug==-1 )& + WRITE(numout,*)' No points for this section.' + ENDIF + + ENDDO !end of the loop on jsec + + nb_sec = jsec-1 !number of section read in the file + ! + END SUBROUTINE readsec + + + SUBROUTINE removepoints(sec,cdind,cdextr,ld_debug) + !!--------------------------------------------------------------------------- + !! *** function removepoints + !! + !! ** Purpose :: Remove points which are common to 2 procs + !! + !---------------------------------------------------------------------------- + !! * arguments + TYPE(SECTION),INTENT(INOUT) :: sec + CHARACTER(len=1),INTENT(IN) :: cdind ! = 'I'/'J' + CHARACTER(len=8),INTENT(IN) :: cdextr ! = 'top_list'/'bot_list' + LOGICAL,INTENT(IN) :: ld_debug + + !! * Local variables + INTEGER :: iextr ,& !extremity of listpoint that we verify + iind ,& !coord of listpoint that we verify + itest ,& !indice value of the side of the domain + !where points could be redundant + isgn ,& ! isgn= 1 : scan listpoint from start to end + ! isgn=-1 : scan listpoint from end to start + istart,iend !first and last points selected in listpoint + INTEGER :: jpoint !loop on list points + INTEGER, DIMENSION(nb_point_max) :: idirec !contains temporary sec%direction + INTEGER, DIMENSION(2,nb_point_max) :: icoord !contains temporary sec%listpoint + !---------------------------------------------------------------------------- + ! + IF( ld_debug )WRITE(numout,*)' -------------------------' + IF( ld_debug )WRITE(numout,*)' removepoints in listpoint' + + !iextr=extremity of list_point that we verify + IF ( cdextr=='bot_list' )THEN ; iextr=1 ; isgn=1 + ELSE IF ( cdextr=='top_list' )THEN ; iextr=sec%nb_point ; isgn=-1 + ELSE ; CALL ctl_stop("removepoints :Wrong value for cdextr") + ENDIF + + !which coordinate shall we verify ? + IF ( cdind=='I' )THEN ; itest=Nie0 ; iind=1 + ELSE IF ( cdind=='J' )THEN ; itest=Nje0 ; iind=2 + ELSE ; CALL ctl_stop("removepoints :Wrong value for cdind") + ENDIF + + IF( ld_debug )THEN + WRITE(numout,*)' case: coord/list extr/domain side' + WRITE(numout,*)' ', cdind,' ',cdextr,' ',itest + WRITE(numout,*)' Actual number of points: ',sec%nb_point + ENDIF + + icoord(1,1:nb_point_max) = sec%listPoint%I + icoord(2,1:nb_point_max) = sec%listPoint%J + idirec = sec%direction + sec%listPoint = POINT_SECTION(0,0) + sec%direction = 0 + + jpoint=iextr+isgn + DO WHILE( jpoint .GE. 1 .AND. jpoint .LE. sec%nb_point ) + IF( icoord( iind,jpoint-isgn ) == itest .AND. icoord( iind,jpoint ) == itest )THEN ; jpoint=jpoint+isgn + ELSE ; EXIT + ENDIF + ENDDO + + IF( cdextr=='bot_list')THEN ; istart=jpoint-1 ; iend=sec%nb_point + ELSE ; istart=1 ; iend=jpoint+1 + ENDIF + + sec%listPoint(1:1+iend-istart)%I = icoord(1,istart:iend) + sec%listPoint(1:1+iend-istart)%J = icoord(2,istart:iend) + sec%direction(1:1+iend-istart) = idirec(istart:iend) + sec%nb_point = iend-istart+1 + + IF( ld_debug )THEN + WRITE(numout,*)' Number of points after removepoints :',sec%nb_point + WRITE(numout,*)' sec%direction after removepoints :',sec%direction(1:sec%nb_point) + ENDIF + ! + END SUBROUTINE removepoints + + + SUBROUTINE transport(Kmm,sec,ld_debug,jsec) + !!------------------------------------------------------------------------------------------- + !! *** ROUTINE transport *** + !! + !! Purpose :: Compute the transport for each point in a section + !! + !! Method :: Loop over each segment, and each vertical level and add the transport + !! Be aware : + !! One section is a sum of segments + !! One segment is defined by 2 consecutive points in sec%listPoint + !! All points of sec%listPoint are positioned on the F-point of the cell + !! + !! There are two loops: + !! loop on the segment between 2 nodes + !! loop on the level jk !! + !! + !! Output :: Arrays containing the volume,density,heat,salt transports for each i + !! point in a section, summed over each nn_dct. + !! + !!------------------------------------------------------------------------------------------- + INTEGER ,INTENT(IN) :: Kmm ! time level index + TYPE(SECTION),INTENT(INOUT) :: sec + LOGICAL ,INTENT(IN) :: ld_debug + INTEGER ,INTENT(IN) :: jsec ! numeric identifier of section + ! + INTEGER :: jk, jseg, jclass,jl, isgnu, isgnv ! loop on level/segment/classes/ice categories + REAL(wp):: zumid, zvmid, zumid_ice, zvmid_ice ! U/V ocean & ice velocity on a cell segment + REAL(wp):: zTnorm ! transport of velocity through one cell's sides + REAL(wp):: ztn, zsn, zrhoi, zrhop, zsshn, zdep ! temperature/salinity/potential density/ssh/depth at u/v point + TYPE(POINT_SECTION) :: k + !!-------------------------------------------------------- + ! + IF( ld_debug )WRITE(numout,*)' Compute transport' + + !---------------------------! + ! COMPUTE TRANSPORT ! + !---------------------------! + IF(sec%nb_point .NE. 0)THEN + + !---------------------------------------------------------------------------------------------------- + !Compute sign for velocities: + ! + !convention: + ! non horizontal section: direction + is toward left hand of section + ! horizontal section: direction + is toward north of section + ! + ! + ! slopeSection < 0 slopeSection > 0 slopeSection=inf slopeSection=0 + ! ---------------- ----------------- --------------- -------------- + ! + ! isgnv=1 direction + + ! ______ _____ ______ + ! | //| | | direction + + ! | isgnu=1 // | |isgnu=1 |isgnu=1 /|\ + ! |_______ // ______| \\ | ---\ | + ! | | isgnv=-1 \\ | | ---/ direction + ____________ + ! | | __\\| | + ! | | direction + | isgnv=1 + ! + !---------------------------------------------------------------------------------------------------- + isgnu = 1 + IF( sec%slopeSection .GT. 0 ) THEN ; isgnv = -1 + ELSE ; isgnv = 1 + ENDIF + IF( sec%slopeSection .GE. 9999. ) isgnv = 1 + + IF( ld_debug )write(numout,*)"sec%slopeSection isgnu isgnv ",sec%slopeSection,isgnu,isgnv + + !--------------------------------------! + ! LOOP ON THE SEGMENT BETWEEN 2 NODES ! + !--------------------------------------! + DO jseg=1,MAX(sec%nb_point-1,0) + + !------------------------------------------------------------------------------------------- + ! Select the appropriate coordinate for computing the velocity of the segment + ! + ! CASE(0) Case (2) + ! ------- -------- + ! listPoint(jseg) listPoint(jseg+1) listPoint(jseg) F(i,j) + ! F(i,j)----------V(i+1,j)-------F(i+1,j) | + ! | + ! | + ! | + ! Case (3) U(i,j) + ! -------- | + ! | + ! listPoint(jseg+1) F(i,j+1) | + ! | | + ! | | + ! | listPoint(jseg+1) F(i,j-1) + ! | + ! | + ! U(i,j+1) + ! | Case(1) + ! | ------ + ! | + ! | listPoint(jseg+1) listPoint(jseg) + ! | F(i-1,j)-----------V(i,j) -------f(jseg) + ! listPoint(jseg) F(i,j) + ! + !------------------------------------------------------------------------------------------- + + SELECT CASE( sec%direction(jseg) ) + CASE(0) ; k = sec%listPoint(jseg) + CASE(1) ; k = POINT_SECTION(sec%listPoint(jseg)%I+1,sec%listPoint(jseg)%J) + CASE(2) ; k = sec%listPoint(jseg) + CASE(3) ; k = POINT_SECTION(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J+1) + END SELECT + + !---------------------------| + ! LOOP ON THE LEVEL | + !---------------------------| + DO jk = 1, mbkt(k%I,k%J) !Sum of the transport on the vertical + ! ! compute temperature, salinity, insitu & potential density, ssh and depth at U/V point + SELECT CASE( sec%direction(jseg) ) + CASE(0,1) + ztn = interp(Kmm,k%I,k%J,jk,'V',ts(:,:,:,jp_tem,Kmm) ) + zsn = interp(Kmm,k%I,k%J,jk,'V',ts(:,:,:,jp_sal,Kmm) ) + zrhop = interp(Kmm,k%I,k%J,jk,'V',rhop) + zrhoi =interp(Kmm,k%I,k%J,jk,'V',CASTDP(rhd*rho0+rho0)) + zsshn = 0.5*( ssh(k%I,k%J,Kmm) + ssh(k%I,k%J+1,Kmm) ) * vmask(k%I,k%J,1) + CASE(2,3) + ztn = interp(Kmm,k%I,k%J,jk,'U',ts(:,:,:,jp_tem,Kmm) ) + zsn = interp(Kmm,k%I,k%J,jk,'U',ts(:,:,:,jp_sal,Kmm) ) + zrhop = interp(Kmm,k%I,k%J,jk,'U',rhop) + zrhoi =interp(Kmm,k%I,k%J,jk,'U',CASTDP(rhd*rho0+rho0)) + zsshn = 0.5*( ssh(k%I,k%J,Kmm) + ssh(k%I+1,k%J,Kmm) ) * umask(k%I,k%J,1) + END SELECT + ! + zdep= gdept(k%I,k%J,jk,Kmm) + + SELECT CASE( sec%direction(jseg) ) !compute velocity with the correct direction + CASE(0,1) + zumid=0._wp + zvmid=isgnv*vv(k%I,k%J,jk,Kmm)*vmask(k%I,k%J,jk) + CASE(2,3) + zumid=isgnu*uu(k%I,k%J,jk,Kmm)*umask(k%I,k%J,jk) + zvmid=0._wp + END SELECT + + !zTnorm=transport through one cell; + !velocity* cell's length * cell's thickness + zTnorm = zumid*e2u(k%I,k%J) * e3u(k%I,k%J,jk,Kmm) & + & + zvmid*e1v(k%I,k%J) * e3v(k%I,k%J,jk,Kmm) + +!!gm THIS is WRONG no transport due to ssh in linear free surface case !!!!! + IF( ln_linssh ) THEN !add transport due to free surface + IF( jk==1 ) THEN + zTnorm = zTnorm + zumid* e2u(k%I,k%J) * zsshn * umask(k%I,k%J,jk) & + & + zvmid* e1v(k%I,k%J) * zsshn * vmask(k%I,k%J,jk) + ENDIF + ENDIF +!!gm end + !COMPUTE TRANSPORT + + transports_3d(1,jsec,jseg,jk) = transports_3d(1,jsec,jseg,jk) + zTnorm + + IF( sec%llstrpond ) THEN + transports_3d(2,jsec,jseg,jk) = transports_3d(2,jsec,jseg,jk) + zTnorm * ztn * zrhop * rcp + transports_3d(3,jsec,jseg,jk) = transports_3d(3,jsec,jseg,jk) + zTnorm * zsn * zrhop * 0.001 + ENDIF + + END DO !end of loop on the level + +#if defined key_si3 + + !ICE CASE + !------------ + IF( sec%ll_ice_section )THEN + SELECT CASE (sec%direction(jseg)) + CASE(0) + zumid_ice = 0 + zvmid_ice = isgnv*0.5*(v_ice(k%I,k%J+1)+v_ice(k%I+1,k%J+1)) + CASE(1) + zumid_ice = 0 + zvmid_ice = isgnv*0.5*(v_ice(k%I,k%J+1)+v_ice(k%I+1,k%J+1)) + CASE(2) + zvmid_ice = 0 + zumid_ice = isgnu*0.5*(u_ice(k%I+1,k%J)+u_ice(k%I+1,k%J+1)) + CASE(3) + zvmid_ice = 0 + zumid_ice = isgnu*0.5*(u_ice(k%I+1,k%J)+u_ice(k%I+1,k%J+1)) + END SELECT + + zTnorm=zumid_ice*e2u(k%I,k%J)+zvmid_ice*e1v(k%I,k%J) + +#if defined key_si3 + DO jl=1,jpl + transports_2d(1,jsec,jseg) = transports_2d(1,jsec,jseg) + (zTnorm)* & + a_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) * & + ( h_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) + & + h_s(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) ) + + transports_2d(2,jsec,jseg) = transports_2d(2,jsec,jseg) + (zTnorm)* & + a_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) + END DO +#endif + + ENDIF !end of ice case +#endif + + END DO !end of loop on the segment + + ENDIF !end of sec%nb_point =0 case + ! + END SUBROUTINE transport + + + SUBROUTINE dia_dct_sum(Kmm,sec,jsec) + !!------------------------------------------------------------- + !! Purpose: Average the transport over nn_dctwri time steps + !! and sum over the density/salinity/temperature/depth classes + !! + !! Method: Sum over relevant grid cells to obtain values + !! for each class + !! There are several loops: + !! loop on the segment between 2 nodes + !! loop on the level jk + !! loop on the density/temperature/salinity/level classes + !! test on the density/temperature/salinity/level + !! + !! Note: Transport through a given section is equal to the sum of transports + !! computed on each proc. + !! On each proc,transport is equal to the sum of transport computed through + !! segments linking each point of sec%listPoint with the next one. + !! + !!------------------------------------------------------------- + INTEGER ,INTENT(IN) :: Kmm ! time level index + TYPE(SECTION),INTENT(INOUT) :: sec + INTEGER ,INTENT(IN) :: jsec ! numeric identifier of section + + TYPE(POINT_SECTION) :: k + INTEGER :: jk,jseg,jclass ! dummy variables for looping on level/segment/classes + REAL(wp) :: ztn, zsn, zrhoi, zrhop, zsshn, zdep ! temperature/salinity/ssh/potential density /depth at u/v point + !!------------------------------------------------------------- + + !! Sum the relevant segments to obtain values for each class + IF(sec%nb_point .NE. 0)THEN + + !--------------------------------------! + ! LOOP ON THE SEGMENT BETWEEN 2 NODES ! + !--------------------------------------! + DO jseg=1,MAX(sec%nb_point-1,0) + + !------------------------------------------------------------------------------------------- + ! Select the appropriate coordinate for computing the velocity of the segment + ! + ! CASE(0) Case (2) + ! ------- -------- + ! listPoint(jseg) listPoint(jseg+1) listPoint(jseg) F(i,j) + ! F(i,j)----------V(i+1,j)-------F(i+1,j) | + ! | + ! | + ! | + ! Case (3) U(i,j) + ! -------- | + ! | + ! listPoint(jseg+1) F(i,j+1) | + ! | | + ! | | + ! | listPoint(jseg+1) F(i,j-1) + ! | + ! | + ! U(i,j+1) + ! | Case(1) + ! | ------ + ! | + ! | listPoint(jseg+1) listPoint(jseg) + ! | F(i-1,j)-----------V(i,j) -------f(jseg) + ! listPoint(jseg) F(i,j) + ! + !------------------------------------------------------------------------------------------- + + SELECT CASE( sec%direction(jseg) ) + CASE(0) ; k = sec%listPoint(jseg) + CASE(1) ; k = POINT_SECTION(sec%listPoint(jseg)%I+1,sec%listPoint(jseg)%J) + CASE(2) ; k = sec%listPoint(jseg) + CASE(3) ; k = POINT_SECTION(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J+1) + END SELECT + + !---------------------------| + ! LOOP ON THE LEVEL | + !---------------------------| + !Sum of the transport on the vertical + DO jk=1,mbkt(k%I,k%J) + + ! compute temperature, salinity, insitu & potential density, ssh and depth at U/V point + SELECT CASE( sec%direction(jseg) ) + CASE(0,1) + ztn = interp(Kmm,k%I,k%J,jk,'V',ts(:,:,:,jp_tem,Kmm) ) + zsn = interp(Kmm,k%I,k%J,jk,'V',ts(:,:,:,jp_sal,Kmm) ) + zrhop = interp(Kmm,k%I,k%J,jk,'V',rhop) + zrhoi =interp(Kmm,k%I,k%J,jk,'V',CASTDP(rhd*rho0+rho0)) + + CASE(2,3) + ztn = interp(Kmm,k%I,k%J,jk,'U',ts(:,:,:,jp_tem,Kmm) ) + zsn = interp(Kmm,k%I,k%J,jk,'U',ts(:,:,:,jp_sal,Kmm) ) + zrhop = interp(Kmm,k%I,k%J,jk,'U',rhop) + zrhoi =interp(Kmm,k%I,k%J,jk,'U',CASTDP(rhd*rho0+rho0)) + zsshn = 0.5*( ssh(k%I,k%J,Kmm) + ssh(k%I+1,k%J,Kmm) ) * umask(k%I,k%J,1) + END SELECT + + zdep= gdept(k%I,k%J,jk,Kmm) + + !------------------------------- + ! LOOP ON THE DENSITY CLASSES | + !------------------------------- + !The computation is made for each density/temperature/salinity/depth class + DO jclass=1,MAX(1,sec%nb_class-1) + + !----------------------------------------------! + !TEST ON THE DENSITY/SALINITY/TEMPERATURE/LEVEL! + !----------------------------------------------! + + IF ( ( & + ((( zrhop .GE. (sec%zsigp(jclass)+1000. )) .AND. & + ( zrhop .LE. (sec%zsigp(jclass+1)+1000. ))) .OR. & + ( sec%zsigp(jclass) .EQ. 99.)) .AND. & + + ((( zrhoi .GE. (sec%zsigi(jclass) + 1000. )) .AND. & + ( zrhoi .LE. (sec%zsigi(jclass+1)+1000. ))) .OR. & + ( sec%zsigi(jclass) .EQ. 99.)) .AND. & + + ((( zsn .GT. sec%zsal(jclass)) .AND. & + ( zsn .LE. sec%zsal(jclass+1))) .OR. & + ( sec%zsal(jclass) .EQ. 99.)) .AND. & + + ((( ztn .GE. sec%ztem(jclass)) .AND. & + ( ztn .LE. sec%ztem(jclass+1))) .OR. & + ( sec%ztem(jclass) .EQ.99.)) .AND. & + + ((( zdep .GE. sec%zlay(jclass)) .AND. & + ( zdep .LE. sec%zlay(jclass+1))) .OR. & + ( sec%zlay(jclass) .EQ. 99. )) & + )) THEN + + !SUM THE TRANSPORTS FOR EACH CLASSES FOR THE POSITIVE AND NEGATIVE DIRECTIONS + !---------------------------------------------------------------------------- + IF (transports_3d(1,jsec,jseg,jk) .GE. 0.0) THEN + sec%transport(1,jclass) = sec%transport(1,jclass)+transports_3d(1,jsec,jseg,jk)*1.E-6 + ELSE + sec%transport(2,jclass) = sec%transport(2,jclass)+transports_3d(1,jsec,jseg,jk)*1.E-6 + ENDIF + IF( sec%llstrpond )THEN + + IF ( transports_3d(2,jsec,jseg,jk) .GE. 0.0 ) THEN + sec%transport(3,jclass) = sec%transport(3,jclass)+transports_3d(2,jsec,jseg,jk) + ELSE + sec%transport(4,jclass) = sec%transport(4,jclass)+transports_3d(2,jsec,jseg,jk) + ENDIF + + IF ( transports_3d(3,jsec,jseg,jk) .GE. 0.0 ) THEN + sec%transport(5,jclass) = sec%transport(5,jclass)+transports_3d(3,jsec,jseg,jk) + ELSE + sec%transport(6,jclass) = sec%transport(6,jclass)+transports_3d(3,jsec,jseg,jk) + ENDIF + + ELSE + sec%transport( 3,jclass) = 0._wp + sec%transport( 4,jclass) = 0._wp + sec%transport( 5,jclass) = 0._wp + sec%transport( 6,jclass) = 0._wp + ENDIF + + ENDIF ! end of test if point is in class + + END DO ! end of loop on the classes + + END DO ! loop over jk + +#if defined key_si3 + + !ICE CASE + IF( sec%ll_ice_section )THEN + + IF ( transports_2d(1,jsec,jseg) .GE. 0.0 ) THEN + sec%transport( 7,1) = sec%transport( 7,1)+transports_2d(1,jsec,jseg)*1.E-6 + ELSE + sec%transport( 8,1) = sec%transport( 8,1)+transports_2d(1,jsec,jseg)*1.E-6 + ENDIF + + IF ( transports_2d(3,jsec,jseg) .GE. 0.0 ) THEN + sec%transport( 9,1) = sec%transport( 9,1)+transports_2d(2,jsec,jseg)*1.E-6 + ELSE + sec%transport(10,1) = sec%transport(10,1)+transports_2d(2,jsec,jseg)*1.E-6 + ENDIF + + ENDIF !end of ice case +#endif + + END DO !end of loop on the segment + + ELSE !if sec%nb_point =0 + sec%transport(1:2,:)=0. + IF (sec%llstrpond) sec%transport(3:6,:)=0. + IF (sec%ll_ice_section) sec%transport(7:10,:)=0. + ENDIF !end of sec%nb_point =0 case + + END SUBROUTINE dia_dct_sum + + + SUBROUTINE dia_dct_wri(kt,ksec,sec) + !!------------------------------------------------------------- + !! Write transport output in numdct + !! + !! Purpose: Write transports in ascii files + !! + !! Method: + !! 1. Write volume transports in "volume_transport" + !! Unit: Sv : area * Velocity / 1.e6 + !! + !! 2. Write heat transports in "heat_transport" + !! Unit: Peta W : area * Velocity * T * rhop * Cp * 1.e-15 + !! + !! 3. Write salt transports in "salt_transport" + !! Unit: 10^9 Kg/m^2/s : area * Velocity * S * rhop * 1.e-9 + !! + !!------------------------------------------------------------- + !!arguments + INTEGER, INTENT(IN) :: kt ! time-step + TYPE(SECTION), INTENT(INOUT) :: sec ! section to write + INTEGER ,INTENT(IN) :: ksec ! section number + + !!local declarations + INTEGER :: jclass ! Dummy loop + CHARACTER(len=2) :: classe ! Classname + REAL(wp) :: zbnd1,zbnd2 ! Class bounds + REAL(wp) :: zslope ! section's slope coeff + ! + REAL(wp), DIMENSION(nb_type_class):: zsumclasses ! 1D workspace + !!------------------------------------------------------------- + + zsumclasses(:)=0._wp + zslope = sec%slopeSection + + + DO jclass=1,MAX(1,sec%nb_class-1) + + classe = 'N ' + zbnd1 = 0._wp + zbnd2 = 0._wp + zsumclasses(1:nb_type_class)=zsumclasses(1:nb_type_class)+sec%transport(1:nb_type_class,jclass) + + + !insitu density classes transports + IF( ( sec%zsigi(jclass) .NE. 99._wp ) .AND. & + ( sec%zsigi(jclass+1) .NE. 99._wp ) )THEN + classe = 'DI ' + zbnd1 = sec%zsigi(jclass) + zbnd2 = sec%zsigi(jclass+1) + ENDIF + !potential density classes transports + IF( ( sec%zsigp(jclass) .NE. 99._wp ) .AND. & + ( sec%zsigp(jclass+1) .NE. 99._wp ) )THEN + classe = 'DP ' + zbnd1 = sec%zsigp(jclass) + zbnd2 = sec%zsigp(jclass+1) + ENDIF + !depth classes transports + IF( ( sec%zlay(jclass) .NE. 99._wp ) .AND. & + ( sec%zlay(jclass+1) .NE. 99._wp ) )THEN + classe = 'Z ' + zbnd1 = sec%zlay(jclass) + zbnd2 = sec%zlay(jclass+1) + ENDIF + !salinity classes transports + IF( ( sec%zsal(jclass) .NE. 99._wp ) .AND. & + ( sec%zsal(jclass+1) .NE. 99._wp ) )THEN + classe = 'S ' + zbnd1 = sec%zsal(jclass) + zbnd2 = sec%zsal(jclass+1) + ENDIF + !temperature classes transports + IF( ( sec%ztem(jclass) .NE. 99._wp ) .AND. & + ( sec%ztem(jclass+1) .NE. 99._wp ) ) THEN + classe = 'T ' + zbnd1 = sec%ztem(jclass) + zbnd2 = sec%ztem(jclass+1) + ENDIF + + !write volume transport per class + WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope, & + jclass,classe,zbnd1,zbnd2,& + sec%transport(1,jclass),sec%transport(2,jclass), & + sec%transport(1,jclass)+sec%transport(2,jclass) + + IF( sec%llstrpond )THEN + + !write heat transport per class: + WRITE(numdct_heat,119) ndastp,kt,ksec,sec%name,zslope, & + jclass,classe,zbnd1,zbnd2,& + sec%transport(3,jclass)*1.e-15,sec%transport(4,jclass)*1.e-15, & + ( sec%transport(3,jclass)+sec%transport(4,jclass) )*1.e-15 + !write salt transport per class + WRITE(numdct_salt,119) ndastp,kt,ksec,sec%name,zslope, & + jclass,classe,zbnd1,zbnd2,& + sec%transport(5,jclass)*1.e-9,sec%transport(6,jclass)*1.e-9,& + (sec%transport(5,jclass)+sec%transport(6,jclass))*1.e-9 + ENDIF + + ENDDO + + zbnd1 = 0._wp + zbnd2 = 0._wp + jclass=0 + + !write total volume transport + WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope, & + jclass,"total",zbnd1,zbnd2,& + zsumclasses(1),zsumclasses(2),zsumclasses(1)+zsumclasses(2) + + IF( sec%llstrpond )THEN + + !write total heat transport + WRITE(numdct_heat,119) ndastp,kt,ksec,sec%name,zslope, & + jclass,"total",zbnd1,zbnd2,& + zsumclasses(3)*1.e-15,zsumclasses(4)*1.e-15,& + (zsumclasses(3)+zsumclasses(4) )*1.e-15 + !write total salt transport + WRITE(numdct_salt,119) ndastp,kt,ksec,sec%name,zslope, & + jclass,"total",zbnd1,zbnd2,& + zsumclasses(5)*1.e-9,zsumclasses(6)*1.e-9,& + (zsumclasses(5)+zsumclasses(6))*1.e-9 + ENDIF + + + IF ( sec%ll_ice_section) THEN + !write total ice volume transport + WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope,& + jclass,"ice_vol",zbnd1,zbnd2,& + sec%transport(7,1),sec%transport(8,1),& + sec%transport(7,1)+sec%transport(8,1) + !write total ice surface transport + WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope,& + jclass,"ice_surf",zbnd1,zbnd2,& + sec%transport(9,1),sec%transport(10,1), & + sec%transport(9,1)+sec%transport(10,1) + ENDIF + +118 FORMAT(I8,1X,I8,1X,I4,1X,A30,1X,f9.2,1X,I4,3X,A8,1X,2F12.4,5X,3F12.4) +119 FORMAT(I8,1X,I8,1X,I4,1X,A30,1X,f9.2,1X,I4,3X,A8,1X,2F12.4,5X,3E15.6) + ! + END SUBROUTINE dia_dct_wri + + + FUNCTION interp(Kmm, ki, kj, kk, cd_point, ptab) + !!---------------------------------------------------------------------- + !! + !! Purpose: compute temperature/salinity/density at U-point or V-point + !! -------- + !! + !! Method: + !! ------ + !! + !! ====> full step and partial step + !! + !! + !! | I | I+1 | Z=temperature/salinity/density at U-poinT + !! | | | + !! ---------------------------------------- 1. Veritcal interpolation: compute zbis + !! | | | interpolation between ptab(I,J,K) and ptab(I,J,K+1) + !! | | | zbis = + !! | | | [ e3w_n(I+1,J,K,NOW)*ptab(I,J,K) + ( e3w_n(I,J,K,NOW) - e3w_n(I+1,J,K,NOW) ) * ptab(I,J,K-1) ] + !! | | | /[ e3w_n(I+1,J,K,NOW) + e3w_n(I,J,K,NOW) - e3w_n(I+1,J,K,NOW) ] + !! | | | + !! | | | 2. Horizontal interpolation: compute value at U/V point + !!K-1 | ptab(I,J,K-1) | | interpolation between zbis and ptab(I+1,J,K) + !! | . | | + !! | . | | interp = ( 0.5*zet2*zbis + 0.5*zet1*ptab(I+1,J,K) )/(0.5*zet2+0.5*zet1) + !! | . | | + !! ------------------------------------------ + !! | . | | + !! | . | | + !! | . | | + !!K | zbis.......U...ptab(I+1,J,K) | + !! | . | | + !! | ptab(I,J,K) | | + !! | |------------------| + !! | | partials | + !! | | steps | + !! ------------------------------------------- + !! <----zet1------><----zet2---------> + !! + !! + !! ====> s-coordinate + !! + !! | | | 1. Compute distance between T1 and U points: SQRT( zdep1^2 + (0.5 * zet1 )^2 + !! | | | Compute distance between T2 and U points: SQRT( zdep2^2 + (0.5 * zet2 )^2 + !! | | ptab(I+1,J,K) | + !! | | T2 | 2. Interpolation between T1 and T2 values at U point + !! | | ^ | + !! | | | zdep2 | + !! | | | | + !! | ^ U v | + !! | | | | + !! | | zdep1 | | + !! | v | | + !! | T1 | | + !! | ptab(I,J,K) | | + !! | | | + !! | | | + !! + !! <----zet1--------><----zet2---------> + !! + !!---------------------------------------------------------------------- + !*arguments + INTEGER, INTENT(IN) :: Kmm ! time level index + INTEGER, INTENT(IN) :: ki, kj, kk ! coordinate of point + CHARACTER(len=1), INTENT(IN) :: cd_point ! type of point (U, V) + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(IN) :: ptab ! variable to compute at (ki, kj, kk ) + REAL(wp) :: interp ! interpolated variable + + !*local declations + INTEGER :: ii1, ij1, ii2, ij2 ! local integer + REAL(wp):: ze3t, ze3, zwgt1, zwgt2, zbis, zdepu ! local real + REAL(wp):: zet1, zet2 ! weight for interpolation + REAL(wp):: zdep1,zdep2 ! differences of depth + REAL(wp):: zmsk ! mask value + !!---------------------------------------------------------------------- + + IF( cd_point=='U' )THEN + ii1 = ki ; ij1 = kj + ii2 = ki+1 ; ij2 = kj + + zet1=e1t(ii1,ij1) + zet2=e1t(ii2,ij2) + zmsk=umask(ii1,ij1,kk) + + + ELSE ! cd_point=='V' + ii1 = ki ; ij1 = kj + ii2 = ki ; ij2 = kj+1 + + zet1=e2t(ii1,ij1) + zet2=e2t(ii2,ij2) + zmsk=vmask(ii1,ij1,kk) + + ENDIF + + IF( ln_sco )THEN ! s-coordinate case + + zdepu = ( gdept(ii1,ij1,kk,Kmm) + gdept(ii2,ij2,kk,Kmm) ) * 0.5_wp + zdep1 = gdept(ii1,ij1,kk,Kmm) - zdepu + zdep2 = gdept(ii2,ij2,kk,Kmm) - zdepu + + ! weights + zwgt1 = SQRT( ( 0.5 * zet1 ) * ( 0.5 * zet1 ) + ( zdep1 * zdep1 ) ) + zwgt2 = SQRT( ( 0.5 * zet2 ) * ( 0.5 * zet2 ) + ( zdep2 * zdep2 ) ) + + ! result + interp = zmsk * ( zwgt2 * ptab(ii1,ij1,kk) + zwgt1 * ptab(ii1,ij1,kk) ) / ( zwgt2 + zwgt1 ) + + + ELSE ! full step or partial step case + + ze3t = e3t(ii2,ij2,kk,Kmm) - e3t(ii1,ij1,kk,Kmm) + zwgt1 = ( e3w(ii2,ij2,kk,Kmm) - e3w(ii1,ij1,kk,Kmm) ) & + & / e3w(ii2,ij2,kk,Kmm) + zwgt2 = ( e3w(ii1,ij1,kk,Kmm) - e3w(ii2,ij2,kk,Kmm) ) & + & / e3w(ii1,ij1,kk,Kmm) + + IF(kk .NE. 1)THEN + + IF( ze3t >= 0. )THEN + ! zbis + zbis = ptab(ii2,ij2,kk) + zwgt1 * ( ptab(ii2,ij2,kk-1) - ptab(ii2,ij2,kk) ) + ! result + interp = zmsk * ( zet2 * ptab(ii1,ij1,kk) + zet1 * zbis )/( zet1 + zet2 ) + ELSE + ! zbis + zbis = ptab(ii1,ij1,kk) + zwgt2 * ( ptab(ii1,ij1,kk-1) - ptab(ii1,ij2,kk) ) + ! result + interp = zmsk * ( zet2 * zbis + zet1 * ptab(ii2,ij2,kk) )/( zet1 + zet2 ) + ENDIF + + ELSE + interp = zmsk * ( zet2 * ptab(ii1,ij1,kk) + zet1 * ptab(ii2,ij2,kk) )/( zet1 + zet2 ) + ENDIF + + ENDIF + ! + END FUNCTION interp + +#else + !!---------------------------------------------------------------------- + !! Dummy module + !!---------------------------------------------------------------------- + LOGICAL, PUBLIC :: ln_diadct = .FALSE. +CONTAINS + SUBROUTINE dia_dct_init + IMPLICIT NONE + END SUBROUTINE dia_dct_init + + SUBROUTINE dia_dct( kt, Kmm ) ! Dummy routine + IMPLICIT NONE + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER, INTENT( in ) :: Kmm ! ocean time level index + WRITE(*,*) 'dia_dct: You should not have seen this print! error?', kt + END SUBROUTINE dia_dct + ! +#endif + + !!====================================================================== +END MODULE diadct \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diadetide.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diadetide.F90 new file mode 100644 index 0000000..7d27718 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diadetide.F90 @@ -0,0 +1,113 @@ +MODULE diadetide + !!====================================================================== + !! *** MODULE diadetide *** + !! Computation of weights for daily detided model diagnostics + !!====================================================================== + !! History : ! 2019 (S. Mueller) + !!---------------------------------------------------------------------- + USE par_kind + USE par_oce , ONLY : wp, jpi, jpj + USE in_out_manager , ONLY : lwp, numout + USE iom , ONLY : iom_put + USE dom_oce , ONLY : rn_Dt, nsec_day + USE phycst , ONLY : rpi + USE tide_mod +#if defined key_xios + USE xios +#endif + + IMPLICIT NONE + PRIVATE + + LOGICAL, PUBLIC :: lk_diadetide + INTEGER :: ndiadetide + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: tdiadetide + + PUBLIC :: dia_detide_init, dia_detide + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2019) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_detide_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_detide_init *** + !! + !! ** Purpose : initialisation of the weight computation for daily + !! detided diagnostics (currently M2-detiding only) + !! + !!---------------------------------------------------------------------- + + REAL(wp) :: zdt + INTEGER :: jn + CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: ctide_selected = ' n/a ' + TYPE(tide_harmonic), DIMENSION(:), POINTER :: stideconst + + lk_diadetide = .FALSE. +#if defined key_xios + ! Enquire detiding activation state (test for presence of detiding-related + ! weights field and output file group) + IF ( xios_is_valid_field( "diadetide_weight" ).AND.xios_is_valid_filegroup( "diadetide_files" ).AND.ln_tide ) THEN + lk_diadetide = .TRUE. + END IF +#endif + + IF (lwp) THEN + WRITE (numout, *) + WRITE (numout, *) 'dia_detide_init : weight computation for daily detided model diagnostics' + WRITE (numout, *) '~~~~~~~~~~~~~~~' + WRITE (numout, *) ' lk_diadetide = ', lk_diadetide + END IF + + IF (lk_diadetide) THEN + ! Retrieve information about M2 tidal constituent + ctide_selected(1) = 'M2' + CALL tide_init_harmonics(ctide_selected, stideconst) + + ! For M2, twice the tidal period spans slightly more than one full + ! day. Compute the maximum number of equal intervals that span exactly + ! twice the tidal period *and* whose mid-points fall within a 24-hour + ! period from midnight to midnight. + zdt = 2.0_wp * 2.0_wp * rpi / stideconst(1)%omega + ndiadetide = FLOOR( zdt / ( zdt - 86400.0_wp ) ) + ! Compute mid-points of the intervals to be included in the detided + ! average + ALLOCATE ( tdiadetide(ndiadetide) ) + DO jn = 1, ndiadetide + tdiadetide(jn) = ( REAL( jn, KIND=wp) - 0.5_wp ) * zdt / REAL( ndiadetide, KIND=wp ) - ( zdt - 86400.0_wp ) * 0.5_wp + END DO + END IF + + END SUBROUTINE dia_detide_init + + SUBROUTINE dia_detide( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_detide *** + !! + !! ** Purpose : weight computation for daily detided model diagnostics + !!---------------------------------------------------------------------- + + INTEGER, INTENT(in) :: kt + REAL(wp), DIMENSION(jpi,jpj) :: zwght_2D + REAL(wp) :: zwght, ztmp + INTEGER :: jn + + ! Compute detiding weight at the current time-step; the daily total weight + ! is one, and the daily summation of a diagnosed field multiplied by this + ! weight should provide daily detided averages + zwght = 0.0_wp + DO jn = 1, ndiadetide + ztmp = ( tdiadetide(jn) - REAL( nsec_day, KIND=wp ) ) / rn_Dt + IF ( ( ztmp < 0.5_wp ).AND.( ztmp >= -0.5_wp ) ) THEN + zwght = zwght + 1.0_wp / REAL( ndiadetide, KIND=wp ) + END IF + END DO + zwght_2D(:,:) = zwght + CALL iom_put( "diadetide_weight", zwght_2D) + + END SUBROUTINE dia_detide + +END MODULE diadetide \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diahsb.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diahsb.F90 new file mode 100644 index 0000000..d189fd3 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diahsb.F90 @@ -0,0 +1,446 @@ +MODULE diahsb + !!====================================================================== + !! *** MODULE diahsb *** + !! Ocean diagnostics: Heat, salt and volume budgets + !!====================================================================== + !! History : 3.3 ! 2010-09 (M. Leclair) Original code + !! ! 2012-10 (C. Rousset) add iom_put + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dia_hsb : Diagnose the conservation of ocean heat and salt contents, and volume + !! dia_hsb_rst : Read or write DIA file in restart file + !! dia_hsb_init : Initialization of the conservation diagnostic + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbc_oce ! surface thermohaline fluxes + USE isf_oce ! ice shelf fluxes + USE sbcrnf ! river runoff + USE domvvl ! vertical scale factors + USE traqsr ! penetrative solar radiation + USE trabbc ! bottom boundary condition + USE trabbc ! bottom boundary condition + USE restart ! ocean restart + USE bdy_oce , ONLY : ln_bdy + ! + USE iom ! I/O manager + USE in_out_manager ! I/O manager + USE lib_fortran ! glob_sum + USE lib_mpp ! distributed memory computing library + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_hsb ! routine called by step.F90 + PUBLIC dia_hsb_init ! routine called by nemogcm.F90 + + LOGICAL, PUBLIC :: ln_diahsb !: check the heat and salt budgets + + REAL(wp) :: surf_tot ! ocean surface + REAL(wp) :: frc_s! global forcing trends + REAL(dp) :: frc_t, frc_v! global forcing trends + REAL(wp) :: frc_wn_t, frc_wn_s ! global forcing trends + ! + REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: surf + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ssh_ini! + REAL(dp), DIMENSION(:,:) , ALLOCATABLE :: surf_ini! + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ssh_hc_loc_ini, ssh_sc_loc_ini ! + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: hc_loc_ini! + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: sc_loc_ini, e3t_ini! + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_ini + + !! * Substitutions +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diahsb.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_hsb( kt, Kbb, Kmm ) + !!--------------------------------------------------------------------------- + !! *** ROUTINE dia_hsb *** + !! + !! ** Purpose: Compute the ocean global heat content, salt content and volume conservation + !! + !! ** Method : - Compute the deviation of heat content, salt content and volume + !! at the current time step from their values at nit000 + !! - Compute the contribution of forcing and remove it from these deviations + !! + !!--------------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indice + REAL(wp) :: zdiff_hc , zdiff_sc ! heat and salt content variations + REAL(wp) :: zdiff_hc1 , zdiff_sc1 ! - - - - + REAL(dp) :: zdiff_v1 , zdiff_v2 ! volume variation + REAL(wp) :: zerr_hc1 , zerr_sc1 ! heat and salt content misfit + REAL(wp) :: zvol_tot ! volume + REAL(wp) :: z_frc_trd_t , z_frc_trd_s ! - - + REAL(dp) :: z_frc_trd_v ! - - + REAL(wp) :: z_wn_trd_t , z_wn_trd_s ! - - + REAL(wp) :: z_ssh_hc , z_ssh_sc ! - - + REAL(dp), DIMENSION(jpi,jpj,13) :: ztmp + REAL(dp), DIMENSION(jpi,jpj,jpkm1,4) :: ztmpk + REAL(dp), DIMENSION(17) :: zbg + !!--------------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('dia_hsb') + ! + ztmp (:,:,:) = 0._wp ! should be better coded + ztmpk(:,:,:,:) = 0._wp ! should be better coded + ! + ts(:,:,:,1,Kmm) = ts(:,:,:,1,Kmm) * tmask(:,:,:) ; ts(:,:,:,1,Kbb) = ts(:,:,:,1,Kbb) * tmask(:,:,:) ; + ts(:,:,:,2,Kmm) = ts(:,:,:,2,Kmm) * tmask(:,:,:) ; ts(:,:,:,2,Kbb) = ts(:,:,:,2,Kbb) * tmask(:,:,:) ; + ! + ! ------------------------- ! + ! 1 - Trends due to forcing ! + ! ------------------------- ! + ! prepare trends + ztmp(:,:,1) = - r1_rho0 * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) ) * surf(:,:) ! volume + ztmp(:,:,2) = sbc_tsc(:,:,jp_tem) * surf(:,:) ! heat + ztmp(:,:,3) = sbc_tsc(:,:,jp_sal) * surf(:,:) ! salt + IF( ln_rnf ) ztmp(:,:,4) = rnf_tsc(:,:,jp_tem) * surf(:,:) ! runoff temp + IF( ln_rnf_sal ) ztmp(:,:,5) = rnf_tsc(:,:,jp_sal) * surf(:,:) ! runoff salt + IF( ln_isf ) ztmp(:,:,6) = ( risf_cav_tsc(:,:,jp_tem) + risf_par_tsc(:,:,jp_tem) ) * surf(:,:) ! isf temp + IF( ln_traqsr ) ztmp(:,:,7) = r1_rho0_rcp * qsr(:,:) * surf(:,:) ! penetrative solar radiation + IF( ln_trabbc ) ztmp(:,:,8) = qgh_trd0(:,:) * surf(:,:) ! geothermal heat + ! + IF( ln_linssh ) THEN ! Advection flux through fixed surface (z=0) + IF( ln_isfcav ) THEN + DO ji=1,jpi + DO jj=1,jpj + ztmp(ji,jj,9 ) = - surf(ji,jj) * ww(ji,jj,mikt(ji,jj)) * ts(ji,jj,mikt(ji,jj),jp_tem,Kbb) + ztmp(ji,jj,10) = - surf(ji,jj) * ww(ji,jj,mikt(ji,jj)) * ts(ji,jj,mikt(ji,jj),jp_sal,Kbb) + END DO + END DO + ELSE + ztmp(:,:,9 ) = - surf(:,:) * ww(:,:,1) * ts(:,:,1,jp_tem,Kbb) + ztmp(:,:,10) = - surf(:,:) * ww(:,:,1) * ts(:,:,1,jp_sal,Kbb) + END IF + ENDIF + + ! global sum + zbg(1:10) = glob_sum_vec( 'dia_hsb', ztmp(:,:,1:10) ) + + ! adding up + z_frc_trd_v = zbg(1) ! volume fluxes + z_frc_trd_t = zbg(2) ! heat fluxes + z_frc_trd_s = zbg(3) ! salt fluxes + IF( ln_rnf ) z_frc_trd_t = z_frc_trd_t + zbg(4) ! runoff heat + IF( ln_rnf_sal) z_frc_trd_s = z_frc_trd_s + zbg(5) ! runoff salt + IF( ln_isf ) z_frc_trd_t = z_frc_trd_t + zbg(6) ! isf heat + IF( ln_traqsr ) z_frc_trd_t = z_frc_trd_t + zbg(7) ! penetrative solar flux + IF( ln_trabbc ) z_frc_trd_t = z_frc_trd_t + zbg(8) ! geothermal heat + ! + frc_v = frc_v + z_frc_trd_v * rn_Dt + frc_t = frc_t + z_frc_trd_t * rn_Dt + frc_s = frc_s + z_frc_trd_s * rn_Dt + ! ! Advection flux through fixed surface (z=0) + IF( ln_linssh ) THEN + z_wn_trd_t = zbg(9) + z_wn_trd_s = zbg(10) + ! + frc_wn_t = frc_wn_t + z_wn_trd_t * rn_Dt + frc_wn_s = frc_wn_s + z_wn_trd_s * rn_Dt + ENDIF + + ! --------------------------------- ! + ! 2 - Content variations with ssh ! + ! --------------------------------- ! + ! glob_sum is needed because you keep only the interior domain to compute the sum (iscpl) + ! + ! ! volume variation (calculated with ssh) + ztmp(:,:,11) = surf(:,:)*ssh(:,:,Kmm) - surf_ini(:,:)*ssh_ini(:,:) + + ! ! heat & salt content variation (associated with ssh) + IF( ln_linssh ) THEN ! linear free surface case + IF( ln_isfcav ) THEN ! ISF case + DO ji = 1, jpi + DO jj = 1, jpj + ztmp(ji,jj,12) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_tem,Kmm) * ssh(ji,jj,Kmm) - ssh_hc_loc_ini(ji,jj) ) + ztmp(ji,jj,13) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_sal,Kmm) * ssh(ji,jj,Kmm) - ssh_sc_loc_ini(ji,jj) ) + END DO + END DO + ELSE ! no under ice-shelf seas + ztmp(:,:,12) = surf(:,:) * ( ts(:,:,1,jp_tem,Kmm) * ssh(:,:,Kmm) - ssh_hc_loc_ini(:,:) ) + ztmp(:,:,13) = surf(:,:) * ( ts(:,:,1,jp_sal,Kmm) * ssh(:,:,Kmm) - ssh_sc_loc_ini(:,:) ) + END IF + ENDIF + + ! global sum + zbg(11:13) = glob_sum_vec( 'dia_hsb', ztmp(:,:,11:13) ) + + zdiff_v1 = zbg(11) + ! ! heat & salt content variation (associated with ssh) + IF( ln_linssh ) THEN ! linear free surface case + z_ssh_hc = zbg(12) + z_ssh_sc = zbg(13) + ENDIF + ! + ! --------------------------------- ! + ! 3 - Content variations with e3t ! + ! --------------------------------- ! + ! glob_sum is needed because you keep only the interior domain to compute the sum (iscpl) + ! + DO jk = 1, jpkm1 ! volume + ztmpk(:,:,jk,1) = surf (:,:) * e3t(:,:,jk,Kmm)*tmask(:,:,jk) & + & - surf_ini(:,:) * e3t_ini(:,:,jk )*tmask_ini(:,:,jk) + END DO + DO jk = 1, jpkm1 ! heat + ztmpk(:,:,jk,2) = ( surf (:,:) * e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_tem,Kmm) & + & - surf_ini(:,:) * hc_loc_ini(:,:,jk) ) + END DO + DO jk = 1, jpkm1 ! salt + ztmpk(:,:,jk,3) = ( surf (:,:) * e3t(:,:,jk,Kmm)*ts(:,:,jk,jp_sal,Kmm) & + & - surf_ini(:,:) * sc_loc_ini(:,:,jk) ) + END DO + DO jk = 1, jpkm1 ! total ocean volume + ztmpk(:,:,jk,4) = surf(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk) + END DO + + ! global sum + zbg(14:17) = glob_sum_vec( 'dia_hsb', ztmpk(:,:,:,1:4) ) + + zdiff_v2 = zbg(14) ! glob_sum needed as tmask and tmask_ini could be different + zdiff_hc = zbg(15) + zdiff_sc = zbg(16) + zvol_tot = zbg(17) + + ! ------------------------ ! + ! 4 - Drifts ! + ! ------------------------ ! + zdiff_v1 = zdiff_v1 - frc_v + IF( .NOT.ln_linssh ) zdiff_v2 = zdiff_v2 - frc_v + zdiff_hc = zdiff_hc - frc_t + zdiff_sc = zdiff_sc - frc_s + IF( ln_linssh ) THEN + zdiff_hc1 = zdiff_hc + z_ssh_hc + zdiff_sc1 = zdiff_sc + z_ssh_sc + zerr_hc1 = z_ssh_hc - frc_wn_t + zerr_sc1 = z_ssh_sc - frc_wn_s + ENDIF + +!!gm to be added ? +! IF( ln_linssh ) THEN ! fixed volume, add the ssh contribution +! zvol_tot = zvol_tot + glob_sum( 'diahsb', surf(:,:) * ssh(:,:,Kmm) ) +! ENDIF +!!gm end + + CALL iom_put( 'bgfrcvol' , frc_v * 1.e-9 ) ! vol - surface forcing (km3) + CALL iom_put( 'bgfrctem' , frc_t * rho0 * rcp * 1.e-20 ) ! hc - surface forcing (1.e20 J) + CALL iom_put( 'bgfrchfx' , frc_t * rho0 * rcp / & ! hc - surface forcing (W/m2) + & ( surf_tot * kt * rn_Dt ) ) + CALL iom_put( 'bgfrcsal' , frc_s * 1.e-9 ) ! sc - surface forcing (psu*km3) + + IF( .NOT. ln_linssh ) THEN + CALL iom_put( 'bgtemper' , zdiff_hc / zvol_tot ) ! Temperature drift (C) + CALL iom_put( 'bgsaline' , zdiff_sc / zvol_tot ) ! Salinity drift (PSU) + CALL iom_put( 'bgheatco' , zdiff_hc * 1.e-20 * rho0 * rcp ) ! Heat content drift (1.e20 J) + CALL iom_put( 'bgheatfx' , zdiff_hc * rho0 * rcp / & ! Heat flux drift (W/m2) + & ( surf_tot * kt * rn_Dt ) ) + CALL iom_put( 'bgsaltco' , zdiff_sc * 1.e-9 ) ! Salt content drift (psu*km3) + CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9 ) ! volume ssh drift (km3) + CALL iom_put( 'bgvole3t' , zdiff_v2 * 1.e-9 ) ! volume e3t drift (km3) + ! + IF( kt == nitend .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'dia_hsb : last time step hsb diagnostics: at it= ', kt,' date= ', ndastp + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) ' Temperature drift = ', zdiff_hc / zvol_tot, ' C' + WRITE(numout,*) ' Salinity drift = ', zdiff_sc / zvol_tot, ' PSU' + WRITE(numout,*) ' volume ssh drift = ', zdiff_v1 * 1.e-9 , ' km^3' + WRITE(numout,*) ' volume e3t drift = ', zdiff_v2 * 1.e-9 , ' km^3' + ENDIF + ! + ELSE + CALL iom_put( 'bgtemper' , zdiff_hc1 / zvol_tot) ! Heat content drift (C) + CALL iom_put( 'bgsaline' , zdiff_sc1 / zvol_tot) ! Salt content drift (PSU) + CALL iom_put( 'bgheatco' , zdiff_hc1 * 1.e-20 * rho0 * rcp ) ! Heat content drift (1.e20 J) + CALL iom_put( 'bgheatfx' , zdiff_hc1 * rho0 * rcp / & ! Heat flux drift (W/m2) + & ( surf_tot * kt * rn_Dt ) ) + CALL iom_put( 'bgsaltco' , zdiff_sc1 * 1.e-9 ) ! Salt content drift (psu*km3) + CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9 ) ! volume ssh drift (km3) + CALL iom_put( 'bgmistem' , zerr_hc1 / zvol_tot ) ! hc - error due to free surface (C) + CALL iom_put( 'bgmissal' , zerr_sc1 / zvol_tot ) ! sc - error due to free surface (psu) + ENDIF + ! + IF( lrst_oce ) CALL dia_hsb_rst( kt, Kmm, 'WRITE' ) + ! + IF( ln_timing ) CALL timing_stop('dia_hsb') + ! + END SUBROUTINE dia_hsb + + + SUBROUTINE dia_hsb_rst( kt, Kmm, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dia_hsb_rst *** + !! + !! ** Purpose : Read or write DIA file in restart file + !! + !! ** Method : use of IOM library + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: Kmm ! ocean time level index + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + ! + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise + IF( ln_rstart ) THEN !* Read the restart file + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' dia_hsb_rst : read hsb restart at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) + CALL iom_get( numror, 'frc_v', frc_v ) + CALL iom_get( numror, 'frc_t', frc_t ) + CALL iom_get( numror, 'frc_s', frc_s ) + IF( ln_linssh ) THEN + CALL iom_get( numror, 'frc_wn_t', frc_wn_t ) + CALL iom_get( numror, 'frc_wn_s', frc_wn_s ) + ENDIF + CALL iom_get( numror, jpdom_auto, 'surf_ini' , surf_ini ) ! ice sheet coupling + CALL iom_get( numror, jpdom_auto, 'ssh_ini' , ssh_ini ) + CALL iom_get( numror, jpdom_auto, 'e3t_ini' , e3t_ini ) + CALL iom_get( numror, jpdom_auto, 'tmask_ini' , tmask_ini ) + CALL iom_get( numror, jpdom_auto, 'hc_loc_ini', hc_loc_ini ) + CALL iom_get( numror, jpdom_auto, 'sc_loc_ini', sc_loc_ini ) + IF( ln_linssh ) THEN + CALL iom_get( numror, jpdom_auto, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) + CALL iom_get( numror, jpdom_auto, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) + ENDIF + ELSE + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' dia_hsb_rst : initialise hsb at initial state ' + IF(lwp) WRITE(numout,*) + surf_ini(:,:) = e1e2t(:,:) * tmask_i(:,:) ! initial ocean surface + ssh_ini(:,:) = ssh(:,:,Kmm) ! initial ssh + DO jk = 1, jpk + ! if ice sheet/oceqn coupling, need to mask ini variables here (mask could change at the next NEMO instance). + e3t_ini (:,:,jk) = e3t(:,:,jk,Kmm) * tmask(:,:,jk) ! initial vertical scale factors + tmask_ini (:,:,jk) = tmask(:,:,jk) ! initial mask + hc_loc_ini(:,:,jk) = ts(:,:,jk,jp_tem,Kmm) * e3t(:,:,jk,Kmm) * tmask(:,:,jk) ! initial heat content + sc_loc_ini(:,:,jk) = ts(:,:,jk,jp_sal,Kmm) * e3t(:,:,jk,Kmm) * tmask(:,:,jk) ! initial salt content + END DO + frc_v = 0._wp ! volume trend due to forcing + frc_t = 0._wp ! heat content - - - - + frc_s = 0._wp ! salt content - - - - + IF( ln_linssh ) THEN + IF( ln_isfcav ) THEN + DO ji = 1, jpi + DO jj = 1, jpj + ssh_hc_loc_ini(ji,jj) = ts(ji,jj,mikt(ji,jj),jp_tem,Kmm) * ssh(ji,jj,Kmm) ! initial heat content in ssh + ssh_sc_loc_ini(ji,jj) = ts(ji,jj,mikt(ji,jj),jp_sal,Kmm) * ssh(ji,jj,Kmm) ! initial salt content in ssh + END DO + END DO + ELSE + ssh_hc_loc_ini(:,:) = ts(:,:,1,jp_tem,Kmm) * ssh(:,:,Kmm) ! initial heat content in ssh + ssh_sc_loc_ini(:,:) = ts(:,:,1,jp_sal,Kmm) * ssh(:,:,Kmm) ! initial salt content in ssh + END IF + frc_wn_t = 0._wp ! initial heat content misfit due to free surface + frc_wn_s = 0._wp ! initial salt content misfit due to free surface + ENDIF + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! ------------------- + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' dia_hsb_rst : write restart at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) + ! + CALL iom_rstput( kt, nitrst, numrow, 'frc_v', frc_v ) + CALL iom_rstput( kt, nitrst, numrow, 'frc_t', frc_t ) + CALL iom_rstput( kt, nitrst, numrow, 'frc_s', frc_s ) + IF( ln_linssh ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_t', frc_wn_t ) + CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s ) + ENDIF + CALL iom_rstput( kt, nitrst, numrow, 'surf_ini' , surf_ini ) ! ice sheet coupling + CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini' , ssh_ini ) + CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini' , e3t_ini ) + CALL iom_rstput( kt, nitrst, numrow, 'tmask_ini' , tmask_ini ) + CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini ) + CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini ) + IF( ln_linssh ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) + CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) + ENDIF + ! + ENDIF + ! + END SUBROUTINE dia_hsb_rst + + + SUBROUTINE dia_hsb_init( Kmm ) + !!--------------------------------------------------------------------------- + !! *** ROUTINE dia_hsb *** + !! + !! ** Purpose: Initialization for the heat salt volume budgets + !! + !! ** Method : Compute initial heat content, salt content and volume + !! + !! ** Action : - Compute initial heat content, salt content and volume + !! - Initialize forcing trends + !! - Compute coefficients for conversion + !!--------------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! time level index + ! + INTEGER :: ierror, ios ! local integer + !! + NAMELIST/namhsb/ ln_diahsb + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dia_hsb_init : heat and salt budgets diagnostics' + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + READ ( numnam_ref, namhsb, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namhsb in reference namelist' ) + READ ( numnam_cfg, namhsb, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namhsb in configuration namelist' ) + IF(lwm) WRITE( numond, namhsb ) + + IF(lwp) THEN + WRITE(numout,*) ' Namelist namhsb :' + WRITE(numout,*) ' check the heat and salt budgets (T) or not (F) ln_diahsb = ', ln_diahsb + ENDIF + ! + IF( .NOT. ln_diahsb ) RETURN + + ! ------------------- ! + ! 1 - Allocate memory ! + ! ------------------- ! + ALLOCATE( hc_loc_ini(jpi,jpj,jpk), sc_loc_ini(jpi,jpj,jpk), surf_ini(jpi,jpj), & + & e3t_ini(jpi,jpj,jpk), surf(jpi,jpj), ssh_ini(jpi,jpj), tmask_ini(jpi,jpj,jpk),STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'dia_hsb_init: unable to allocate hc_loc_ini' ) ; RETURN + ENDIF + + IF( ln_linssh ) ALLOCATE( ssh_hc_loc_ini(jpi,jpj), ssh_sc_loc_ini(jpi,jpj),STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'dia_hsb: unable to allocate ssh_hc_loc_ini' ) ; RETURN + ENDIF + + ! ----------------------------------------------- ! + ! 2 - Time independant variables and file opening ! + ! ----------------------------------------------- ! + surf(:,:) = e1e2t(:,:) * tmask_i(:,:) ! masked surface grid cell area + surf_tot = glob_sum( 'diahsb', surf(:,:) ) ! total ocean surface area + + IF( ln_bdy ) CALL ctl_warn( 'dia_hsb_init: heat/salt budget does not consider open boundary fluxes' ) + ! + ! ---------------------------------- ! + ! 4 - initial conservation variables ! + ! ---------------------------------- ! + CALL dia_hsb_rst( nit000, Kmm, 'READ' ) !* read or initialize all required files + ! + END SUBROUTINE dia_hsb_init + + !!====================================================================== +END MODULE diahsb \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diahth.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diahth.F90 new file mode 100644 index 0000000..285d85e --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diahth.F90 @@ -0,0 +1,372 @@ +MODULE diahth + !!====================================================================== + !! *** MODULE diahth *** + !! Ocean diagnostics: thermocline and 20 degree depth + !!====================================================================== + !! History : OPA ! 1994-09 (J.-P. Boulanger) Original code + !! ! 1996-11 (E. Guilyardi) OPA8 + !! ! 1997-08 (G. Madec) optimization + !! ! 1999-07 (E. Guilyardi) hd28 + heat content + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.2 ! 2009-07 (S. Masson) hc300 bugfix + cleaning + add new diag + !!---------------------------------------------------------------------- + !! dia_hth : Compute varius diagnostics associated with the mixed layer + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE iom ! I/O library + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_hth ! routine called by step.F90 + PUBLIC dia_hth_alloc ! routine called by nemogcm.F90 + + LOGICAL, SAVE :: l_hth !: thermocline-20d depths flag + + ! note: following variables should move to local variables once iom_put is always used + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hth !: depth of the max vertical temperature gradient [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd20 !: depth of 20 C isotherm [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd26 !: depth of 26 C isotherm [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd28 !: depth of 28 C isotherm [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc3 !: heat content of first 300 m [W] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc7 !: heat content of first 700 m [W] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc20 !: heat content of first 2000 m [W] + + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diahth.F90 15234 2021-09-08 14:07:02Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + FUNCTION dia_hth_alloc() + !!--------------------------------------------------------------------- + INTEGER :: dia_hth_alloc + !!--------------------------------------------------------------------- + ! + ALLOCATE( hth(jpi,jpj), hd20(jpi,jpj), hd26(jpi,jpj), hd28(jpi,jpj), & + & htc3(jpi,jpj), htc7(jpi,jpj), htc20(jpi,jpj), STAT=dia_hth_alloc ) + ! + CALL mpp_sum ( 'diahth', dia_hth_alloc ) + IF(dia_hth_alloc /= 0) CALL ctl_stop( 'STOP', 'dia_hth_alloc: failed to allocate arrays.' ) + ! + END FUNCTION dia_hth_alloc + + + SUBROUTINE dia_hth( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dia_hth *** + !! + !! ** Purpose : Computes + !! the mixing layer depth (turbocline): avt = 5.e-4 + !! the depth of strongest vertical temperature gradient + !! the mixed layer depth with density criteria: rho = rho(10m or surf) + 0.03(or 0.01) + !! the mixed layer depth with temperature criteria: abs( tn - tn(10m) ) = 0.2 + !! the top of the thermochine: tn = tn(10m) - ztem2 + !! the pycnocline depth with density criteria equivalent to a temperature variation + !! rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC) + !! the barrier layer thickness + !! the maximal verical inversion of temperature and its depth max( 0, max of tn - tn(10m) ) + !! the depth of the 20 degree isotherm (linear interpolation) + !! the depth of the 28 degree isotherm (linear interpolation) + !! the heat content of first 300 m + !! + !! ** Method : + !!------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER, INTENT( in ) :: Kmm ! ocean time level index + !! + INTEGER :: ji, jj, jk ! dummy loop arguments + REAL(wp) :: zrho3 = 0.03_wp ! density criterion for mixed layer depth + REAL(wp) :: zrho1 = 0.01_wp ! density criterion for mixed layer depth + REAL(wp) :: ztem2 = 0.2_wp ! temperature criterion for mixed layer depth + REAL(wp) :: zztmp, zzdep ! temporary scalars inside do loop + REAL(wp) :: zu, zv, zw, zut, zvt ! temporary workspace + REAL(wp), DIMENSION(jpi,jpj) :: zabs2 ! MLD: abs( tn - tn(10m) ) = ztem2 + REAL(wp), DIMENSION(jpi,jpj) :: ztm2 ! Top of thermocline: tn = tn(10m) - ztem2 + REAL(wp), DIMENSION(jpi,jpj) :: zrho10_3 ! MLD: rho = rho10m + zrho3 + REAL(wp), DIMENSION(jpi,jpj) :: zpycn ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC) + REAL(wp), DIMENSION(jpi,jpj) :: ztinv ! max of temperature inversion + REAL(wp), DIMENSION(jpi,jpj) :: zdepinv ! depth of temperature inversion + REAL(wp), DIMENSION(jpi,jpj) :: zrho0_3 ! MLD rho = rho(surf) = 0.03 + REAL(wp), DIMENSION(jpi,jpj) :: zrho0_1 ! MLD rho = rho(surf) = 0.01 + REAL(wp), DIMENSION(jpi,jpj) :: zmaxdzT ! max of dT/dz + REAL(wp), DIMENSION(jpi,jpj) :: zdelr ! delta rho equivalent to deltaT = 0.2 + !!---------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('dia_hth') + + IF( kt == nit000 ) THEN + l_hth = .FALSE. + IF( iom_use( 'mlddzt' ) .OR. iom_use( 'mldr0_3' ) .OR. iom_use( 'mldr0_1' ) .OR. & + & iom_use( 'mld_dt02' ) .OR. iom_use( 'topthdep' ) .OR. iom_use( 'mldr10_3' ) .OR. & + & iom_use( '20d' ) .OR. iom_use( '26d' ) .OR. iom_use( '28d' ) .OR. & + & iom_use( 'hc300' ) .OR. iom_use( 'hc700' ) .OR. iom_use( 'hc2000' ) .OR. & + & iom_use( 'pycndep' ) .OR. iom_use( 'tinv' ) .OR. iom_use( 'depti' ) ) l_hth = .TRUE. + ! ! allocate dia_hth array + IF( l_hth ) THEN + IF( dia_hth_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_hth : unable to allocate standard arrays' ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dia_hth : diagnostics of the thermocline depth' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + IF(lwp) WRITE(numout,*) + ENDIF + ENDIF + + IF( l_hth ) THEN + ! + IF( iom_use( 'mlddzt' ) .OR. iom_use( 'mldr0_3' ) .OR. iom_use( 'mldr0_1' ) ) THEN + ! initialization + ztinv (:,:) = 0._wp + zdepinv(:,:) = 0._wp + zmaxdzT(:,:) = 0._wp + DO_2D( 1, 1, 1, 1 ) + zztmp = gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) + hth (ji,jj) = zztmp + zabs2 (ji,jj) = zztmp + ztm2 (ji,jj) = zztmp + zrho10_3(ji,jj) = zztmp + zpycn (ji,jj) = zztmp + END_2D + IF( nla10 > 1 ) THEN + DO_2D( 1, 1, 1, 1 ) + zztmp = gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) + zrho0_3(ji,jj) = zztmp + zrho0_1(ji,jj) = zztmp + END_2D + ENDIF + + ! Preliminary computation + ! computation of zdelr = (dr/dT)(T,S,10m)*(-0.2 degC) + DO_2D( 1, 1, 1, 1 ) + IF( tmask(ji,jj,nla10) == 1. ) THEN + zu = 1779.50 + 11.250 * ts(ji,jj,nla10,jp_tem,Kmm) - 3.80 * ts(ji,jj,nla10,jp_sal,Kmm) & + & - 0.0745 * ts(ji,jj,nla10,jp_tem,Kmm) * ts(ji,jj,nla10,jp_tem,Kmm) & + & - 0.0100 * ts(ji,jj,nla10,jp_tem,Kmm) * ts(ji,jj,nla10,jp_sal,Kmm) + zv = 5891.00 + 38.000 * ts(ji,jj,nla10,jp_tem,Kmm) + 3.00 * ts(ji,jj,nla10,jp_sal,Kmm) & + & - 0.3750 * ts(ji,jj,nla10,jp_tem,Kmm) * ts(ji,jj,nla10,jp_tem,Kmm) + zut = 11.25 - 0.149 * ts(ji,jj,nla10,jp_tem,Kmm) - 0.01 * ts(ji,jj,nla10,jp_sal,Kmm) + zvt = 38.00 - 0.750 * ts(ji,jj,nla10,jp_tem,Kmm) + zw = (zu + 0.698*zv) * (zu + 0.698*zv) + zdelr(ji,jj) = ztem2 * (1000.*(zut*zv - zvt*zu)/zw) + ELSE + zdelr(ji,jj) = 0._wp + ENDIF + END_2D + + ! ------------------------------------------------------------- ! + ! thermocline depth: strongest vertical gradient of temperature ! + ! turbocline depth (mixing layer depth): avt = zavt5 ! + ! MLD: rho = rho(1) + zrho3 ! + ! MLD: rho = rho(1) + zrho1 ! + ! ------------------------------------------------------------- ! + DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) ! loop from bottom to 2 + ! + zzdep = gdepw(ji,jj,jk,Kmm) + zztmp = ( ts(ji,jj,jk-1,jp_tem,Kmm) - ts(ji,jj,jk,jp_tem,Kmm) ) & + & / zzdep * tmask(ji,jj,jk) ! vertical gradient of temperature (dT/dz) + zzdep = zzdep * tmask(ji,jj,1) + + IF( zztmp > zmaxdzT(ji,jj) ) THEN + zmaxdzT(ji,jj) = zztmp + hth (ji,jj) = zzdep ! max and depth of dT/dz + ENDIF + + IF( nla10 > 1 ) THEN + zztmp = rhop(ji,jj,jk) - rhop(ji,jj,1) ! delta rho(1) + IF( zztmp > zrho3 ) zrho0_3(ji,jj) = zzdep ! > 0.03 + IF( zztmp > zrho1 ) zrho0_1(ji,jj) = zzdep ! > 0.01 + ENDIF + END_3D + + CALL iom_put( 'mlddzt', hth ) ! depth of the thermocline + IF( nla10 > 1 ) THEN + CALL iom_put( 'mldr0_3', zrho0_3 ) ! MLD delta rho(surf) = 0.03 + CALL iom_put( 'mldr0_1', zrho0_1 ) ! MLD delta rho(surf) = 0.01 + ENDIF + ! + ENDIF + ! + IF( iom_use( 'mld_dt02' ) .OR. iom_use( 'topthdep' ) .OR. iom_use( 'mldr10_3' ) .OR. & + & iom_use( 'pycndep' ) .OR. iom_use( 'tinv' ) .OR. iom_use( 'depti' ) ) THEN + ! ------------------------------------------------------------- ! + ! MLD: abs( tn - tn(10m) ) = ztem2 ! + ! Top of thermocline: tn = tn(10m) - ztem2 ! + ! MLD: rho = rho10m + zrho3 ! + ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC) ! + ! temperature inversion: max( 0, max of tn - tn(10m) ) ! + ! depth of temperature inversion ! + ! ------------------------------------------------------------- ! + DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! loop from bottom to nlb10 + ! + zzdep = gdepw(ji,jj,jk,Kmm) * tmask(ji,jj,1) + ! + zztmp = ts(ji,jj,nla10,jp_tem,Kmm) - ts(ji,jj,jk,jp_tem,Kmm) ! - delta T(10m) + IF( ABS(zztmp) > ztem2 ) zabs2 (ji,jj) = zzdep ! abs > 0.2 + IF( zztmp > ztem2 ) ztm2 (ji,jj) = zzdep ! > 0.2 + zztmp = -zztmp ! delta T(10m) + IF( zztmp > ztinv(ji,jj) ) THEN ! temperature inversion + ztinv(ji,jj) = zztmp + zdepinv (ji,jj) = zzdep ! max value and depth + ENDIF + + zztmp = rhop(ji,jj,jk) - rhop(ji,jj,nla10) ! delta rho(10m) + IF( zztmp > zrho3 ) zrho10_3(ji,jj) = zzdep ! > 0.03 + IF( zztmp > zdelr(ji,jj) ) zpycn (ji,jj) = zzdep ! > equi. delta T(10m) - 0.2 + ! + END_3D + + CALL iom_put( 'mld_dt02', zabs2 ) ! MLD abs(delta t) - 0.2 + CALL iom_put( 'topthdep', ztm2 ) ! T(10) - 0.2 + CALL iom_put( 'mldr10_3', zrho10_3 ) ! MLD delta rho(10m) = 0.03 + CALL iom_put( 'pycndep' , zpycn ) ! MLD delta rho equi. delta T(10m) = 0.2 + CALL iom_put( 'tinv' , ztinv ) ! max. temp. inv. (t10 ref) + CALL iom_put( 'depti' , zdepinv ) ! depth of max. temp. inv. (t10 ref) + ! + ENDIF + + ! ------------------------------- ! + ! Depth of 20C/26C/28C isotherm ! + ! ------------------------------- ! + IF( iom_use ('20d') ) THEN ! depth of the 20 isotherm + ztem2 = 20. + CALL dia_hth_dep( Kmm, ztem2, hd20 ) + CALL iom_put( '20d', hd20 ) + ENDIF + ! + IF( iom_use ('26d') ) THEN ! depth of the 26 isotherm + ztem2 = 26. + CALL dia_hth_dep( Kmm, ztem2, hd26 ) + CALL iom_put( '26d', hd26 ) + ENDIF + ! + IF( iom_use ('28d') ) THEN ! depth of the 28 isotherm + ztem2 = 28. + CALL dia_hth_dep( Kmm, ztem2, hd28 ) + CALL iom_put( '28d', hd28 ) + ENDIF + + ! ----------------------------- ! + ! Heat content of first 300 m ! + ! ----------------------------- ! + IF( iom_use ('hc300') ) THEN + zzdep = 300. + CALL dia_hth_htc( Kmm, zzdep, ts(:,:,:,jp_tem,Kmm), htc3 ) + CALL iom_put( 'hc300', rho0_rcp * htc3 ) ! vertically integrated heat content (J/m2) + ENDIF + ! + ! ----------------------------- ! + ! Heat content of first 700 m ! + ! ----------------------------- ! + IF( iom_use ('hc700') ) THEN + zzdep = 700. + CALL dia_hth_htc( Kmm, zzdep, ts(:,:,:,jp_tem,Kmm), htc7 ) + CALL iom_put( 'hc700', rho0_rcp * htc7 ) ! vertically integrated heat content (J/m2) + + ENDIF + ! + ! ----------------------------- ! + ! Heat content of first 2000 m ! + ! ----------------------------- ! + IF( iom_use ('hc2000') ) THEN + zzdep = 2000. + CALL dia_hth_htc( Kmm, zzdep, ts(:,:,:,jp_tem,Kmm), htc20 ) + CALL iom_put( 'hc2000', rho0_rcp * htc20 ) ! vertically integrated heat content (J/m2) + ENDIF + ! + ENDIF + + ! + IF( ln_timing ) CALL timing_stop('dia_hth') + ! + END SUBROUTINE dia_hth + + SUBROUTINE dia_hth_dep( Kmm, ptem, pdept ) + ! + INTEGER , INTENT(in) :: Kmm ! ocean time level index + REAL(wp), INTENT(in) :: ptem + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pdept + ! + INTEGER :: ji, jj, jk, iid + REAL(wp) :: zztmp, zzdep + INTEGER, DIMENSION(jpi,jpj) :: iktem + + ! --------------------------------------- ! + ! search deepest level above ptem ! + ! --------------------------------------- ! + iktem(:,:) = 1 + DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! beware temperature is not always decreasing with depth => loop from top to bottom + zztmp = ts(ji,jj,jk,jp_tem,Kmm) + IF( zztmp >= ptem ) iktem(ji,jj) = jk + END_3D + + ! ------------------------------- ! + ! Depth of ptem isotherm ! + ! ------------------------------- ! + DO_2D( 1, 1, 1, 1 ) + ! + zzdep = gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) ! depth of the ocean bottom + ! + iid = iktem(ji,jj) + IF( iid /= 1 ) THEN + zztmp = gdept(ji,jj,iid ,Kmm) & ! linear interpolation + & + ( gdept(ji,jj,iid+1,Kmm) - gdept(ji,jj,iid,Kmm) ) & + & * ( 20.*tmask(ji,jj,iid+1) - ts(ji,jj,iid,jp_tem,Kmm) ) & + & / ( ts(ji,jj,iid+1,jp_tem,Kmm) - ts(ji,jj,iid,jp_tem,Kmm) + (1.-tmask(ji,jj,1)) ) + pdept(ji,jj) = MIN( zztmp , zzdep) * tmask(ji,jj,1) ! bound by the ocean depth + ELSE + pdept(ji,jj) = 0._wp + ENDIF + END_2D + ! + END SUBROUTINE dia_hth_dep + + + SUBROUTINE dia_hth_htc( Kmm, pdep, pt, phtc ) + ! + INTEGER , INTENT(in) :: Kmm ! ocean time level index + REAL(wp), INTENT(in) :: pdep ! depth over the heat content + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pt + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: phtc + ! + INTEGER :: ji, jj, jk, ik + REAL(wp), DIMENSION(jpi,jpj) :: zthick + INTEGER , DIMENSION(jpi,jpj) :: ilevel + + + ! surface boundary condition + + IF( .NOT. ln_linssh ) THEN ; zthick(:,:) = 0._wp ; phtc(:,:) = 0._wp + ELSE ; zthick(:,:) = ssh(:,:,Kmm) ; phtc(:,:) = pt(:,:,1) * ssh(:,:,Kmm) * tmask(:,:,1) + ENDIF + ! + ilevel(:,:) = 1 + DO_3D( 1, 1, 1, 1, 1, jpkm1 ) + IF( ( gdepw(ji,jj,jk+1,Kmm) < pdep ) .AND. ( tmask(ji,jj,jk) == 1 ) ) THEN + ilevel(ji,jj) = jk+1 + zthick(ji,jj) = zthick(ji,jj) + e3t(ji,jj,jk,Kmm) + phtc (ji,jj) = phtc (ji,jj) + e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk) + ENDIF + END_3D + ! + DO_2D( 1, 1, 1, 1 ) + ik = ilevel(ji,jj) + IF( tmask(ji,jj,ik) == 1 ) THEN + zthick(ji,jj) = MIN ( gdepw(ji,jj,ik+1,Kmm), pdep ) - zthick(ji,jj) ! remaining thickness to reach dephw pdep + phtc(ji,jj) = phtc(ji,jj) + pt(ji,jj,ik) * zthick(ji,jj) + ENDIF + END_2D + ! + END SUBROUTINE dia_hth_htc + + !!====================================================================== +END MODULE diahth \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diamlr.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diamlr.F90 new file mode 100644 index 0000000..aa1a3f5 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diamlr.F90 @@ -0,0 +1,428 @@ +MODULE diamlr + !!====================================================================== + !! *** MODULE diamlr *** + !! Management of the IOM context for multiple-linear-regression analysis + !!====================================================================== + !! History : 4.0 ! 2019 (S. Mueller) Original code + !!---------------------------------------------------------------------- + USE par_kind + USE par_oce , ONLY : wp, jpi, jpj + USE phycst , ONLY : rpi + USE dom_oce , ONLY : adatrj + USE tide_mod + ! + USE in_out_manager , ONLY : lwp, numout, ln_timing + USE iom , ONLY : iom_put, iom_use, iom_update_file_name + USE timing , ONLY : timing_start, timing_stop +#if defined key_xios + USE xios +#endif + + IMPLICIT NONE + PRIVATE + + LOGICAL, PUBLIC :: lk_diamlr = .FALSE. !: ===>>> NOT a DOCTOR norm name : use l_diamlr + ! lk_ is used only for logical controlled by a CPP key + + PUBLIC :: dia_mlr_init, dia_mlr_iom_init, dia_mlr + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2019) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_mlr_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_mlr_init *** + !! + !! ** Purpose : initialisation of IOM context management for + !! multiple-linear-regression analysis + !! + !!---------------------------------------------------------------------- + ! + lk_diamlr = .TRUE. + ! + IF(lwp) THEN + WRITE(numout, *) + WRITE(numout, *) 'dia_mlr_init : initialisation of IOM context management for' + WRITE(numout, *) '~~~~~~~~~~~~ multiple-linear-regression analysis' + END IF + ! + END SUBROUTINE dia_mlr_init + + + SUBROUTINE dia_mlr_iom_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_mlr_iom_init *** + !! + !! ** Purpose : IOM context setup for multiple-linear-regression + !! analysis + !! + !!---------------------------------------------------------------------- +#if defined key_xios + + TYPE(xios_fieldgroup) :: slxhdl_fldgrp + TYPE(xios_filegroup) :: slxhdl_filgrp + TYPE(xios_field), ALLOCATABLE, DIMENSION(:) :: slxhdl_regs, slxhdl_flds + TYPE(xios_field) :: slxhdl_fld + TYPE(xios_file) :: slxhdl_fil + LOGICAL :: llxatt_enabled, llxatt_comment + CHARACTER(LEN=256) :: clxatt_expr, clxatt_comment + CHARACTER(LEN=32) :: clxatt_name1, clxatt_name2 + CHARACTER(LEN=32) :: clxatt_gridref, clxatt_fieldref + INTEGER, PARAMETER :: jpscanmax = 999 + INTEGER :: ireg, ifld + CHARACTER(LEN=3) :: cl3i + CHARACTER(LEN=6) :: cl6a + CHARACTER(LEN=7) :: cl7a + CHARACTER(LEN=1) :: clgt + CHARACTER(LEN=2) :: clgd + CHARACTER(LEN=25) :: clfloat + CHARACTER(LEN=32) :: clrepl + INTEGER :: jl, jm, jn + INTEGER :: itide ! Number of available tidal components + REAL(wp) :: ztide_phase ! Tidal-constituent phase at adatrj=0 + CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: ctide_selected = 'n/a ' + TYPE(tide_harmonic), DIMENSION(:), POINTER :: stideconst + + IF(lwp) THEN + WRITE(numout, *) + WRITE(numout, *) 'dia_mlr_iom_init : IOM context setup for multiple-linear-regression' + WRITE(numout, *) '~~~~~~~~~~~~~~~~' + END IF + + ! Get handles to multiple-linear-regression analysis configuration (field + ! group 'diamrl_fields' and file group 'diamlr_files'); if no suitable + ! configuration is found, disable diamlr + IF ( lk_diamlr .AND. xios_is_valid_fieldgroup( "diamlr_fields" ) .AND. xios_is_valid_field( "diamlr_time" ) .AND. & + & xios_is_valid_filegroup( "diamlr_files" ) ) THEN + CALL xios_get_handle("diamlr_fields", slxhdl_fldgrp) + CALL xios_get_handle("diamlr_files", slxhdl_filgrp) + ELSE + IF (lwp) THEN + WRITE(numout, *) "diamlr: configuration not found or incomplete (field group 'diamlr_fields'" + WRITE(numout, *) " and/or file group 'diamlr_files' and/or field 'diamlr_time' missing);" + WRITE(numout, *) " disabling output for multiple-linear-regression analysis." + END IF + lk_diamlr = .FALSE. + END IF + + ! Set up IOM context for multiple-linear-regression analysis + IF ( lk_diamlr ) THEN + + ! Set up output files for grid types scalar, grid_T, grid_U, grid_V, + ! and grid_W + DO jm = 1, 5 + SELECT CASE( jm ) + CASE( 1 ) + cl6a = 'scalar' + CASE( 2 ) + cl6a = 'grid_T' + CASE( 3 ) + cl6a = 'grid_U' + CASE( 4 ) + cl6a = 'grid_V' + CASE( 5 ) + cl6a = 'grid_W' + END SELECT + CALL xios_add_child ( slxhdl_filgrp, slxhdl_fil, "diamlr_file_"//cl6a ) + CALL xios_set_attr ( slxhdl_fil, name_suffix="_diamlr_"//cl6a, & + & description="Intermediate output for multiple-linear-regression analysis - "//cl6a ) + CALL iom_update_file_name( "diamlr_file_"//cl6a ) + END DO + + ! Compile lists of active regressors and of fields selected for + ! analysis (fields "diamlr_r" and "diamlr_f", where is + ! a 3-digit integer); also carry out placeholder substitution of tidal + ! parameters in regressor expressions + ! + ALLOCATE( slxhdl_regs( jpscanmax ), slxhdl_flds( jpscanmax ) ) + ireg = 0 + ifld = 0 + ! + IF ( ln_tide ) THEN + ! Retrieve information (frequency, phase, nodal correction) about all + ! available tidal constituents for placeholder substitution below + ! Warning: we must use the same character length in an array constructor (at least for gcc compiler) + ctide_selected(1:34) = (/ 'Mf ', 'Mm ', 'Ssa ', 'Mtm ', 'Msf ', & + & 'Msqm', 'Sa ', 'K1 ', 'O1 ', 'P1 ', & + & 'Q1 ', 'J1 ', 'S1 ', 'M2 ', 'S2 ', 'N2 ', & + & 'K2 ', 'nu2 ', 'mu2 ', '2N2 ', 'L2 ', & + & 'T2 ', 'eps2', 'lam2', 'R2 ', 'M3 ', & + & 'MKS2', 'MN4 ', 'MS4 ', 'M4 ', 'N4 ', & + & 'S4 ', 'M6 ', 'M8 ' /) + CALL tide_init_harmonics(ctide_selected, stideconst) + itide = size(stideconst) + ELSE + itide = 0 + ENDIF + + DO jm = 1, jpscanmax + WRITE (cl3i, '(i3.3)') jm + + ! Look for regressor + IF ( xios_is_valid_field( "diamlr_r"//cl3i ) ) THEN + + CALL xios_get_handle( "diamlr_r"//cl3i, slxhdl_regs(ireg+1) ) + ! Retrieve pre-configured value of "enabled" attribute and + ! regressor expression + CALL xios_get_attr ( slxhdl_regs(ireg+1), enabled=llxatt_enabled, expr=clxatt_expr ) + ! If enabled, keep handle in list of active regressors; also + ! substitute placeholders for tidal frequencies, phases, and + ! nodal corrections in regressor expressions + IF ( llxatt_enabled ) THEN + + ! Substitution of placeholders for tidal-constituent + ! parameters (amplitudes, angular veloccities, nodal phase + ! correction) with values that have been obtained from the + ! tidal-forcing implementation (if enabled) + DO jn = 1, itide + ! Compute phase of tidal constituent (incl. current nodal + ! correction) at the start of the model run (i.e. for + ! adatrj=0) + ztide_phase = MOD( stideconst(jn)%u + stideconst(jn)%v0 - adatrj * 86400.0_wp * stideconst(jn)%omega, & + & 2.0_wp * rpi ) + clrepl = "__TDE_"//TRIM( stideconst(jn)%cname_tide )//"_omega__" + DO WHILE ( INDEX( clxatt_expr, TRIM( clrepl ) ) > 0 ) + WRITE (clfloat, '(e25.18)') stideconst(jn)%omega + jl = INDEX( clxatt_expr, TRIM( clrepl ) ) + clxatt_expr = clxatt_expr(1:jl - 1)//clfloat// & + & clxatt_expr(jl + LEN( TRIM( clrepl ) ):LEN( TRIM( clxatt_expr ) )) + END DO + clrepl = "__TDE_"//TRIM( stideconst(jn)%cname_tide )//"_phase__" + DO WHILE ( INDEX( clxatt_expr, TRIM( clrepl ) ) > 0 ) + WRITE (clfloat, '(e25.18)') ztide_phase + jl = INDEX( clxatt_expr, TRIM( clrepl ) ) + clxatt_expr = clxatt_expr(1:jl - 1)//clfloat// & + & clxatt_expr(jl + LEN( TRIM( clrepl ) ):LEN( TRIM( clxatt_expr ) )) + END DO + clrepl = "__TDE_"//TRIM( stideconst(jn)%cname_tide )//"_amplitude__" + DO WHILE (INDEX( clxatt_expr, TRIM( clrepl ) ) > 0 ) + WRITE (clfloat, '(e25.18)') stideconst(jn)%f + jl = INDEX( clxatt_expr, TRIM( clrepl ) ) + clxatt_expr = clxatt_expr(1:jl - 1)//clfloat// & + & clxatt_expr(jl + LEN( TRIM( clrepl ) ):LEN( TRIM( clxatt_expr ) )) + END DO + END DO + + ! Set standard value for comment attribute, including possible + ! existing comment added in parantheses + CALL xios_is_defined_attr( slxhdl_regs(ireg+1), comment=llxatt_comment ) + IF ( llxatt_comment ) THEN + CALL xios_get_attr( slxhdl_regs(ireg+1), comment=clxatt_comment ) + clxatt_comment = "Regressor "//cl3i//" ("//TRIM( clxatt_comment )//") " + ELSE + clxatt_comment = "Regressor "//cl3i + END IF + + ! Set name attribute (and overwrite possible pre-configured + ! name) with field id to enable id string retrieval from + ! stored handle below, re-set expression with possible + ! substitutions, and set or re-set comment attribute + CALL xios_set_attr ( slxhdl_regs(ireg+1), name="diamlr_r"//cl3i, expr=TRIM( clxatt_expr ), & + & comment=TRIM( clxatt_comment ) ) + + ireg = ireg + 1 ! Accept regressor in list of active regressors + + END IF + END IF + + ! Look for field + IF ( xios_is_valid_field( "diamlr_f"//cl3i ) ) THEN + + CALL xios_get_handle( "diamlr_f"//cl3i, slxhdl_flds(ifld+1) ) + ! Retrieve pre-configured value of "enabled" attribute + CALL xios_get_attr ( slxhdl_flds(ifld+1), enabled=llxatt_enabled ) + ! If enabled, keep handle in list of fields selected for analysis + IF ( llxatt_enabled ) THEN + + ! Set name attribute (and overwrite possible pre-configured name) + ! with field id to enable id string retrieval from stored handle + ! below + CALL xios_set_attr ( slxhdl_flds(ifld+1), name="diamlr_f"//cl3i ) + + ifld = ifld + 1 ! Accept field in list of fields selected for analysis + + END IF + END IF + + END DO + + ! Output number of active regressors and fields selected for analysis + IF ( lwp ) WRITE(numout,'(a,i3,a)' ) 'diamlr: ', ireg, ' active regressors found' + IF ( lwp ) WRITE(numout,'(a,i3,a)' ) 'diamlr: ', ifld, ' fields selected for analysis' + + ! Set up output of minimum, maximum, and average values of the time + ! variable available for the computation of regressors (diamlr_time) + CALL xios_get_handle( "diamlr_file_scalar", slxhdl_fil ) + CALL xios_add_child ( slxhdl_fil, slxhdl_fld, "diamlr_time_average" ) +!$AGRIF_DO_NOT_TREAT + CALL xios_set_attr ( slxhdl_fld, standard_name="diamlr_time", & + & long_name="Elapsed model time at start of regression interval", & + & unit="s", operation="average", field_ref="diamlr_time", & + & grid_ref="diamlr_grid_2D_to_scalar" ) +!$AGRIF_END_DO_NOT_TREAT + CALL xios_add_child ( slxhdl_fil, slxhdl_fld, "diamlr_time_minimum" ) +!$AGRIF_DO_NOT_TREAT + CALL xios_set_attr ( slxhdl_fld, standard_name="diamlr_time", & + & long_name="Elapsed model time at start of regression interval", & + & unit="s", operation="minimum", field_ref="diamlr_time", & + & grid_ref="diamlr_grid_2D_to_scalar" ) +!$AGRIF_END_DO_NOT_TREAT + CALL xios_add_child ( slxhdl_fil, slxhdl_fld, "diamlr_time_maximum" ) +!$AGRIF_DO_NOT_TREAT + CALL xios_set_attr ( slxhdl_fld, standard_name="diamlr_time", & + & long_name="Elapsed model time at start of regression interval", & + & unit="s", operation="maximum", field_ref="diamlr_time", & + & grid_ref="diamlr_grid_2D_to_scalar" ) +!$AGRIF_END_DO_NOT_TREAT + + ! For each active regressor: + DO jm = 1, ireg + + ! i) set up 2-dimensional and 3-dimensional versions of the + ! regressors; explicitely set "enabled" attribute; note, while + ! the scalar versions of regressors are part of the + ! configuration, the respective 2-dimensional versions take + ! over the defining expression, while the scalar and + ! 3-dimensional versions are simply obtained via grid + ! transformations from the 2-dimensional version. + CALL xios_get_attr ( slxhdl_regs( jm ), name=clxatt_name1, expr=clxatt_expr, & + & enabled=llxatt_enabled, comment=clxatt_comment ) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_T_2D" ) + CALL xios_set_attr ( slxhdl_fld, expr=TRIM( clxatt_expr ), grid_ref="diamlr_grid_T_2D", & + & field_ref="diamlr_time", enabled=llxatt_enabled ) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_U_2D" ) + CALL xios_set_attr ( slxhdl_fld, expr=TRIM( clxatt_expr ), grid_ref="diamlr_grid_U_2D", & + & field_ref="diamlr_time", enabled=llxatt_enabled ) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_V_2D" ) + CALL xios_set_attr ( slxhdl_fld, expr=TRIM( clxatt_expr ), grid_ref="diamlr_grid_V_2D", & + & field_ref="diamlr_time", enabled=llxatt_enabled ) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_W_2D" ) + CALL xios_set_attr ( slxhdl_fld, expr=TRIM( clxatt_expr ), grid_ref="diamlr_grid_W_2D", & + & field_ref="diamlr_time", enabled=llxatt_enabled ) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_T_3D") + CALL xios_set_attr ( slxhdl_fld, expr="this", grid_ref="diamlr_grid_2D_to_grid_T_3D", & + & field_ref=TRIM( clxatt_name1 )//"_grid_T_2D", enabled=llxatt_enabled) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_U_3D") + CALL xios_set_attr ( slxhdl_fld, expr="this", grid_ref="diamlr_grid_2D_to_grid_U_3D", & + & field_ref=TRIM( clxatt_name1 )//"_grid_U_2D", enabled=llxatt_enabled) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_V_3D") + CALL xios_set_attr ( slxhdl_fld, expr="this", grid_ref="diamlr_grid_2D_to_grid_V_3D", & + & field_ref=TRIM( clxatt_name1 )//"_grid_V_2D", enabled=llxatt_enabled) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"_grid_W_3D") + CALL xios_set_attr ( slxhdl_fld, expr="this", grid_ref="diamlr_grid_2D_to_grid_W_3D", & + & field_ref=TRIM( clxatt_name1 )//"_grid_W_2D", enabled=llxatt_enabled) + CALL xios_set_attr ( slxhdl_regs(jm), expr="this", grid_ref="diamlr_grid_2D_to_scalar", & + & field_ref=TRIM( clxatt_name1 )//"_grid_T_2D", enabled=llxatt_enabled) + + ! ii) set up output of active regressors, including metadata + CALL xios_get_handle( "diamlr_file_scalar", slxhdl_fil ) + ! Add regressor to output file + CALL xios_add_child ( slxhdl_fil, slxhdl_fld, TRIM( clxatt_name1 ) ) + CALL xios_set_attr ( slxhdl_fld, standard_name=TRIM( clxatt_comment ), long_name=TRIM( clxatt_expr ), & + & operation="average" ) + + ! iii) set up the output of scalar products with itself and with + ! other active regressors + CALL xios_get_attr ( slxhdl_regs(jm), name=clxatt_name1 ) + DO jn = 1, jm + ! Field for product between regressors + CALL xios_get_attr ( slxhdl_regs(jn), name=clxatt_name2 ) + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name1 )//"."//TRIM( clxatt_name2 ) ) + ! Set appropriate name attribute to avoid the possibility of + ! using an inappropriate inherited name attribute as the variable + ! name in the output file + CALL xios_set_attr ( slxhdl_fld, & + & name=TRIM( clxatt_name1 )//"."//TRIM( clxatt_name2 ), & + & grid_ref="diamlr_grid_scalar", & + & expr="this * "//TRIM( clxatt_name2 ), & + & field_ref=TRIM( clxatt_name1 ), & + & enabled=llxatt_enabled, & + & long_name="Scalar product of regressor "//TRIM( clxatt_name1 )// & + & " and regressor "//TRIM( clxatt_name2 ), & + & standard_name=TRIM( clxatt_name1 )//"."//TRIM( clxatt_name2 ), & + & operation="accumulate") + ! Add regressor-product field to output file + CALL xios_add_child ( slxhdl_fil, slxhdl_fld, TRIM( clxatt_name1 )//"."//TRIM( clxatt_name2 ) ) + END DO + + ! iv) set up definitions for the output of scalar products with + ! fields selected for analysis + DO jn = 1, ifld + CALL xios_get_attr ( slxhdl_flds(jn), name=clxatt_name2, field_ref=clxatt_fieldref ) + CALL xios_get_handle( TRIM( clxatt_fieldref ), slxhdl_fld ) + CALL xios_get_attr ( slxhdl_fld, grid_ref=clxatt_gridref ) + clgt="T" + IF ( INDEX( clxatt_gridref, "_U_" ) > 0 ) clgt="U" + IF ( INDEX( clxatt_gridref, "_V_" ) > 0 ) clgt="V" + IF ( INDEX( clxatt_gridref, "_W_" ) > 0 ) clgt="W" + clgd="2D" + cl7a="" + IF ( INDEX( clxatt_gridref, "_3D" ) > 0 ) THEN + clgd="3D" + ELSE + cl7a="diamlr_" + END IF + CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( clxatt_name2 )//"."//TRIM( clxatt_name1 ) ) + ! Set appropriate name attribute to avoid the possibility of + ! using an inappropriate inherited name attribute as the variable + ! name in the output file; use metadata (standard_name and + ! long_name) to refer to the id of the analysed field + CALL xios_set_attr ( slxhdl_fld, & + & name=TRIM( clxatt_name2 )//"."//TRIM( clxatt_name1 ), & + & expr="this * "//TRIM( clxatt_fieldref ), & + & grid_ref=cl7a//"grid_"//clgt//"_"//clgd, & + & field_ref=TRIM( clxatt_name1 )//"_grid_"//clgt//"_"//clgd, & + & enabled=llxatt_enabled, & + & long_name="Scalar product of "//TRIM( clxatt_fieldref )// & + & " and regressor "//TRIM( clxatt_name1 ), & + & standard_name=TRIM( clxatt_fieldref )//"."//TRIM( clxatt_name1 ), & + & operation="accumulate" ) + CALL xios_get_handle( "diamlr_file_grid_"//clgt, slxhdl_fil ) + CALL xios_add_child ( slxhdl_fil, slxhdl_fld, TRIM( clxatt_name2 )//"."//TRIM( clxatt_name1 ) ) + END DO + + END DO + + ! Release list of active regressors and fields selected for analysis + DEALLOCATE( slxhdl_regs, slxhdl_flds ) + + END IF +#else + IF( .FALSE. ) write(numout,*) 'dia_mlr_iom_init: should not see this' ! useless statement to avoid compiler warnings +#endif + + END SUBROUTINE dia_mlr_iom_init + + + SUBROUTINE dia_mlr + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_mlr *** + !! + !! ** Purpose : update time used in multiple-linear-regression analysis + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: zadatrj2d + !!---------------------------------------------------------------------- + + IF( ln_timing ) CALL timing_start('dia_mlr') + + ! Update time to the continuous time since the start of the model run + ! (value of adatrj converted to time in units of seconds) + ! + ! A 2-dimensional field of constant value is sent, and subsequently used directly + ! or transformed to a scalar or a constant 3-dimensional field as required. + zadatrj2d(:,:) = adatrj*86400.0_wp + IF ( iom_use('diamlr_time') ) CALL iom_put('diamlr_time', zadatrj2d) + ! + IF( ln_timing ) CALL timing_stop('dia_mlr') + ! + END SUBROUTINE dia_mlr + + !!====================================================================== +END MODULE diamlr \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/dianam.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/dianam.F90 new file mode 100644 index 0000000..360b720 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/dianam.F90 @@ -0,0 +1,136 @@ +MODULE dianam + !!====================================================================== + !! *** MODULE dianam *** + !! Ocean diagnostics: Builds output file name + !!===================================================================== + !! History : OPA ! 1999-02 (E. Guilyardi) Creation for 30 days/month + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.2 ! 2009-11 (S. Masson) complete rewriting, works for all calendars... + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dia_nam : Builds output file name + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE in_out_manager ! I/O manager + USE ioipsl, ONLY : ju2ymds ! for calendar + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_nam + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dianam.F90 12489 2020-02-28 15:55:11Z davestorkey $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE dia_nam( cdfnam, kfreq, cdsuff, ldfsec ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dia_nam *** + !! + !! ** Purpose : Builds output file name + !! + !! ** Method : File name is a function of date and output frequency + !! cdfnam=____ + !! = averaging frequency (DA, MO, etc...) + !! , date of beginning and end of run + !! + !!---------------------------------------------------------------------- + CHARACTER (len=*), INTENT( out) :: cdfnam ! file name + CHARACTER (len=*), INTENT(in ) :: cdsuff ! to be added at the end of the file name + INTEGER , INTENT(in ) :: kfreq ! output frequency: > 0 in time-step (or seconds see ldfsec) + ! < 0 in months + ! = 0 no frequency + LOGICAL , INTENT(in ), OPTIONAL :: ldfsec ! kfreq in second(in time-step) if .true.(.false. default) + ! + CHARACTER (len=20) :: clfmt, clfmt0 ! writing format + CHARACTER (len=20) :: clave ! name for output frequency + CHARACTER (len=20) :: cldate1 ! date of the beginning of run + CHARACTER (len=20) :: cldate2 ! date of the end of run + LOGICAL :: llfsec ! local value of ldfsec + INTEGER :: iyear1, imonth1, iday1 ! year, month, day of the first day of the run + INTEGER :: iyear2, imonth2, iday2 ! year, month, day of the last day of the run + INTEGER :: indg ! number of digits needed to write a number + INTEGER :: inbsec, inbmn, inbhr ! output frequency in seconds, minutes and hours + INTEGER :: inbday, inbmo, inbyr ! output frequency in days, months and years + INTEGER :: iyyss, iddss, ihhss, immss ! number of seconds in 1 year, 1 day, 1 hour and 1 minute + INTEGER :: iyymo ! number of months in 1 year + REAL(dp) :: zsec1, zsec2 ! not used + REAL(dp) :: zdrun, zjul ! temporary scalars + !!---------------------------------------------------------------------- + + ! name for output frequency + + IF( PRESENT(ldfsec) ) THEN ; llfsec = ldfsec + ELSE ; llfsec = .FALSE. + ENDIF + + IF( llfsec .OR. kfreq < 0 ) THEN ; inbsec = kfreq ! output frequency already in seconds + ELSE ; inbsec = kfreq * NINT( rn_Dt ) ! from time-step to seconds + ENDIF + iddss = NINT( rday ) ! number of seconds in 1 day + ihhss = NINT( rmmss * rhhmm ) ! number of seconds in 1 hour + immss = NINT( rmmss ) ! number of seconds in 1 minute + iyymo = NINT( raamo ) ! number of months in 1 year + iyyss = iddss * nyear_len(1) ! seconds in 1 year (not good: multi years with leap) + clfmt0 = "('(a,i',i1,',a)')" ! format '(a,ix,a)' with x to be defined + ! + IF( inbsec == 0 ) THEN ; clave = '' ! no frequency + ELSEIF( inbsec < 0 ) THEN + inbmo = -inbsec ! frequency in month + IF( MOD( inbmo, iyymo ) == 0 ) THEN ! frequency in years + inbyr = inbmo / iyymo + indg = INT(LOG10(REAL(inbyr,wp))) + 1 ! number of digits needed to write years frequency + WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbyr , 'y' + ELSE ! frequency in month + indg = INT(LOG10(REAL(inbmo,wp))) + 1 ! number of digits needed to write months frequency + WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbmo, 'm' + ENDIF + ELSEIF( MOD( inbsec, iyyss ) == 0 ) THEN ! frequency in years + inbyr = inbsec / iyyss + indg = INT(LOG10(REAL(inbyr ,wp))) + 1 ! number of digits needed to write years frequency + WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbyr , 'y' + ELSEIF( MOD( inbsec, iddss ) == 0 ) THEN ! frequency in days + inbday = inbsec / iddss + indg = INT(LOG10(REAL(inbday,wp))) + 1 ! number of digits needed to write days frequency + WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbday, 'd' + IF( inbday == nmonth_len(nmonth) ) clave = '_1m' + ELSEIF( MOD( inbsec, ihhss ) == 0 ) THEN ! frequency in hours + inbhr = inbsec / ihhss + indg = INT(LOG10(REAL(inbhr ,wp))) + 1 ! number of digits needed to write hours frequency + WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbhr , 'h' + ELSEIF( MOD( inbsec, immss ) == 0 ) THEN ! frequency in minutes + inbmn = inbsec / immss + indg = INT(LOG10(REAL(inbmn ,wp))) + 1 ! number of digits needed to write minutes frequency + WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbmn , 'mn' + ELSE ! frequency in seconds + indg = INT(LOG10(REAL(inbsec,wp))) + 1 ! number of digits needed to write seconds frequency + WRITE(clfmt, clfmt0) indg ; WRITE(clave, clfmt) '_', inbsec, 's' + ENDIF + + ! date of the beginning and the end of the run + + zdrun = rn_Dt / rday * REAL( nitend - nit000, wp ) ! length of the run in days + zjul = fjulday - rn_Dt / rday + CALL ju2ymds( zjul , iyear1, imonth1, iday1, zsec1 ) ! year/month/day of the beginning of run + CALL ju2ymds( zjul + zdrun, iyear2, imonth2, iday2, zsec2 ) ! year/month/day of the end of run + + IF( iyear2 < 10000 ) THEN ; clfmt = "(i4.4,2i2.2)" ! format used to write the date + ELSE ; WRITE(clfmt, "('(i',i1,',2i2.2)')") INT(LOG10(REAL(iyear2,wp))) + 1 + ENDIF + + WRITE(cldate1, clfmt) iyear1, imonth1, iday1 ! date of the beginning of run + WRITE(cldate2, clfmt) iyear2, imonth2, iday2 ! date of the end of run + + cdfnam = TRIM(cexper)//TRIM(clave)//"_"//TRIM(cldate1)//"_"//TRIM(cldate2)//"_"//TRIM(cdsuff) + IF( .NOT. Agrif_Root() ) cdfnam = TRIM(Agrif_CFixed())//'_'//TRIM(cdfnam) + + END SUBROUTINE dia_nam + + !!====================================================================== +END MODULE dianam \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diaptr.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diaptr.F90 new file mode 100644 index 0000000..0a07689 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diaptr.F90 @@ -0,0 +1,804 @@ +MODULE diaptr + !!====================================================================== + !! *** MODULE diaptr *** + !! Ocean physics: Computes meridonal transports and zonal means + !!===================================================================== + !! History : 1.0 ! 2003-09 (C. Talandier, G. Madec) Original code + !! 2.0 ! 2006-01 (A. Biastoch) Allow sub-basins computation + !! 3.2 ! 2010-03 (O. Marti, S. Flavoni) Add fields + !! 3.3 ! 2010-10 (G. Madec) dynamical allocation + !! 3.6 ! 2014-12 (C. Ethe) use of IOM + !! 3.6 ! 2016-06 (T. Graham) Addition of diagnostics for CMIP6 + !! 4.0 ! 2010-08 ( C. Ethe, J. Deshayes ) Improvment + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dia_ptr : Poleward Transport Diagnostics module + !! dia_ptr_init : Initialization, namelist read + !! ptr_sjk : "zonal" mean computation of a field - tracer or flux array + !! ptr_sj : "zonal" and vertical sum computation of a "meridional" flux array + !! (Generic interface to ptr_sj_3d, ptr_sj_2d) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE domtile + USE phycst ! physical constants + ! + USE iom ! IOM library + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + INTERFACE ptr_sum + MODULE PROCEDURE ptr_sum_3d, ptr_sum_2d + END INTERFACE + + INTERFACE ptr_sj + MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d + END INTERFACE + + PUBLIC dia_ptr ! call in step module + PUBLIC dia_ptr_hst ! called from tra_ldf/tra_adv routines + PUBLIC dia_ptr_exc !an exception for a call in debug run + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: pvtr_int, pzon_int !: Other zonal integrals + + LOGICAL, PUBLIC :: l_diaptr !: tracers trend flag + INTEGER, PARAMETER :: jp_msk = 3 + INTEGER, PARAMETER :: jp_vtr = 4 + + REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup + REAL(wp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x rho0 x Cp) + REAL(wp) :: rc_ggram = 1.e-9_wp ! conversion from g to Gg (further x rho0) + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S) + + LOGICAL :: ll_init = .TRUE. !: tracers trend flag + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diaptr.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + ! NOTE: [tiling] tiling sometimes changes the diagnostics very slightly, usually where there are few zonal points e.g. the northern Indian Ocean basin. The difference is usually very small, for one point in one diagnostic. Presumably this is because of the additional zonal integration step over tiles. + SUBROUTINE dia_ptr( kt, Kmm, pvtr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step index + INTEGER , INTENT(in) :: Kmm ! time level index + REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dia_ptr') + + IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init ! -> will define l_diaptr and nbasin + ! + IF( l_diaptr ) THEN + ! Calculate zonal integrals + IF( PRESENT( pvtr ) ) THEN + CALL dia_ptr_zint( Kmm, pvtr) + ELSE + CALL dia_ptr_zint( Kmm ) + ENDIF + + ! Calculate diagnostics only when zonal integrals have finished + IF( .NOT. l_istiled .OR. ntile == nijtile ) CALL dia_ptr_iom(kt, Kmm, pvtr) + + ENDIF + + IF( ln_timing ) CALL timing_stop('dia_ptr') + ! + END SUBROUTINE dia_ptr + + SUBROUTINE dia_ptr_exc( kt, Kmm, pvtr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr *** + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step index + INTEGER , INTENT(in) :: Kmm ! time level index + REAL(dp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dia_ptr') + + IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init ! -> will define l_diaptr and nbasin + ! + IF( l_diaptr ) THEN + ! Calculate zonal integrals + IF( PRESENT( pvtr ) ) THEN + CALL dia_ptr_zint( Kmm, REAL(pvtr,wp)) + ELSE + CALL dia_ptr_zint( Kmm ) + ENDIF + + ! Calculate diagnostics only when zonal integrals have finished + IF( .NOT. l_istiled .OR. ntile == nijtile ) CALL dia_ptr_iom(kt, Kmm, REAL(pvtr,wp)) + + ENDIF + + IF( ln_timing ) CALL timing_stop('dia_ptr') + ! + END SUBROUTINE dia_ptr_exc + + + SUBROUTINE dia_ptr_iom( kt, Kmm, pvtr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr_iom *** + !!---------------------------------------------------------------------- + !! ** Purpose : Calculate diagnostics and send to XIOS + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step index + INTEGER , INTENT(in) :: Kmm ! time level index + REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + REAL(wp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace + ! + !overturning calculation + REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse + REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: zt_jk, zs_jk ! i-mean T and S, j-Stream-Function + + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: z4d1, z4d2 + REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: z3dtr + !!---------------------------------------------------------------------- + ! + ALLOCATE( z3dtr(jpi,jpj,nbasin) ) + + IF( PRESENT( pvtr ) ) THEN + IF( iom_use( 'zomsf' ) ) THEN ! effective MSF + ALLOCATE( z4d1(jpi,jpj,jpk,nbasin) ) + ! + DO jn = 1, nbasin ! by sub-basins + z4d1(1,:,:,jn) = pvtr_int(:,:,jp_vtr,jn) ! zonal cumulative effective transport excluding closed seas + DO jk = jpkm1, 1, -1 + z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn) ! effective j-Stream-Function (MSF) + END DO + DO ji = 2, jpi + z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) + ENDDO + END DO + CALL iom_put( 'zomsf', z4d1 * rc_sv ) + ! + DEALLOCATE( z4d1 ) + ENDIF + IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN + ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin), & + & zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) ) + ! + DO jn = 1, nbasin + sjk(:,:,jn) = pvtr_int(:,:,jp_msk,jn) + r1_sjk(:,:,jn) = 0._wp + WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) + ! i-mean T and S, j-Stream-Function, basin + zt_jk(:,:,jn) = pvtr_int(:,:,jp_tem,jn) * r1_sjk(:,:,jn) + zs_jk(:,:,jn) = pvtr_int(:,:,jp_sal,jn) * r1_sjk(:,:,jn) + v_msf(:,:,jn) = pvtr_int(:,:,jp_vtr,jn) + hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) + hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) + ! + ENDDO + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtove', z3dtr ) + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopstove', z3dtr ) + ! + DEALLOCATE( sjk, r1_sjk, v_msf, zt_jk, zs_jk ) + ENDIF + + IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN + ! Calculate barotropic heat and salt transport here + ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) ) + ! + DO jn = 1, nbasin + sjk(:,1,jn) = SUM( pvtr_int(:,:,jp_msk,jn), 2 ) + r1_sjk(:,1,jn) = 0._wp + WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) + ! + zvsum(:) = SUM( pvtr_int(:,:,jp_vtr,jn), 2 ) + ztsum(:) = SUM( pvtr_int(:,:,jp_tem,jn), 2 ) + zssum(:) = SUM( pvtr_int(:,:,jp_sal,jn), 2 ) + hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) + hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) + ! + ENDDO + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtbtr', z3dtr ) + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopstbtr', z3dtr ) + ! + DEALLOCATE( sjk, r1_sjk ) + ENDIF + ! + hstr_ove(:,:,:) = 0._wp ! Zero before next timestep + hstr_btr(:,:,:) = 0._wp + pvtr_int(:,:,:,:) = 0._wp + ELSE + IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface + ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) ) + ! + DO jn = 1, nbasin + z4d1(1,:,:,jn) = pzon_int(:,:,jp_msk,jn) + DO ji = 2, jpi + z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) + ENDDO + ENDDO + CALL iom_put( 'zosrf', z4d1 ) + ! + DO jn = 1, nbasin + z4d2(1,:,:,jn) = pzon_int(:,:,jp_tem,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) + DO ji = 2, jpi + z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) + ENDDO + ENDDO + CALL iom_put( 'zotem', z4d2 ) + ! + DO jn = 1, nbasin + z4d2(1,:,:,jn) = pzon_int(:,:,jp_sal,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) + DO ji = 2, jpi + z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) + ENDDO + ENDDO + CALL iom_put( 'zosal', z4d2 ) + ! + DEALLOCATE( z4d1, z4d2 ) + ENDIF + ! + ! ! Advective and diffusive heat and salt transport + IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN + ! + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtadv', z3dtr ) + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopstadv', z3dtr ) + ENDIF + ! + IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN + ! + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtldf', z3dtr ) + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopstldf', z3dtr ) + ENDIF + ! + IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN + ! + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophteiv', z3dtr ) + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopsteiv', z3dtr ) + ENDIF + ! + IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtvtr', z3dtr ) + DO jn = 1, nbasin + z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 2, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopstvtr', z3dtr ) + ENDIF + ! + IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN + CALL iom_get_var( 'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml + z2d(:,:) = ptr_ci_2d( z2d(:,:) ) + CALL iom_put( 'uocetr_vsum_cumul', z2d ) + ENDIF + ! + hstr_adv(:,:,:) = 0._wp ! Zero before next timestep + hstr_ldf(:,:,:) = 0._wp + hstr_eiv(:,:,:) = 0._wp + hstr_vtr(:,:,:) = 0._wp + pzon_int(:,:,:,:) = 0._wp + ENDIF + ! + DEALLOCATE( z3dtr ) + ! + END SUBROUTINE dia_ptr_iom + + + SUBROUTINE dia_ptr_zint( Kmm, pvtr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr_zint *** + !!---------------------------------------------------------------------- + !! ** Purpose : i and i-k sum operations on arrays + !! + !! ** Method : - Call ptr_sjk (i sum) or ptr_sj (i-k sum) to perform the sum operation + !! - Call ptr_sum to add this result to the sum over tiles + !! + !! ** Action : pvtr_int - terms for volume streamfunction, heat/salt transport barotropic/overturning terms + !! pzon_int - terms for i mean temperature/salinity + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: Kmm ! time level index + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zmask ! 3D workspace + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zts ! 4D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: sjk, v_msf ! Zonal sum: i-k surface area, j-effective transport + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt_jk, zs_jk ! Zonal sum: i-k surface area * (T, S) + REAL(wp) :: zsfc, zvfc ! i-k surface area + INTEGER :: ji, jj, jk, jn ! dummy loop indices + !!---------------------------------------------------------------------- + + IF( PRESENT( pvtr ) ) THEN + ! i sum of effective j transport excluding closed seas + IF( iom_use( 'zomsf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN + ALLOCATE( v_msf(A1Dj(nn_hls),jpk,nbasin) ) + + DO jn = 1, nbasin + v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) + ENDDO + + CALL ptr_sum( pvtr_int(:,:,jp_vtr,:), v_msf(:,:,:) ) + + DEALLOCATE( v_msf ) + ENDIF + + ! i sum of j surface area, j surface area - temperature/salinity product on V grid + IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & + & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN + ALLOCATE( zmask(A2D(nn_hls),jpk), zts(A2D(nn_hls),jpk,jpts), & + & sjk(A1Dj(nn_hls),jpk,nbasin), & + & zt_jk(A1Dj(nn_hls),jpk,nbasin), zs_jk(A1Dj(nn_hls),jpk,nbasin) ) + + zmask(:,:,:) = 0._wp + zts(:,:,:,:) = 0._wp + + DO_3D( 1, 1, 1, 0, 1, jpkm1 ) + zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) + zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc + zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid + zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc + END_3D + + DO jn = 1, nbasin + sjk(:,:,jn) = ptr_sjk( zmask(:,:,:) , btmsk(:,:,jn) ) + zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) + zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) + ENDDO + + CALL ptr_sum( pvtr_int(:,:,jp_msk,:), sjk(:,:,:) ) + CALL ptr_sum( pvtr_int(:,:,jp_tem,:), zt_jk(:,:,:) ) + CALL ptr_sum( pvtr_int(:,:,jp_sal,:), zs_jk(:,:,:) ) + + DEALLOCATE( zmask, zts, sjk, zt_jk, zs_jk ) + ENDIF + ELSE + ! i sum of j surface area - temperature/salinity product on T grid + IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN + ALLOCATE( zmask(A2D(nn_hls),jpk), zts(A2D(nn_hls),jpk,jpts), & + & sjk(A1Dj(nn_hls),jpk,nbasin), & + & zt_jk(A1Dj(nn_hls),jpk,nbasin), zs_jk(A1Dj(nn_hls),jpk,nbasin) ) + + zmask(:,:,:) = 0._wp + zts(:,:,:,:) = 0._wp + + DO_3D( 1, 1, 1, 1, 1, jpkm1 ) + zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) + zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc + zts(ji,jj,jk,jp_tem) = ts(ji,jj,jk,jp_tem,Kmm) * zsfc + zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc + END_3D + + DO jn = 1, nbasin + sjk(:,:,jn) = ptr_sjk( zmask(:,:,:) , btmsk(:,:,jn) ) + zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) + zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) + ENDDO + + CALL ptr_sum( pzon_int(:,:,jp_msk,:), sjk(:,:,:) ) + CALL ptr_sum( pzon_int(:,:,jp_tem,:), zt_jk(:,:,:) ) + CALL ptr_sum( pzon_int(:,:,jp_sal,:), zs_jk(:,:,:) ) + + DEALLOCATE( zmask, zts, sjk, zt_jk, zs_jk ) + ENDIF + + ! i-k sum of j surface area - temperature/salinity product on V grid + IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN + ALLOCATE( zts(A2D(nn_hls),jpk,jpts) ) + + zts(:,:,:,:) = 0._wp + + DO_3D( 1, 1, 1, 0, 1, jpkm1 ) + zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) + zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid + zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc + END_3D + + CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) + CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) + + DEALLOCATE( zts ) + ENDIF + ENDIF + END SUBROUTINE dia_ptr_zint + + + SUBROUTINE dia_ptr_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr_init *** + !! + !! ** Purpose : Initialization + !!---------------------------------------------------------------------- + INTEGER :: inum, jn ! local integers + !! + REAL(wp), DIMENSION(jpi,jpj) :: zmsk + !!---------------------------------------------------------------------- + + ! l_diaptr is defined with iom_use + ! --> dia_ptr_init must be done after the call to iom_init + ! --> cannot be .TRUE. without cpp key: key_xios --> nbasin define by iom_init is initialized + l_diaptr = iom_use( 'zomsf' ) .OR. iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. & + & iom_use( 'zosrf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & + & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR. & + & iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. & + & iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR. & + & iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) + + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) l_diaptr = ', l_diaptr + ENDIF + + IF( l_diaptr ) THEN + ! + IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) + ! + rc_pwatt = rc_pwatt * rho0_rcp ! conversion from K.s-1 to PetaWatt + rc_ggram = rc_ggram * rho0 ! conversion from m3/s to Gg/s + + IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum + + btmsk(:,:,1) = tmask_i(:,:) + IF( nbasin == 5 ) THEN ! nbasin has been initialized in iom_init to define the axis "basin" + CALL iom_open( 'subbasins', inum ) + CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin + CALL iom_get( inum, jpdom_global, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin + CALL iom_get( inum, jpdom_global, 'indmsk', btmsk(:,:,4) ) ! Indian basin + CALL iom_close( inum ) + btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin + ENDIF + DO jn = 2, nbasin + btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only + END DO + ! JD : modification so that overturning streamfunction is available in Atlantic at 34S to compare with observations + WHERE( gphit(:,:)*tmask_i(:,:) < -34._wp) + zmsk(:,:) = 0._wp ! mask out Southern Ocean + ELSE WHERE + zmsk(:,:) = ssmask(:,:) + END WHERE + btmsk34(:,:,1) = btmsk(:,:,1) + DO jn = 2, nbasin + btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:) ! interior domain only + ENDDO + + ! Initialise arrays to zero because diatpr is called before they are first calculated + ! Note that this means diagnostics will not be exactly correct when model run is restarted. + hstr_adv(:,:,:) = 0._wp + hstr_ldf(:,:,:) = 0._wp + hstr_eiv(:,:,:) = 0._wp + hstr_ove(:,:,:) = 0._wp + hstr_btr(:,:,:) = 0._wp ! + hstr_vtr(:,:,:) = 0._wp ! + pvtr_int(:,:,:,:) = 0._wp + pzon_int(:,:,:,:) = 0._wp + ! + ll_init = .FALSE. + ! + ENDIF + ! + END SUBROUTINE dia_ptr_init + + + SUBROUTINE dia_ptr_hst( ktra, cptr, pvflx ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr_hst *** + !!---------------------------------------------------------------------- + !! Wrapper for heat and salt transport calculations to calculate them for each basin + !! Called from all advection and/or diffusion routines + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ktra ! tracer index + CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv' + REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: pvflx ! 3D input array of advection/diffusion + REAL(wp), DIMENSION(A1Dj(nn_hls),nbasin) :: zsj ! + INTEGER :: jn ! + + DO jn = 1, nbasin + zsj(:,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) + ENDDO + ! + IF( cptr == 'adv' ) THEN + IF( ktra == jp_tem ) CALL ptr_sum( hstr_adv(:,jp_tem,:), zsj(:,:) ) + IF( ktra == jp_sal ) CALL ptr_sum( hstr_adv(:,jp_sal,:), zsj(:,:) ) + ELSE IF( cptr == 'ldf' ) THEN + IF( ktra == jp_tem ) CALL ptr_sum( hstr_ldf(:,jp_tem,:), zsj(:,:) ) + IF( ktra == jp_sal ) CALL ptr_sum( hstr_ldf(:,jp_sal,:), zsj(:,:) ) + ELSE IF( cptr == 'eiv' ) THEN + IF( ktra == jp_tem ) CALL ptr_sum( hstr_eiv(:,jp_tem,:), zsj(:,:) ) + IF( ktra == jp_sal ) CALL ptr_sum( hstr_eiv(:,jp_sal,:), zsj(:,:) ) + ELSE IF( cptr == 'vtr' ) THEN + IF( ktra == jp_tem ) CALL ptr_sum( hstr_vtr(:,jp_tem,:), zsj(:,:) ) + IF( ktra == jp_sal ) CALL ptr_sum( hstr_vtr(:,jp_sal,:), zsj(:,:) ) + ENDIF + ! + END SUBROUTINE dia_ptr_hst + + + SUBROUTINE ptr_sum_2d( phstr, pva ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ptr_sum_2d *** + !!---------------------------------------------------------------------- + !! ** Purpose : Add two 2D arrays with (j,nbasin) dimensions + !! + !! ** Method : - phstr = phstr + pva + !! - Call mpp_sum if the final tile + !! + !! ** Action : phstr + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpj,nbasin) , INTENT(inout) :: phstr ! + REAL(wp), DIMENSION(A1Dj(nn_hls),nbasin), INTENT(in) :: pva ! + INTEGER :: jj +#if ! defined key_mpi_off + INTEGER, DIMENSION(1) :: ish1d + INTEGER, DIMENSION(2) :: ish2d + REAL(wp), DIMENSION(jpj*nbasin) :: zwork +#endif + + DO jj = ntsj, ntej + phstr(jj,:) = phstr(jj,:) + pva(jj,:) + END DO + +#if ! defined key_mpi_off + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + ish1d(1) = jpj*nbasin + ish2d(1) = jpj ; ish2d(2) = nbasin + zwork(:) = RESHAPE( phstr(:,:), ish1d ) + CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) + phstr(:,:) = RESHAPE( zwork, ish2d ) + ENDIF +#endif + END SUBROUTINE ptr_sum_2d + + + SUBROUTINE ptr_sum_3d( phstr, pva ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ptr_sum_3d *** + !!---------------------------------------------------------------------- + !! ** Purpose : Add two 3D arrays with (j,k,nbasin) dimensions + !! + !! ** Method : - phstr = phstr + pva + !! - Call mpp_sum if the final tile + !! + !! ** Action : phstr + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpj,jpk,nbasin) , INTENT(inout) :: phstr ! + REAL(wp), DIMENSION(A1Dj(nn_hls),jpk,nbasin), INTENT(in) :: pva ! + INTEGER :: jj, jk +#if ! defined key_mpi_off + INTEGER, DIMENSION(1) :: ish1d + INTEGER, DIMENSION(3) :: ish3d + REAL(wp), DIMENSION(jpj*jpk*nbasin) :: zwork +#endif + + DO jk = 1, jpk + DO jj = ntsj, ntej + phstr(jj,jk,:) = phstr(jj,jk,:) + pva(jj,jk,:) + END DO + END DO + +#if ! defined key_mpi_off + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + ish1d(1) = jpj*jpk*nbasin + ish3d(1) = jpj ; ish3d(2) = jpk ; ish3d(3) = nbasin + zwork(:) = RESHAPE( phstr(:,:,:), ish1d ) + CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) + phstr(:,:,:) = RESHAPE( zwork, ish3d ) + ENDIF +#endif + END SUBROUTINE ptr_sum_3d + + + FUNCTION dia_ptr_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: dia_ptr_alloc ! return value + INTEGER, DIMENSION(2) :: ierr + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! + ! nbasin has been initialized in iom_init to define the axis "basin" + ! + IF( .NOT. ALLOCATED( btmsk ) ) THEN + ALLOCATE( btmsk(jpi,jpj,nbasin) , btmsk34(jpi,jpj,nbasin), & + & hstr_adv(jpj,jpts,nbasin), hstr_eiv(jpj,jpts,nbasin), & + & hstr_ove(jpj,jpts,nbasin), hstr_btr(jpj,jpts,nbasin), & + & hstr_ldf(jpj,jpts,nbasin), hstr_vtr(jpj,jpts,nbasin), STAT=ierr(1) ) + ! + ALLOCATE( pvtr_int(jpj,jpk,jpts+2,nbasin), & + & pzon_int(jpj,jpk,jpts+1,nbasin), STAT=ierr(2) ) + ! + dia_ptr_alloc = MAXVAL( ierr ) + CALL mpp_sum( 'diaptr', dia_ptr_alloc ) + ENDIF + ! + END FUNCTION dia_ptr_alloc + + + FUNCTION ptr_sj_3d( pvflx, pmsk ) RESULT ( p_fval ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ptr_sj_3d *** + !! + !! ** Purpose : i-k sum computation of a j-flux array + !! + !! ** Method : - i-k sum of pvflx using the interior 2D vmask (vmask_i). + !! pvflx is supposed to be a masked flux (i.e. * vmask*e1v*e3v) + !! + !! ** Action : - p_fval: i-k-mean poleward flux of pvflx + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(A2D(nn_hls),jpk) :: pvflx ! mask flux array at V-point + REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask + ! + INTEGER :: ji, jj, jk ! dummy loop arguments + REAL(wp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value + !!-------------------------------------------------------------------- + ! + p_fval(:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) + END_3D + END FUNCTION ptr_sj_3d + + + FUNCTION ptr_sj_2d( pvflx, pmsk ) RESULT ( p_fval ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ptr_sj_2d *** + !! + !! ** Purpose : "zonal" and vertical sum computation of a j-flux array + !! + !! ** Method : - i-k sum of pvflx using the interior 2D vmask (vmask_i). + !! pvflx is supposed to be a masked flux (i.e. * vmask*e1v*e3v) + !! + !! ** Action : - p_fval: i-k-mean poleward flux of pvflx + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls)) :: pvflx ! mask flux array at V-point + REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask + ! + INTEGER :: ji,jj ! dummy loop arguments + REAL(wp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value + !!-------------------------------------------------------------------- + ! + p_fval(:) = 0._wp + DO_2D( 0, 0, 0, 0 ) + p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) + END_2D + END FUNCTION ptr_sj_2d + + FUNCTION ptr_ci_2d( pva ) RESULT ( p_fval ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ptr_ci_2d *** + !! + !! ** Purpose : "meridional" cumulated sum computation of a j-flux array + !! + !! ** Method : - j cumulated sum of pva using the interior 2D vmask (umask_i). + !! + !! ** Action : - p_fval: j-cumulated sum of pva + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point + ! + INTEGER :: ji,jj,jc ! dummy loop arguments + INTEGER :: ijpj ! ??? + REAL(wp), DIMENSION(jpi,jpj) :: p_fval ! function value + !!-------------------------------------------------------------------- + ! + ijpj = jpj ! ??? + p_fval(:,:) = 0._wp + DO jc = 1, jpnj ! looping over all processors in j axis + DO_2D( 0, 0, 0, 0 ) + p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) + END_2D + END DO + ! + END FUNCTION ptr_ci_2d + + + + FUNCTION ptr_sjk( pta, pmsk ) RESULT ( p_fval ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ptr_sjk *** + !! + !! ** Purpose : i-sum computation of an array + !! + !! ** Method : - i-sum of field using the interior 2D vmask (pmsk). + !! + !! ** Action : - p_fval: i-sum of masked field + !!---------------------------------------------------------------------- + !! + IMPLICIT none + REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls),jpk) :: pta ! mask flux array at V-point + REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask + !! + INTEGER :: ji, jj, jk ! dummy loop arguments + REAL(wp), DIMENSION(A1Dj(nn_hls),jpk) :: p_fval ! return function value + !!-------------------------------------------------------------------- + ! + p_fval(:,:) = 0._wp + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) + END_3D + END FUNCTION ptr_sjk + + + !!====================================================================== +END MODULE diaptr diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diawri.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diawri.F90 new file mode 100644 index 0000000..89c9e88 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIA/diawri.F90 @@ -0,0 +1,1246 @@ +MODULE diawri + !!====================================================================== + !! *** MODULE diawri *** + !! Ocean diagnostics : write ocean output files + !!===================================================================== + !! History : OPA ! 1991-03 (M.-A. Foujols) Original code + !! 4.0 ! 1991-11 (G. Madec) + !! ! 1992-06 (M. Imbard) correction restart file + !! ! 1992-07 (M. Imbard) split into diawri and rstwri + !! ! 1993-03 (M. Imbard) suppress writibm + !! ! 1998-01 (C. Levy) NETCDF format using ioipsl INTERFACE + !! ! 1999-02 (E. Guilyardi) name of netCDF files + variables + !! 8.2 ! 2000-06 (M. Imbard) Original code (diabort.F) + !! NEMO 1.0 ! 2002-06 (A.Bozec, E. Durand) Original code (diainit.F) + !! - ! 2002-09 (G. Madec) F90: Free form and module + !! - ! 2002-12 (G. Madec) merge of diabort and diainit, F90 + !! ! 2005-11 (V. Garnier) Surface pressure gradient organization + !! 3.2 ! 2008-11 (B. Lemaire) creation from old diawri + !! 3.7 ! 2014-01 (G. Madec) remove eddy induced velocity from no-IOM output + !! ! change name of output variables in dia_wri_state + !! 4.0 ! 2020-10 (A. Nasser, S. Techene) add diagnostic for SWE + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dia_wri : create the standart output files + !! dia_wri_state : create an output NetCDF file for a single instantaeous ocean state and forcing fields + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE isf_oce + USE isfcpl + USE abl ! abl variables in case ln_abl = .true. + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE dianam ! build name of file (routine) + USE diahth ! thermocline diagnostics + USE dynadv , ONLY: ln_dynadv_vec + USE icb_oce ! Icebergs + USE icbdia ! Iceberg budgets + USE ldftra ! lateral physics: eddy diffusivity coef. + USE ldfdyn ! lateral physics: eddy viscosity coef. + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbc_ice ! Surface boundary condition: ice fields + USE sbcssr ! restoring term toward SST/SSS climatology + USE sbcwave ! wave parameters + USE wet_dry ! wetting and drying + USE zdf_oce ! ocean vertical physics + USE zdfdrg ! ocean vertical physics: top/bottom friction + USE zdfmxl ! mixed layer + USE zdfosm ! mixed layer + ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE in_out_manager ! I/O manager + USE dia25h ! 25h Mean output + USE iom ! + USE ioipsl ! + +#if defined key_si3 + USE ice + USE icewri +#endif + USE lib_mpp ! MPP library + USE timing ! preformance summary + USE diu_bulk ! diurnal warm layer + USE diu_coolskin ! Cool skin + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_wri ! routines called by step.F90 + PUBLIC dia_wri_state + PUBLIC dia_wri_alloc ! Called by nemogcm module +#if ! defined key_xios + PUBLIC dia_wri_alloc_abl ! Called by sbcabl module (if ln_abl = .true.) +#endif + INTEGER :: nid_T, nz_T, nh_T, ndim_T, ndim_hT ! grid_T file + INTEGER :: nb_T , ndim_bT ! grid_T file + INTEGER :: nid_U, nz_U, nh_U, ndim_U, ndim_hU ! grid_U file + INTEGER :: nid_V, nz_V, nh_V, ndim_V, ndim_hV ! grid_V file + INTEGER :: nid_W, nz_W, nh_W ! grid_W file + INTEGER :: nid_A, nz_A, nh_A, ndim_A, ndim_hA ! grid_ABL file + INTEGER :: ndex(1) ! ??? + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_hT, ndex_hU, ndex_hV + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_hA, ndex_A ! ABL + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_T, ndex_U, ndex_V + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_bT + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diawri.F90 15141 2021-07-23 14:20:12Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +#if defined key_xios + !!---------------------------------------------------------------------- + !! 'key_xios' use IOM library + !!---------------------------------------------------------------------- + INTEGER FUNCTION dia_wri_alloc() + ! + dia_wri_alloc = 0 + ! + END FUNCTION dia_wri_alloc + + + SUBROUTINE dia_wri( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dia_wri *** + !! + !! ** Purpose : Standard output of opa: dynamics and tracer fields + !! NETCDF format is used by default + !! + !! ** Method : use iom_put + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER, INTENT( in ) :: Kmm ! ocean time level index + !! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikbot ! local integer + REAL(wp):: zztmp , zztmpx ! local scalar + REAL(wp):: zztmp2, zztmpy ! - - + REAL(wp):: ze3 + REAL(wp), DIMENSION(A2D( 0)) :: z2d ! 2D workspace + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: z3d ! 3D workspace + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dia_wri') + ! + ! Output the initial state and forcings + IF( ninist == 1 ) THEN + CALL dia_wri_state( Kmm, 'output.init' ) + ninist = 0 + ENDIF + + ! initialize arrays + z2d(:,:) = 0._wp + z3d(:,:,:) = 0._wp + + ! Output of initial vertical scale factor + CALL iom_put("e3t_0", e3t_0(:,:,:) ) + CALL iom_put("e3u_0", e3u_0(:,:,:) ) + CALL iom_put("e3v_0", e3v_0(:,:,:) ) + CALL iom_put("e3f_0", e3f_0(:,:,:) ) + ! + IF ( iom_use("tpt_dep") ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = gdept(ji,jj,jk,Kmm) + END_3D + CALL iom_put( "tpt_dep", z3d ) + ENDIF + + ! --- vertical scale factors --- ! + IF ( iom_use("e3t") .OR. iom_use("e3tdef") ) THEN ! time-varying e3t + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = e3t(ji,jj,jk,Kmm) + END_3D + CALL iom_put( "e3t", z3d ) + IF ( iom_use("e3tdef") ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = ( ( z3d(ji,jj,jk) - e3t_0(ji,jj,jk) ) / e3t_0(ji,jj,jk) * 100._wp * tmask(ji,jj,jk) ) ** 2 + END_3D + CALL iom_put( "e3tdef", z3d ) + ENDIF + ENDIF + IF ( iom_use("e3u") ) THEN ! time-varying e3u + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = e3u(ji,jj,jk,Kmm) + END_3D + CALL iom_put( "e3u" , z3d ) + ENDIF + IF ( iom_use("e3v") ) THEN ! time-varying e3v + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = e3v(ji,jj,jk,Kmm) + END_3D + CALL iom_put( "e3v" , z3d ) + ENDIF + IF ( iom_use("e3w") ) THEN ! time-varying e3w + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = e3w(ji,jj,jk,Kmm) + END_3D + CALL iom_put( "e3w" , z3d ) + ENDIF + IF ( iom_use("e3f") ) THEN ! time-varying e3f caution here at Kaa + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = e3f(ji,jj,jk) + END_3D + CALL iom_put( "e3f" , z3d ) + ENDIF + + IF ( iom_use("ssh") ) THEN + IF( ll_wd ) THEN ! sea surface height (brought back to the reference used for wetting and drying) + CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*ssmask(:,:) ) + ELSE + CALL iom_put( "ssh" , ssh(:,:,Kmm) ) ! sea surface height + ENDIF + ENDIF + + IF( iom_use("wetdep") ) CALL iom_put( "wetdep" , ht_0(:,:) + ssh(:,:,Kmm) ) ! wet depth + +#if defined key_qco + IF( iom_use("ht") ) CALL iom_put( "ht" , ht(:,:) ) ! water column at t-point + IF( iom_use("hu") ) CALL iom_put( "hu" , hu(:,:,Kmm) ) ! water column at u-point + IF( iom_use("hv") ) CALL iom_put( "hv" , hv(:,:,Kmm) ) ! water column at v-point + IF( iom_use("hf") ) CALL iom_put( "hf" , hf_0(:,:)*( 1._wp + r3f(:,:) ) ) ! water column at f-point (caution here at Naa) +#endif + + ! --- tracers T&S --- ! + CALL iom_put( "toce", ts(:,:,:,jp_tem,Kmm) ) ! 3D temperature + CALL iom_put( "sst", ts(:,:,1,jp_tem,Kmm) ) ! surface temperature + + IF ( iom_use("sbt") ) THEN + DO_2D( 0, 0, 0, 0 ) + ikbot = mbkt(ji,jj) + z2d(ji,jj) = ts(ji,jj,ikbot,jp_tem,Kmm) + END_2D + CALL iom_put( "sbt", z2d ) ! bottom temperature + ENDIF + + CALL iom_put( "soce", ts(:,:,:,jp_sal,Kmm) ) ! 3D salinity + CALL iom_put( "sss", ts(:,:,1,jp_sal,Kmm) ) ! surface salinity + IF ( iom_use("sbs") ) THEN + DO_2D( 0, 0, 0, 0 ) + ikbot = mbkt(ji,jj) + z2d(ji,jj) = ts(ji,jj,ikbot,jp_sal,Kmm) + END_2D + CALL iom_put( "sbs", z2d ) ! bottom salinity + ENDIF + + IF( .NOT.lk_SWE ) CALL iom_put( "rhop", rhop(:,:,:) ) ! 3D potential density (sigma0) + + ! --- momentum --- ! + IF ( iom_use("taubot") ) THEN ! bottom stress + zztmp = rho0 * 0.25_wp + z2d(:,:) = 0._wp + DO_2D( 0, 0, 0, 0 ) + zztmp2 = ( ( rCdU_bot(ji+1,jj)+rCdU_bot(ji ,jj) ) * uu(ji ,jj,mbku(ji ,jj),Kmm) )**2 & + & + ( ( rCdU_bot(ji ,jj)+rCdU_bot(ji-1,jj) ) * uu(ji-1,jj,mbku(ji-1,jj),Kmm) )**2 & + & + ( ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj ) ) * vv(ji,jj ,mbkv(ji,jj ),Kmm) )**2 & + & + ( ( rCdU_bot(ji,jj )+rCdU_bot(ji,jj-1) ) * vv(ji,jj-1,mbkv(ji,jj-1),Kmm) )**2 + z2d(ji,jj) = zztmp * SQRT( zztmp2 ) * tmask(ji,jj,1) + ! + END_2D + CALL iom_put( "taubot", z2d ) + ENDIF + + CALL iom_put( "uoce", uu(:,:,:,Kmm) ) ! 3D i-current + CALL iom_put( "ssu", uu(:,:,1,Kmm) ) ! surface i-current + IF ( iom_use("sbu") ) THEN + DO_2D( 0, 0, 0, 0 ) + ikbot = mbku(ji,jj) + z2d(ji,jj) = uu(ji,jj,ikbot,Kmm) + END_2D + CALL iom_put( "sbu", z2d ) ! bottom i-current + ENDIF + + CALL iom_put( "voce", vv(:,:,:,Kmm) ) ! 3D j-current + CALL iom_put( "ssv", vv(:,:,1,Kmm) ) ! surface j-current + IF ( iom_use("sbv") ) THEN + DO_2D( 0, 0, 0, 0 ) + ikbot = mbkv(ji,jj) + z2d(ji,jj) = vv(ji,jj,ikbot,Kmm) + END_2D + CALL iom_put( "sbv", z2d ) ! bottom j-current + ENDIF + + ! ! vertical velocity + IF( ln_zad_Aimp ) THEN + IF( iom_use('woce') ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = ww(ji,jj,jk) + wi(ji,jj,jk) + END_3D + CALL iom_put( "woce", z3d ) ! explicit plus implicit parts + ENDIF + ELSE + CALL iom_put( "woce", ww ) + ENDIF + + IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN ! vertical mass transport & its square value + ! ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. + IF( ln_zad_Aimp ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = rho0 * e1e2t(ji,jj) * ( ww(ji,jj,jk) + wi(ji,jj,jk) ) + END_3D + ELSE + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = rho0 * e1e2t(ji,jj) * ww(ji,jj,jk) + END_3D + ENDIF + CALL iom_put( "w_masstr" , z3d ) + IF( iom_use('w_masstr2') ) CALL iom_put( "w_masstr2", z3d * z3d ) + ENDIF + + CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef. + CALL iom_put( "avs" , avs ) ! S vert. eddy diff. coef. + CALL iom_put( "avm" , avm ) ! T vert. eddy visc. coef. + + IF( iom_use('logavt') ) CALL iom_put( "logavt", LOG( MAX( 1.e-20_wp, avt(:,:,:) ) ) ) + IF( iom_use('logavs') ) CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, avs(:,:,:) ) ) ) + + IF ( iom_use("sssgrad") .OR. iom_use("sssgrad2") ) THEN + DO_2D( 0, 0, 0, 0 ) ! sss gradient + zztmp = ts(ji,jj,1,jp_sal,Kmm) + zztmpx = (ts(ji+1,jj,1,jp_sal,Kmm) - zztmp) * r1_e1u(ji,jj) + (zztmp - ts(ji-1,jj ,1,jp_sal,Kmm)) * r1_e1u(ji-1,jj) + zztmpy = (ts(ji,jj+1,1,jp_sal,Kmm) - zztmp) * r1_e2v(ji,jj) + (zztmp - ts(ji ,jj-1,1,jp_sal,Kmm)) * r1_e2v(ji,jj-1) + z2d(ji,jj) = 0.25_wp * ( zztmpx * zztmpx + zztmpy * zztmpy ) & + & * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * vmask(ji,jj-1,1) + END_2D + CALL iom_put( "sssgrad2", z2d ) ! square of module of sss gradient + IF ( iom_use("sssgrad") ) THEN + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = SQRT( z2d(ji,jj) ) + END_2D + CALL iom_put( "sssgrad", z2d ) ! module of sss gradient + ENDIF + ENDIF + + IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN + DO_2D( 0, 0, 0, 0 ) ! sst gradient + zztmp = ts(ji,jj,1,jp_tem,Kmm) + zztmpx = ( ts(ji+1,jj,1,jp_tem,Kmm) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - ts(ji-1,jj ,1,jp_tem,Kmm) ) * r1_e1u(ji-1,jj) + zztmpy = ( ts(ji,jj+1,1,jp_tem,Kmm) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - ts(ji ,jj-1,1,jp_tem,Kmm) ) * r1_e2v(ji,jj-1) + z2d(ji,jj) = 0.25_wp * ( zztmpx * zztmpx + zztmpy * zztmpy ) & + & * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * vmask(ji,jj-1,1) + END_2D + CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient + IF ( iom_use("sstgrad") ) THEN + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = SQRT( z2d(ji,jj) ) + END_2D + CALL iom_put( "sstgrad", z2d ) ! module of sst gradient + ENDIF + ENDIF + + ! heat and salt contents + IF( iom_use("heatc") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) * tmask(ji,jj,jk) + END_3D + CALL iom_put( "heatc", rho0_rcp * z2d ) ! vertically integrated heat content (J/m2) + ENDIF + + IF( iom_use("saltc") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk) + END_3D + CALL iom_put( "saltc", rho0 * z2d ) ! vertically integrated salt content (PSU*kg/m2) + ENDIF + ! + IF( iom_use("salt2c") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk) + END_3D + CALL iom_put( "salt2c", rho0 * z2d ) ! vertically integrated square of salt content (PSU2*kg/m2) + ENDIF + ! + IF ( iom_use("ke") .OR. iom_use("ke_int") ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + zztmpx = uu(ji-1,jj ,jk,Kmm) + uu(ji,jj,jk,Kmm) + zztmpy = vv(ji ,jj-1,jk,Kmm) + vv(ji,jj,jk,Kmm) + z3d(ji,jj,jk) = 0.25_wp * ( zztmpx*zztmpx + zztmpy*zztmpy ) + END_3D + CALL iom_put( "ke", z3d ) ! kinetic energy + + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * z3d(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk) + END_3D + CALL iom_put( "ke_int", z2d ) ! vertically integrated kinetic energy + ENDIF + ! + IF ( iom_use("sKE") ) THEN ! surface kinetic energy at T point + z2d(:,:) = 0._wp + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = 0.25_wp * ( uu(ji ,jj,1,Kmm) * uu(ji ,jj,1,Kmm) * e1e2u(ji ,jj) * e3u(ji ,jj,1,Kmm) & + & + uu(ji-1,jj,1,Kmm) * uu(ji-1,jj,1,Kmm) * e1e2u(ji-1,jj) * e3u(ji-1,jj,1,Kmm) & + & + vv(ji,jj ,1,Kmm) * vv(ji,jj ,1,Kmm) * e1e2v(ji,jj ) * e3v(ji,jj ,1,Kmm) & + & + vv(ji,jj-1,1,Kmm) * vv(ji,jj-1,1,Kmm) * e1e2v(ji,jj-1) * e3v(ji,jj-1,1,Kmm) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,1,Kmm) * ssmask(ji,jj) + END_2D + IF ( iom_use("sKE" ) ) CALL iom_put( "sKE" , z2d ) + ENDIF + ! + IF ( iom_use("ssKEf") ) THEN ! surface kinetic energy at F point + z2d(:,:) = 0._wp ! CAUTION : only valid in SWE, not with bathymetry + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = 0.25_wp * ( uu(ji,jj ,1,Kmm) * uu(ji,jj ,1,Kmm) * e1e2u(ji,jj ) * e3u(ji,jj ,1,Kmm) & + & + uu(ji,jj+1,1,Kmm) * uu(ji,jj+1,1,Kmm) * e1e2u(ji,jj+1) * e3u(ji,jj+1,1,Kmm) & + & + vv(ji ,jj,1,Kmm) * vv(ji,jj ,1,Kmm) * e1e2v(ji ,jj) * e3v(ji ,jj,1,Kmm) & + & + vv(ji+1,jj,1,Kmm) * vv(ji+1,jj,1,Kmm) * e1e2v(ji+1,jj) * e3v(ji+1,jj,1,Kmm) ) & + & * r1_e1e2f(ji,jj) / e3f(ji,jj,1) * ssfmask(ji,jj) + END_2D + CALL iom_put( "ssKEf", z2d ) + ENDIF + ! + CALL iom_put( "hdiv", hdiv ) ! Horizontal divergence + ! + IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN + + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = rho0 * uu(ji,jj,jk,Kmm) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk) + END_3D + CALL iom_put( "u_masstr" , z3d ) ! mass transport in i-direction + + IF( iom_use("u_masstr_vint") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) + END_3D + CALL iom_put( "u_masstr_vint", z2d ) ! mass transport in i-direction vertical sum + ENDIF + IF( iom_use("u_heattr") ) THEN + z2d(:,:) = 0._wp + zztmp = 0.5_wp * rcp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + zztmp * z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) ) + END_3D + CALL iom_put( "u_heattr", z2d ) ! heat transport in i-direction + ENDIF + IF( iom_use("u_salttr") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + 0.5 * z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) ) + END_3D + CALL iom_put( "u_salttr", z2d ) ! heat transport in i-direction + ENDIF + + ENDIF + + IF( iom_use("v_masstr") .OR. iom_use("v_heattr") .OR. iom_use("v_salttr") ) THEN + + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = rho0 * vv(ji,jj,jk,Kmm) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk) + END_3D + CALL iom_put( "v_masstr", z3d ) ! mass transport in j-direction + + IF( iom_use("v_heattr") ) THEN + z2d(:,:) = 0._wp + zztmp = 0.5_wp * rcp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + zztmp * z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) ) + END_3D + CALL iom_put( "v_heattr", z2d ) ! heat transport in j-direction + ENDIF + IF( iom_use("v_salttr") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + 0.5 * z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) ) + END_3D + CALL iom_put( "v_salttr", z2d ) ! heat transport in j-direction + ENDIF + + ENDIF + + IF( iom_use("tosmint") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + rho0 * e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) + END_3D + CALL iom_put( "tosmint", z2d ) ! Vertical integral of temperature + ENDIF + IF( iom_use("somint") ) THEN + z2d(:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + z2d(ji,jj) = z2d(ji,jj) + rho0 * e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) + END_3D + CALL iom_put( "somint", z2d ) ! Vertical integral of salinity + ENDIF + + CALL iom_put( "bn2", rn2 ) ! Brunt-Vaisala buoyancy frequency (N^2) + + IF (ln_dia25h) CALL dia_25h( kt, Kmm ) ! 25h averaging + + ! Output of surface vorticity terms + ! + CALL iom_put( "ssplavor", ff_f ) ! planetary vorticity ( f ) + ! + IF ( iom_use("ssrelvor") .OR. iom_use("ssEns") .OR. & + & iom_use("ssrelpotvor") .OR. iom_use("ssabspotvor") ) THEN + ! + z2d(:,:) = 0._wp + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = ( e2v(ji+1,jj ) * vv(ji+1,jj ,1,Kmm) - e2v(ji,jj) * vv(ji,jj,1,Kmm) & + & - e1u(ji ,jj+1) * uu(ji ,jj+1,1,Kmm) + e1u(ji,jj) * uu(ji,jj,1,Kmm) ) * r1_e1e2f(ji,jj) + END_2D + CALL iom_put( "ssrelvor", z2d ) ! relative vorticity ( zeta ) + ! + IF ( iom_use("ssEns") .OR. iom_use("ssrelpotvor") .OR. iom_use("ssabspotvor") ) THEN + DO_2D( 0, 0, 0, 0 ) + ze3 = ( e3t(ji,jj+1,1,Kmm) * e1e2t(ji,jj+1) + e3t(ji+1,jj+1,1,Kmm) * e1e2t(ji+1,jj+1) & + & + e3t(ji,jj ,1,Kmm) * e1e2t(ji,jj ) + e3t(ji+1,jj ,1,Kmm) * e1e2t(ji+1,jj ) ) * r1_e1e2f(ji,jj) + IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3 + ELSE ; ze3 = 0._wp + ENDIF + z2d(ji,jj) = ze3 * z2d(ji,jj) + END_2D + CALL iom_put( "ssrelpotvor", z2d ) ! relative potential vorticity (zeta/h) + ! + IF ( iom_use("ssEns") .OR. iom_use("ssabspotvor") ) THEN + DO_2D( 0, 0, 0, 0 ) + ze3 = ( e3t(ji,jj+1,1,Kmm) * e1e2t(ji,jj+1) + e3t(ji+1,jj+1,1,Kmm) * e1e2t(ji+1,jj+1) & + & + e3t(ji,jj ,1,Kmm) * e1e2t(ji,jj ) + e3t(ji+1,jj ,1,Kmm) * e1e2t(ji+1,jj ) ) * r1_e1e2f(ji,jj) + IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3 + ELSE ; ze3 = 0._wp + ENDIF + z2d(ji,jj) = ze3 * ff_f(ji,jj) + z2d(ji,jj) + END_2D + CALL iom_put( "ssabspotvor", z2d ) ! absolute potential vorticity ( q ) + ! + IF ( iom_use("ssEns") ) THEN + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = 0.5_wp * z2d(ji,jj) * z2d(ji,jj) + END_2D + CALL iom_put( "ssEns", z2d ) ! potential enstrophy ( 1/2*q2 ) + ENDIF + ENDIF + ENDIF + ENDIF + + IF( ln_timing ) CALL timing_stop('dia_wri') + ! + END SUBROUTINE dia_wri + +#else + !!---------------------------------------------------------------------- + !! Default option use IOIPSL library + !!---------------------------------------------------------------------- + + INTEGER FUNCTION dia_wri_alloc() + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(2) :: ierr + !!---------------------------------------------------------------------- + IF( nn_write == -1 ) THEN + dia_wri_alloc = 0 + ELSE + ierr = 0 + ALLOCATE( ndex_hT(jpi*jpj) , ndex_T(jpi*jpj*jpk) , & + & ndex_hU(jpi*jpj) , ndex_U(jpi*jpj*jpk) , & + & ndex_hV(jpi*jpj) , ndex_V(jpi*jpj*jpk) , STAT=ierr(1) ) + ! + dia_wri_alloc = MAXVAL(ierr) + CALL mpp_sum( 'diawri', dia_wri_alloc ) + ! + ENDIF + ! + END FUNCTION dia_wri_alloc + + INTEGER FUNCTION dia_wri_alloc_abl() + !!---------------------------------------------------------------------- + ALLOCATE( ndex_hA(jpi*jpj), ndex_A (jpi*jpj*jpkam1), STAT=dia_wri_alloc_abl) + CALL mpp_sum( 'diawri', dia_wri_alloc_abl ) + ! + END FUNCTION dia_wri_alloc_abl + + + SUBROUTINE dia_wri( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dia_wri *** + !! + !! ** Purpose : Standard output of opa: dynamics and tracer fields + !! NETCDF format is used by default + !! + !! ** Method : At the beginning of the first time step (nit000), + !! define all the NETCDF files and fields + !! At each time step call histdef to compute the mean if ncessary + !! Each nn_write time step, output the instantaneous or mean fields + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER, INTENT( in ) :: Kmm ! ocean time level index + ! + LOGICAL :: ll_print = .FALSE. ! =T print and flush numout + CHARACTER (len=40) :: clhstnam, clop, clmx ! local names + INTEGER :: inum = 11 ! temporary logical unit + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ierr ! error code return from allocation + INTEGER :: iimi, iima, ipk, it, itmod, ijmi, ijma ! local integers + INTEGER :: ipka ! ABL + INTEGER :: jn, ierror ! local integers + REAL(dp) :: zsto, zout, zmax, zjulian ! local scalars + ! + REAL(wp), DIMENSION(jpi,jpj ) :: z2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zw3d_abl ! ABL 3D workspace + !!---------------------------------------------------------------------- + ! + IF( ninist == 1 ) THEN !== Output the initial state and forcings ==! + CALL dia_wri_state( Kmm, 'output.init' ) + ninist = 0 + ENDIF + ! + IF( nn_write == -1 ) RETURN ! we will never do any output + ! + IF( ln_timing ) CALL timing_start('dia_wri') + ! + ! 0. Initialisation + ! ----------------- + + ll_print = .FALSE. ! local variable for debugging + ll_print = ll_print .AND. lwp + + ! Define frequency of output and means + clop = "x" ! no use of the mask value (require less cpu time and otherwise the model crashes) +#if defined key_diainstant + zsto = nn_write * rn_Dt + clop = "inst("//TRIM(clop)//")" +#else + zsto=rn_Dt + clop = "ave("//TRIM(clop)//")" +#endif + zout = nn_write * rn_Dt + zmax = ( nitend - nit000 + 1 ) * rn_Dt + + ! Define indices of the horizontal output zoom and vertical limit storage + iimi = Nis0 ; iima = Nie0 + ijmi = Njs0 ; ijma = Nje0 + ipk = jpk + IF(ln_abl) ipka = jpkam1 + + ! define time axis + it = kt + itmod = kt - nit000 + 1 + + ! 1. Define NETCDF files and fields at beginning of first time step + ! ----------------------------------------------------------------- + + IF( kt == nit000 ) THEN + + ! Define the NETCDF files (one per grid) + + ! Compute julian date from starting date of the run + CALL ymds2ju( nyear, nmonth, nday, rn_Dt, zjulian ) + zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*) 'Date 0 used :', nit000, ' YEAR ', nyear, & + & ' MONTH ', nmonth, ' DAY ', nday, 'Julian day : ', zjulian + IF(lwp)WRITE(numout,*) ' indexes of zoom = ', iimi, iima, ijmi, ijma, & + ' limit storage in depth = ', ipk + + ! WRITE root name in date.file for use by postpro + IF(lwp) THEN + CALL dia_nam( clhstnam, nn_write,' ' ) + CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) + WRITE(inum,*) clhstnam + CLOSE(inum) + ENDIF + + ! Define the T grid FILE ( nid_T ) + + CALL dia_nam( clhstnam, nn_write, 'grid_T' ) + IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename + CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit + & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, & + & nit000-1, zjulian, rn_Dt, nh_T, nid_T, domain_id=nidom, snc4chunks=snc4set ) + CALL histvert( nid_T, "deptht", "Vertical T levels", & ! Vertical grid: gdept + & "m", ipk, gdept_1d, nz_T, "down" ) + ! ! Index of ocean points + CALL wheneq( jpi*jpj*ipk, tmask, 1, 1., ndex_T , ndim_T ) ! volume + CALL wheneq( jpi*jpj , tmask, 1, 1., ndex_hT, ndim_hT ) ! surface + ! + IF( ln_icebergs ) THEN + ! + !! allocation cant go in dia_wri_alloc because ln_icebergs is only set after + !! that routine is called from nemogcm, so do it here immediately before its needed + ALLOCATE( ndex_bT(jpi*jpj*nclasses), STAT=ierror ) + CALL mpp_sum( 'diawri', ierror ) + IF( ierror /= 0 ) THEN + CALL ctl_stop('dia_wri: failed to allocate iceberg diagnostic array') + RETURN + ENDIF + ! + !! iceberg vertical coordinate is class number + CALL histvert( nid_T, "class", "Iceberg class", & ! Vertical grid: class + & "number", nclasses, class_num, nb_T ) + ! + !! each class just needs the surface index pattern + ndim_bT = 3 + DO jn = 1,nclasses + ndex_bT((jn-1)*jpi*jpj+1:jn*jpi*jpj) = ndex_hT(1:jpi*jpj) + ENDDO + ! + ENDIF + + ! Define the U grid FILE ( nid_U ) + + CALL dia_nam( clhstnam, nn_write, 'grid_U' ) + IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename + CALL histbeg( clhstnam, jpi, glamu, jpj, gphiu, & ! Horizontal grid: glamu and gphiu + & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, & + & nit000-1, zjulian, rn_Dt, nh_U, nid_U, domain_id=nidom, snc4chunks=snc4set ) + CALL histvert( nid_U, "depthu", "Vertical U levels", & ! Vertical grid: gdept + & "m", ipk, gdept_1d, nz_U, "down" ) + ! ! Index of ocean points + CALL wheneq( jpi*jpj*ipk, umask, 1, 1., ndex_U , ndim_U ) ! volume + CALL wheneq( jpi*jpj , umask, 1, 1., ndex_hU, ndim_hU ) ! surface + + ! Define the V grid FILE ( nid_V ) + + CALL dia_nam( clhstnam, nn_write, 'grid_V' ) ! filename + IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam + CALL histbeg( clhstnam, jpi, glamv, jpj, gphiv, & ! Horizontal grid: glamv and gphiv + & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, & + & nit000-1, zjulian, rn_Dt, nh_V, nid_V, domain_id=nidom, snc4chunks=snc4set ) + CALL histvert( nid_V, "depthv", "Vertical V levels", & ! Vertical grid : gdept + & "m", ipk, gdept_1d, nz_V, "down" ) + ! ! Index of ocean points + CALL wheneq( jpi*jpj*ipk, vmask, 1, 1., ndex_V , ndim_V ) ! volume + CALL wheneq( jpi*jpj , vmask, 1, 1., ndex_hV, ndim_hV ) ! surface + + ! Define the W grid FILE ( nid_W ) + + CALL dia_nam( clhstnam, nn_write, 'grid_W' ) ! filename + IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam + CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit + & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, & + & nit000-1, zjulian, rn_Dt, nh_W, nid_W, domain_id=nidom, snc4chunks=snc4set ) + CALL histvert( nid_W, "depthw", "Vertical W levels", & ! Vertical grid: gdepw + & "m", ipk, gdepw_1d, nz_W, "down" ) + + IF( ln_abl ) THEN + ! Define the ABL grid FILE ( nid_A ) + CALL dia_nam( clhstnam, nn_write, 'grid_ABL' ) + IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename + CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit + & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, & + & nit000-1, zjulian, rn_Dt, nh_A, nid_A, domain_id=nidom, snc4chunks=snc4set ) + CALL histvert( nid_A, "ght_abl", "Vertical T levels", & ! Vertical grid: gdept + & "m", ipka, ght_abl(2:jpka), nz_A, "up" ) + ! ! Index of ocean points + ALLOCATE( zw3d_abl(jpi,jpj,ipka) ) + zw3d_abl(:,:,:) = 1._wp + CALL wheneq( jpi*jpj*ipka, zw3d_abl, 1, 1., ndex_A , ndim_A ) ! volume + CALL wheneq( jpi*jpj , zw3d_abl, 1, 1., ndex_hA, ndim_hA ) ! surface + DEALLOCATE(zw3d_abl) + ENDIF + ! + + ! Declare all the output fields as NETCDF variables + + ! !!! nid_T : 3D + CALL histdef( nid_T, "votemper", "Temperature" , "C" , & ! tn + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + CALL histdef( nid_T, "vosaline", "Salinity" , "PSU" , & ! sn + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + IF( .NOT.ln_linssh ) THEN + CALL histdef( nid_T, "vovvle3t", "Level thickness" , "m" ,& ! e3t n + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + CALL histdef( nid_T, "vovvldep", "T point depth" , "m" ,& ! e3t n + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + CALL histdef( nid_T, "vovvldef", "Squared level deformation" , "%^2" ,& ! e3t n + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + ENDIF + ! !!! nid_T : 2D + CALL histdef( nid_T, "sosstsst", "Sea Surface temperature" , "C" , & ! sst + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sosaline", "Sea Surface Salinity" , "PSU" , & ! sss + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sossheig", "Sea Surface Height" , "m" , & ! ssh + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sowaflup", "Net Upward Water Flux" , "Kg/m2/s", & ! (emp-rnf) + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sorunoff", "River runoffs" , "Kg/m2/s", & ! runoffs + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sosfldow", "downward salt flux" , "PSU/m2/s", & ! sfx + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + IF( ln_linssh ) THEN + CALL histdef( nid_T, "sosst_cd", "Concentration/Dilution term on temperature" & ! emp * ts(:,:,1,jp_tem,Kmm) + & , "KgC/m2/s", & ! sosst_cd + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sosss_cd", "Concentration/Dilution term on salinity" & ! emp * ts(:,:,1,jp_sal,Kmm) + & , "KgPSU/m2/s",& ! sosss_cd + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + ENDIF + CALL histdef( nid_T, "sohefldo", "Net Downward Heat Flux" , "W/m2" , & ! qns + qsr + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "soshfldo", "Shortwave Radiation" , "W/m2" , & ! qsr + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + IF( ALLOCATED(hmld) ) THEN ! zdf_mxl not called by SWE + CALL histdef( nid_T, "somixhgt", "Turbocline Depth" , "m" , & ! hmld + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "somxl010", "Mixed Layer Depth 0.01" , "m" , & ! hmlp + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + ENDIF + CALL histdef( nid_T, "soicecov", "Ice fraction" , "[0,1]" , & ! fr_i + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sowindsp", "wind speed at 10m" , "m/s" , & ! wndm + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + ! + IF( ln_abl ) THEN + CALL histdef( nid_A, "t_abl", "Potential Temperature" , "K" , & ! t_abl + & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout ) + CALL histdef( nid_A, "q_abl", "Humidity" , "kg/kg" , & ! q_abl + & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout ) + CALL histdef( nid_A, "u_abl", "Atmospheric U-wind " , "m/s" , & ! u_abl + & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout ) + CALL histdef( nid_A, "v_abl", "Atmospheric V-wind " , "m/s" , & ! v_abl + & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout ) + CALL histdef( nid_A, "tke_abl", "Atmospheric TKE " , "m2/s2" , & ! tke_abl + & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout ) + CALL histdef( nid_A, "avm_abl", "Atmospheric turbulent viscosity", "m2/s" , & ! avm_abl + & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout ) + CALL histdef( nid_A, "avt_abl", "Atmospheric turbulent diffusivity", "m2/s2", & ! avt_abl + & jpi, jpj, nh_A, ipka, 1, ipka, nz_A, 32, clop, zsto, zout ) + CALL histdef( nid_A, "pblh", "Atmospheric boundary layer height " , "m", & ! pblh + & jpi, jpj, nh_A, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) +#if defined key_si3 + CALL histdef( nid_A, "oce_frac", "Fraction of open ocean" , " ", & ! ato_i + & jpi, jpj, nh_A, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) +#endif + CALL histend( nid_A, snc4chunks=snc4set ) + ENDIF + ! + IF( ln_icebergs ) THEN + CALL histdef( nid_T, "calving" , "calving mass input" , "kg/s" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "calving_heat" , "calving heat flux" , "XXXX" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_floating_melt" , "Melt rate of icebergs + bits" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_stored_ice" , "Accumulated ice mass by class" , "kg" , & + & jpi, jpj, nh_T, nclasses , 1, nclasses , nb_T , 32, clop, zsto, zout ) + IF( ln_bergdia ) THEN + CALL histdef( nid_T, "berg_melt" , "Melt rate of icebergs" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_buoy_melt" , "Buoyancy component of iceberg melt rate" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_eros_melt" , "Erosion component of iceberg melt rate" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_conv_melt" , "Convective component of iceberg melt rate", "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_virtual_area" , "Virtual coverage by icebergs" , "m2" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "bits_src" , "Mass source of bergy bits" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "bits_melt" , "Melt rate of bergy bits" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "bits_mass" , "Bergy bit density field" , "kg/m2" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_mass" , "Iceberg density field" , "kg/m2" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_real_calving" , "Calving into iceberg class" , "kg/s" , & + & jpi, jpj, nh_T, nclasses , 1, nclasses , nb_T , 32, clop, zsto, zout ) + ENDIF + ENDIF + + IF( ln_ssr ) THEN + CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping" , "Kg/m2/s", & ! erp + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sosafldp", "Surface salt flux: damping" , "Kg/m2/s", & ! erp * sn + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + ENDIF + + clmx ="l_max(only(x))" ! max index on a period +! CALL histdef( nid_T, "sobowlin", "Bowl Index" , "W-point", & ! bowl INDEX +! & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clmx, zsto, zout ) +#if defined key_diahth + CALL histdef( nid_T, "sothedep", "Thermocline Depth" , "m" , & ! hth + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "so20chgt", "Depth of 20C isotherm" , "m" , & ! hd20 + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "so28chgt", "Depth of 28C isotherm" , "m" , & ! hd28 + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sohtc300", "Heat content 300 m" , "J/m2" , & ! htc3 + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) +#endif + + CALL histend( nid_T, snc4chunks=snc4set ) + + ! !!! nid_U : 3D + CALL histdef( nid_U, "vozocrtx", "Zonal Current" , "m/s" , & ! uu(:,:,:,Kmm) + & jpi, jpj, nh_U, ipk, 1, ipk, nz_U, 32, clop, zsto, zout ) + IF( ln_wave .AND. ln_sdw) THEN + CALL histdef( nid_U, "sdzocrtx", "Stokes Drift Zonal Current" , "m/s" , & ! usd + & jpi, jpj, nh_U, ipk, 1, ipk, nz_U, 32, clop, zsto, zout ) + ENDIF + ! !!! nid_U : 2D + CALL histdef( nid_U, "sozotaux", "Wind Stress along i-axis" , "N/m2" , & ! utau + & jpi, jpj, nh_U, 1 , 1, 1 , - 99, 32, clop, zsto, zout ) + + CALL histend( nid_U, snc4chunks=snc4set ) + + ! !!! nid_V : 3D + CALL histdef( nid_V, "vomecrty", "Meridional Current" , "m/s" , & ! vv(:,:,:,Kmm) + & jpi, jpj, nh_V, ipk, 1, ipk, nz_V, 32, clop, zsto, zout ) + IF( ln_wave .AND. ln_sdw) THEN + CALL histdef( nid_V, "sdmecrty", "Stokes Drift Meridional Current" , "m/s" , & ! vsd + & jpi, jpj, nh_V, ipk, 1, ipk, nz_V, 32, clop, zsto, zout ) + ENDIF + ! !!! nid_V : 2D + CALL histdef( nid_V, "sometauy", "Wind Stress along j-axis" , "N/m2" , & ! vtau + & jpi, jpj, nh_V, 1 , 1, 1 , - 99, 32, clop, zsto, zout ) + + CALL histend( nid_V, snc4chunks=snc4set ) + + ! !!! nid_W : 3D + CALL histdef( nid_W, "vovecrtz", "Vertical Velocity" , "m/s" , & ! ww + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + CALL histdef( nid_W, "votkeavt", "Vertical Eddy Diffusivity" , "m2/s" , & ! avt + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + CALL histdef( nid_W, "votkeavm", "Vertical Eddy Viscosity" , "m2/s" , & ! avm + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + + IF( ln_zdfddm ) THEN + CALL histdef( nid_W,"voddmavs","Salt Vertical Eddy Diffusivity" , "m2/s" , & ! avs + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + ENDIF + + IF( ln_wave .AND. ln_sdw) THEN + CALL histdef( nid_W, "sdvecrtz", "Stokes Drift Vertical Current" , "m/s" , & ! wsd + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + ENDIF + ! !!! nid_W : 2D + CALL histend( nid_W, snc4chunks=snc4set ) + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'End of NetCDF Initialization' + IF(ll_print) CALL FLUSH(numout ) + + ENDIF + + ! 2. Start writing data + ! --------------------- + + ! ndex(1) est utilise ssi l'avant dernier argument est different de + ! la taille du tableau en sortie. Dans ce cas , l'avant dernier argument + ! donne le nombre d'elements, et ndex la liste des indices a sortir + + IF( lwp .AND. MOD( itmod, nn_write ) == 0 ) THEN + WRITE(numout,*) 'dia_wri : write model outputs in NetCDF files at ', kt, 'time-step' + WRITE(numout,*) '~~~~~~ ' + ENDIF + + IF( .NOT.ln_linssh ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = ts(ji,jj,jk,jp_tem,Kmm) * e3t(ji,jj,jk,Kmm) + END_3D + CALL histwrite( nid_T, "votemper", it, z3d, ndim_T , ndex_T ) ! heat content + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = ts(ji,jj,jk,jp_sal,Kmm) * e3t(ji,jj,jk,Kmm) + END_3D + CALL histwrite( nid_T, "vosaline", it, z3d, ndim_T , ndex_T ) ! salt content + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj ) = ts(ji,jj, 1,jp_tem,Kmm) * e3t(ji,jj, 1,Kmm) + END_2D + CALL histwrite( nid_T, "sosstsst", it, z2d, ndim_hT, ndex_hT ) ! sea surface heat content + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj ) = ts(ji,jj, 1,jp_sal,Kmm) * e3t(ji,jj, 1,Kmm) + END_2D + CALL histwrite( nid_T, "sosaline", it, z2d, ndim_hT, ndex_hT ) ! sea surface salinity content + ELSE + CALL histwrite( nid_T, "votemper", it, ts(:,:,:,jp_tem,Kmm) , ndim_T , ndex_T ) ! temperature + CALL histwrite( nid_T, "vosaline", it, ts(:,:,:,jp_sal,Kmm) , ndim_T , ndex_T ) ! salinity + CALL histwrite( nid_T, "sosstsst", it, ts(:,:,1,jp_tem,Kmm) , ndim_hT, ndex_hT ) ! sea surface temperature + CALL histwrite( nid_T, "sosaline", it, ts(:,:,1,jp_sal,Kmm) , ndim_hT, ndex_hT ) ! sea surface salinity + ENDIF + IF( .NOT.ln_linssh ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = e3t(ji,jj,jk,Kmm) ! 3D workspace for qco substitution + END_3D + CALL histwrite( nid_T, "vovvle3t", it, z3d , ndim_T , ndex_T ) ! level thickness + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = gdept(ji,jj,jk,Kmm) ! 3D workspace for qco substitution + END_3D + CALL histwrite( nid_T, "vovvldep", it, z3d , ndim_T , ndex_T ) ! t-point depth + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = ( ( e3t(ji,jj,jk,Kmm) - e3t_0(ji,jj,jk) ) / e3t_0(ji,jj,jk) * 100._wp * tmask(ji,jj,jk) ) ** 2 + END_3D + CALL histwrite( nid_T, "vovvldef", it, z3d , ndim_T , ndex_T ) ! level thickness deformation + ENDIF + CALL histwrite( nid_T, "sossheig", it, ssh(:,:,Kmm) , ndim_hT, ndex_hT ) ! sea surface height + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = emp(ji,jj) - rnf(ji,jj) + END_2D + CALL histwrite( nid_T, "sowaflup", it, z2d , ndim_hT, ndex_hT ) ! upward water flux + CALL histwrite( nid_T, "sorunoff", it, rnf , ndim_hT, ndex_hT ) ! river runoffs + CALL histwrite( nid_T, "sosfldow", it, sfx , ndim_hT, ndex_hT ) ! downward salt flux + ! (includes virtual salt flux beneath ice + ! in linear free surface case) + IF( ln_linssh ) THEN + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = emp (ji,jj) * ts(ji,jj,1,jp_tem,Kmm) + END_2D + CALL histwrite( nid_T, "sosst_cd", it, z2d, ndim_hT, ndex_hT ) ! c/d term on sst + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = emp (ji,jj) * ts(ji,jj,1,jp_sal,Kmm) + END_2D + CALL histwrite( nid_T, "sosss_cd", it, z2d, ndim_hT, ndex_hT ) ! c/d term on sss + ENDIF + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = qsr(ji,jj) + qns(ji,jj) + END_2D + CALL histwrite( nid_T, "sohefldo", it, z2d , ndim_hT, ndex_hT ) ! total heat flux + CALL histwrite( nid_T, "soshfldo", it, qsr , ndim_hT, ndex_hT ) ! solar heat flux + IF( ALLOCATED(hmld) ) THEN ! zdf_mxl not called by SWE + CALL histwrite( nid_T, "somixhgt", it, hmld , ndim_hT, ndex_hT ) ! turbocline depth + CALL histwrite( nid_T, "somxl010", it, hmlp , ndim_hT, ndex_hT ) ! mixed layer depth + ENDIF + CALL histwrite( nid_T, "soicecov", it, fr_i , ndim_hT, ndex_hT ) ! ice fraction + CALL histwrite( nid_T, "sowindsp", it, wndm , ndim_hT, ndex_hT ) ! wind speed + ! + IF( ln_abl ) THEN + ALLOCATE( zw3d_abl(jpi,jpj,jpka) ) + IF( ln_mskland ) THEN + DO jk=1,jpka + zw3d_abl(:,:,jk) = tmask(:,:,1) + END DO + ELSE + zw3d_abl(:,:,:) = 1._wp + ENDIF + CALL histwrite( nid_A, "pblh" , it, pblh(:,:) *zw3d_abl(:,:,1 ), ndim_hA, ndex_hA ) ! pblh + CALL histwrite( nid_A, "u_abl" , it, u_abl (:,:,2:jpka,nt_n )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! u_abl + CALL histwrite( nid_A, "v_abl" , it, v_abl (:,:,2:jpka,nt_n )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! v_abl + CALL histwrite( nid_A, "t_abl" , it, tq_abl (:,:,2:jpka,nt_n,1)*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! t_abl + CALL histwrite( nid_A, "q_abl" , it, tq_abl (:,:,2:jpka,nt_n,2)*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! q_abl + CALL histwrite( nid_A, "tke_abl", it, tke_abl (:,:,2:jpka,nt_n )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! tke_abl + CALL histwrite( nid_A, "avm_abl", it, avm_abl (:,:,2:jpka )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! avm_abl + CALL histwrite( nid_A, "avt_abl", it, avt_abl (:,:,2:jpka )*zw3d_abl(:,:,2:jpka), ndim_A , ndex_A ) ! avt_abl +#if defined key_si3 + CALL histwrite( nid_A, "oce_frac" , it, ato_i(:,:) , ndim_hA, ndex_hA ) ! ato_i +#endif + DEALLOCATE(zw3d_abl) + ENDIF + ! + IF( ln_icebergs ) THEN + ! + CALL histwrite( nid_T, "calving" , it, berg_grid%calving , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "calving_heat" , it, berg_grid%calving_hflx , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_floating_melt" , it, berg_grid%floating_melt, ndim_hT, ndex_hT ) + ! + CALL histwrite( nid_T, "berg_stored_ice" , it, berg_grid%stored_ice , ndim_bT, ndex_bT ) + ! + IF( ln_bergdia ) THEN + CALL histwrite( nid_T, "berg_melt" , it, berg_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_buoy_melt" , it, buoy_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_eros_melt" , it, eros_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_conv_melt" , it, conv_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_virtual_area" , it, virtual_area , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "bits_src" , it, bits_src , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "bits_melt" , it, bits_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "bits_mass" , it, bits_mass , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_mass" , it, berg_mass , ndim_hT, ndex_hT ) + ! + CALL histwrite( nid_T, "berg_real_calving" , it, real_calving , ndim_bT, ndex_bT ) + ENDIF + ENDIF + + IF( ln_ssr ) THEN + CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping + CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = erp(ji,jj) * ts(ji,jj,1,jp_sal,Kmm) * tmask(ji,jj,1) + END_2D + CALL histwrite( nid_T, "sosafldp", it, z2d , ndim_hT, ndex_hT ) ! salt flux damping + ENDIF +! zw2d(:,:) = FLOAT( nmln(:,:) ) * tmask(:,:,1) +! CALL histwrite( nid_T, "sobowlin", it, zw2d , ndim_hT, ndex_hT ) ! ??? + +#if defined key_diahth + CALL histwrite( nid_T, "sothedep", it, hth , ndim_hT, ndex_hT ) ! depth of the thermocline + CALL histwrite( nid_T, "so20chgt", it, hd20 , ndim_hT, ndex_hT ) ! depth of the 20 isotherm + CALL histwrite( nid_T, "so28chgt", it, hd28 , ndim_hT, ndex_hT ) ! depth of the 28 isotherm + CALL histwrite( nid_T, "sohtc300", it, htc3 , ndim_hT, ndex_hT ) ! first 300m heaat content +#endif + + CALL histwrite( nid_U, "vozocrtx", it, uu(:,:,:,Kmm) , ndim_U , ndex_U ) ! i-current + CALL histwrite( nid_U, "sozotaux", it, utau , ndim_hU, ndex_hU ) ! i-wind stress + + CALL histwrite( nid_V, "vomecrty", it, vv(:,:,:,Kmm) , ndim_V , ndex_V ) ! j-current + CALL histwrite( nid_V, "sometauy", it, vtau , ndim_hV, ndex_hV ) ! j-wind stress + + IF( ln_zad_Aimp ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = ww(ji,jj,jk) + wi(ji,jj,jk) + END_3D + CALL histwrite( nid_W, "vovecrtz", it, z3d , ndim_T, ndex_T ) ! vert. current + ELSE + CALL histwrite( nid_W, "vovecrtz", it, ww , ndim_T, ndex_T ) ! vert. current + ENDIF + CALL histwrite( nid_W, "votkeavt", it, avt , ndim_T, ndex_T ) ! T vert. eddy diff. coef. + CALL histwrite( nid_W, "votkeavm", it, avm , ndim_T, ndex_T ) ! T vert. eddy visc. coef. + IF( ln_zdfddm ) THEN + CALL histwrite( nid_W, "voddmavs", it, avs , ndim_T, ndex_T ) ! S vert. eddy diff. coef. + ENDIF + + IF( ln_wave .AND. ln_sdw ) THEN + CALL histwrite( nid_U, "sdzocrtx", it, usd , ndim_U , ndex_U ) ! i-StokesDrift-current + CALL histwrite( nid_V, "sdmecrty", it, vsd , ndim_V , ndex_V ) ! j-StokesDrift-current + CALL histwrite( nid_W, "sdvecrtz", it, wsd , ndim_T , ndex_T ) ! StokesDrift vert. current + ENDIF + + ! 3. Close all files + ! --------------------------------------- + IF( kt == nitend ) THEN + CALL histclo( nid_T ) + CALL histclo( nid_U ) + CALL histclo( nid_V ) + CALL histclo( nid_W ) + IF(ln_abl) CALL histclo( nid_A ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('dia_wri') + ! + END SUBROUTINE dia_wri +#endif + + SUBROUTINE dia_wri_state( Kmm, cdfile_name ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dia_wri_state *** + !! + !! ** Purpose : create a NetCDF file named cdfile_name which contains + !! the instantaneous ocean state and forcing fields. + !! Used to find errors in the initial state or save the last + !! ocean state in case of abnormal end of a simulation + !! + !! ** Method : NetCDF files using ioipsl + !! File 'output.init.nc' is created if ninist = 1 (namelist) + !! File 'output.abort.nc' is created in case of abnormal job end + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: Kmm ! time level index + CHARACTER (len=* ), INTENT( in ) :: cdfile_name ! name of the file created + !! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: inum + REAL(wp), DIMENSION(jpi,jpj) :: z2d + REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dia_wri_state : single instantaneous ocean state' + WRITE(numout,*) '~~~~~~~~~~~~~ and forcing fields file created ' + WRITE(numout,*) ' and named :', cdfile_name, '...nc' + ENDIF + ! + CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. ) + ! + CALL iom_rstput( 0, 0, inum, 'votemper', ts(:,:,:,jp_tem,Kmm) ) ! now temperature + CALL iom_rstput( 0, 0, inum, 'vosaline', ts(:,:,:,jp_sal,Kmm) ) ! now salinity + CALL iom_rstput( 0, 0, inum, 'sossheig', ssh(:,:,Kmm) ) ! sea surface height + CALL iom_rstput( 0, 0, inum, 'vozocrtx', uu(:,:,:,Kmm) ) ! now i-velocity + CALL iom_rstput( 0, 0, inum, 'vomecrty', vv(:,:,:,Kmm) ) ! now j-velocity + IF( ln_zad_Aimp ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = ww(ji,jj,jk) + wi(ji,jj,jk) + END_3D + CALL iom_rstput( 0, 0, inum, 'vovecrtz', z3d ) ! now k-velocity + ELSE + CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww ) ! now k-velocity + ENDIF + CALL iom_rstput( 0, 0, inum, 'risfdep', risfdep ) + CALL iom_rstput( 0, 0, inum, 'ht' , ht(:,:) ) ! now water column height + ! + IF ( ln_isf ) THEN + IF (ln_isfcav_mlt) THEN + CALL iom_rstput( 0, 0, inum, 'fwfisf_cav', fwfisf_cav ) + CALL iom_rstput( 0, 0, inum, 'rhisf_cav_tbl', rhisf_tbl_cav ) + CALL iom_rstput( 0, 0, inum, 'rfrac_cav_tbl', rfrac_tbl_cav ) + CALL iom_rstput( 0, 0, inum, 'misfkb_cav', REAL(misfkb_cav,wp) ) + CALL iom_rstput( 0, 0, inum, 'misfkt_cav', REAL(misfkt_cav,wp) ) + CALL iom_rstput( 0, 0, inum, 'mskisf_cav', REAL(mskisf_cav,wp), ktype = jp_i1 ) + END IF + IF (ln_isfpar_mlt) THEN + CALL iom_rstput( 0, 0, inum, 'isfmsk_par', REAL(mskisf_par,wp) ) + CALL iom_rstput( 0, 0, inum, 'fwfisf_par', fwfisf_par ) + CALL iom_rstput( 0, 0, inum, 'rhisf_par_tbl', rhisf_tbl_par ) + CALL iom_rstput( 0, 0, inum, 'rfrac_par_tbl', rfrac_tbl_par ) + CALL iom_rstput( 0, 0, inum, 'misfkb_par', REAL(misfkb_par,wp) ) + CALL iom_rstput( 0, 0, inum, 'misfkt_par', REAL(misfkt_par,wp) ) + CALL iom_rstput( 0, 0, inum, 'mskisf_par', REAL(mskisf_par,wp), ktype = jp_i1 ) + END IF + END IF + ! + IF( ALLOCATED(ahtu) ) THEN + CALL iom_rstput( 0, 0, inum, 'ahtu', ahtu ) ! aht at u-point + CALL iom_rstput( 0, 0, inum, 'ahtv', ahtv ) ! aht at v-point + ENDIF + IF( ALLOCATED(ahmt) ) THEN + CALL iom_rstput( 0, 0, inum, 'ahmt', ahmt ) ! ahmt at u-point + CALL iom_rstput( 0, 0, inum, 'ahmf', ahmf ) ! ahmf at v-point + ENDIF + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = emp(ji,jj) - rnf(ji,jj) + END_2D + CALL iom_rstput( 0, 0, inum, 'sowaflup', z2d ) ! freshwater budget + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = qsr(ji,jj) + qns(ji,jj) + END_2D + CALL iom_rstput( 0, 0, inum, 'sohefldo', z2d ) ! total heat flux + CALL iom_rstput( 0, 0, inum, 'soshfldo', qsr ) ! solar heat flux + CALL iom_rstput( 0, 0, inum, 'soicecov', fr_i ) ! ice fraction + CALL iom_rstput( 0, 0, inum, 'sozotaux', utau ) ! i-wind stress + CALL iom_rstput( 0, 0, inum, 'sometauy', vtau ) ! j-wind stress + IF( .NOT.ln_linssh ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = gdept(ji,jj,jk,Kmm) ! 3D workspace for qco substitution + END_3D + CALL iom_rstput( 0, 0, inum, 'vovvldep', z3d ) ! T-cell depth + DO_3D( 0, 0, 0, 0, 1, jpk ) + z3d(ji,jj,jk) = e3t(ji,jj,jk,Kmm) ! 3D workspace for qco substitution + END_3D + CALL iom_rstput( 0, 0, inum, 'vovvle3t', z3d ) ! T-cell thickness + END IF + IF( ln_wave .AND. ln_sdw ) THEN + CALL iom_rstput( 0, 0, inum, 'sdzocrtx', usd ) ! now StokesDrift i-velocity + CALL iom_rstput( 0, 0, inum, 'sdmecrty', vsd ) ! now StokesDrift j-velocity + CALL iom_rstput( 0, 0, inum, 'sdvecrtz', wsd ) ! now StokesDrift k-velocity + ENDIF + IF ( ln_abl ) THEN + CALL iom_rstput ( 0, 0, inum, "uz1_abl", u_abl(:,:,2,nt_a ) ) ! now first level i-wind + CALL iom_rstput ( 0, 0, inum, "vz1_abl", v_abl(:,:,2,nt_a ) ) ! now first level j-wind + CALL iom_rstput ( 0, 0, inum, "tz1_abl", tq_abl(:,:,2,nt_a,1) ) ! now first level temperature + CALL iom_rstput ( 0, 0, inum, "qz1_abl", tq_abl(:,:,2,nt_a,2) ) ! now first level humidity + ENDIF + IF( ln_zdfosm ) THEN + CALL iom_rstput( 0, 0, inum, 'hbl', hbl*tmask(:,:,1) ) ! now boundary-layer depth + CALL iom_rstput( 0, 0, inum, 'hml', hml*tmask(:,:,1) ) ! now mixed-layer depth + CALL iom_rstput( 0, 0, inum, 'avt_k', avt_k*wmask ) ! w-level diffusion + CALL iom_rstput( 0, 0, inum, 'avm_k', avm_k*wmask ) ! now w-level viscosity + CALL iom_rstput( 0, 0, inum, 'ghamt', ghamt*wmask ) ! non-local t forcing + CALL iom_rstput( 0, 0, inum, 'ghams', ghams*wmask ) ! non-local s forcing + CALL iom_rstput( 0, 0, inum, 'ghamu', ghamu*umask ) ! non-local u forcing + CALL iom_rstput( 0, 0, inum, 'ghamv', ghamv*vmask ) ! non-local v forcing + IF( ln_osm_mle ) THEN + CALL iom_rstput( 0, 0, inum, 'hmle', hmle*tmask(:,:,1) ) ! now transition-layer depth + END IF + ENDIF + ! + CALL iom_close( inum ) + ! +#if defined key_si3 + IF( nn_ice == 2 ) THEN ! condition needed in case agrif + ice-model but no-ice in child grid + CALL iom_open( TRIM(cdfile_name)//'_ice', inum, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) + CALL ice_wri_state( inum ) + CALL iom_close( inum ) + ENDIF + ! +#endif + END SUBROUTINE dia_wri_state + + !!====================================================================== +END MODULE diawri \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/diu_bulk.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/diu_bulk.F90 new file mode 100644 index 0000000..b578c50 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/diu_bulk.F90 @@ -0,0 +1,262 @@ +MODULE diu_bulk + !!====================================================================== + !! *** MODULE diu_bulk *** + !! Takaya model of diurnal warming (Takaya, 2010) + !!===================================================================== + !! History : ! 11-10 (J. While) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! diurnal_sst_bulk_init : initialise diurnal model + !! diurnal_sst_bulk_step : time-step the diurnal model + !!---------------------------------------------------------------------- + USE par_kind + USE phycst + USE dom_oce + USE lib_mpp + USE solfrac_mod + USE in_out_manager + + IMPLICIT NONE + PRIVATE + + ! Namelist parameters + LOGICAL, PUBLIC :: ln_diurnal = .false. ! force definition if diurnal_sst_bulk_init is not called + LOGICAL, PUBLIC :: ln_diurnal_only = .false. ! force definition if diurnal_sst_bulk_init is not called + + ! Parameters + REAL(wp), PRIVATE, PARAMETER :: pp_alpha = 2.0e-4_wp + REAL(wp), PRIVATE, PARAMETER :: pp_veltol = 0._wp + REAL(wp), PRIVATE, PARAMETER :: pp_min_fvel = 1.e-10_wp + + ! Key variables + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_dsst ! Delta SST + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_solfrac ! Fraction of + ! ! absorbed radiation + + PUBLIC diurnal_sst_bulk_init, diurnal_sst_takaya_step + !! * Substitutions +# include "do_loop_substitute.h90" + + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE diurnal_sst_bulk_init + !!---------------------------------------------------------------------- + !! *** ROUTINE diurnal_sst_init *** + !! + !! ** Purpose : Initialise the Takaya diurnal model + !!---------------------------------------------------------------------- + INTEGER :: ios ! local integer + !! + NAMELIST /namdiu/ ln_diurnal, ln_diurnal_only + !!---------------------------------------------------------------------- + + ! Read the namelist + READ ( numnam_ref, namdiu, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdiu in reference namelist' ) + READ ( numnam_cfg, namdiu, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdiu in configuration namelist' ) + ! + IF( ln_diurnal_only .AND. ( .NOT. ln_diurnal ) ) THEN + CALL ctl_stop( "ln_diurnal_only set, but ln_diurnal = FALSE !" ) + ENDIF + + IF( ln_diurnal ) THEN + ! + ALLOCATE( x_dsst(jpi,jpj), x_solfrac(jpi,jpj) ) + ! + x_solfrac = 0._wp ! Initialise the solar fraction + x_dsst = 0._wp + ! + IF( ln_diurnal_only ) THEN + CALL ctl_warn( "ln_diurnal_only set; only the diurnal component of SST will be calculated" ) + ENDIF + ENDIF + + END SUBROUTINE diurnal_sst_bulk_init + + + SUBROUTINE diurnal_sst_takaya_step(kt, psolflux, pqflux, ptauflux, prho, p_rdt, & + & pla, pthick, pcoolthick, pmu, & + & p_fvel_bkginc, p_hflux_bkginc) + !!---------------------------------------------------------------------- + !! *** ROUTINE diurnal_sst_takaya_step *** + !! + !! ** Purpose : Time-step the Takaya diurnal model + !! + !! ** Method : 1) Calculate the Obukhov length + !! 2) Calculate the Similarity function + !! 2) Calculate the increment to dsst + !! 3) Apply the increment + !! ** Reference : Refinements to a prognostic scheme of skin sea surface + !! temperature, Takaya et al, JGR, 2010 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! time step + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: psolflux ! solar flux (Watts) + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: pqflux ! heat (non-solar) flux (Watts) + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: ptauflux ! wind stress (kg/ m s^2) + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in) :: prho ! water density (kg/m^3) + REAL(wp) , INTENT(in) :: p_rdt ! time-step + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pla ! Langmuir number + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pthick ! warm layer thickness (m) + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pcoolthick ! cool skin thickness (m) + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pmu ! mu parameter + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: p_hflux_bkginc ! increment to the heat flux + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: p_fvel_bkginc ! increment to the friction velocity + ! + INTEGER :: ji,jj + LOGICAL :: ll_calcfrac + REAL(wp), DIMENSION(jpi,jpj) :: z_fvel ! friction velocity + REAL(wp), DIMENSION(jpi,jpj) :: zthick, zcoolthick, zmu, zla + REAL(wp), DIMENSION(jpi,jpj) :: z_abflux ! absorbed flux + REAL(wp), DIMENSION(jpi,jpj) :: z_fla ! Langmuir function value + !!---------------------------------------------------------------------- + + ! Set optional arguments to their defaults + IF( .NOT. PRESENT( pthick ) ) THEN ; zthick(:,:) = 3._wp + ELSE ; zthick(:,:) = pthick(:,:) + ENDIF + IF( .NOT. PRESENT(pcoolthick) ) THEN ; zcoolthick(:,:) = 0._wp + ELSE ; zcoolthick(:,:) = pcoolthick(:,:) + ENDIF + IF( .NOT. PRESENT( pmu ) ) THEN ; zmu(:,:) = 0.3_wp + ELSE ; zmu(:,:) = pmu(:,:) + ENDIF + IF( .NOT. PRESENT(pla) ) THEN ; zla(:,:) = 0.3_wp + ELSE ; zla(:,:) = pla(:,:) + ENDIF + + ! If not done already, calculate the solar fraction + IF ( kt==nit000 ) THEN + DO_2D( 1, 1, 1, 1 ) + IF( ( x_solfrac(ji,jj) == 0._wp ) .AND. ( tmask(ji,jj,1) == 1._wp ) ) & + & x_solfrac(ji,jj) = solfrac( zcoolthick(ji,jj),zthick(ji,jj) ) + END_2D + ENDIF + + ! convert solar flux and heat flux to absorbed flux + WHERE ( tmask(:,:,1) == 1._wp) + z_abflux(:,:) = ( x_solfrac(:,:) * psolflux (:,:)) + pqflux(:,:) + ELSEWHERE + z_abflux(:,:) = 0._wp + ENDWHERE + IF( PRESENT(p_hflux_bkginc) ) z_abflux(:,:) = z_abflux(:,:) + p_hflux_bkginc ! Optional increment + WHERE ( ABS( z_abflux(:,:) ) < rsmall ) + z_abflux(:,:) = rsmall + ENDWHERE + + ! Calculate the friction velocity + WHERE ( (ptauflux /= 0) .AND. ( tmask(:,:,1) == 1.) ) + z_fvel(:,:) = SQRT( ptauflux(:,:) / prho(:,:) ) + ELSEWHERE + z_fvel(:,:) = 0._wp + ENDWHERE + IF( PRESENT(p_fvel_bkginc) ) z_fvel(:,:) = z_fvel(:,:) + p_fvel_bkginc ! Optional increment + + + + ! Calculate the Langmuir function value + WHERE ( tmask(:,:,1) == 1.) + z_fla(:,:) = MAX( 1._wp, zla(:,:)**( -2._wp / 3._wp ) ) + ELSEWHERE + z_fla(:,:) = 0._wp + ENDWHERE + + ! Increment the temperature using the implicit solution + x_dsst(:,:) = t_imp( x_dsst(:,:), p_rdt, z_abflux(:,:), z_fvel(:,:), & + & z_fla(:,:), zmu(:,:), zthick(:,:), prho(:,:) ) + ! + END SUBROUTINE diurnal_sst_takaya_step + + + FUNCTION t_imp(p_dsst, p_rdt, p_abflux, p_fvel, & + p_fla, pmu, pthick, prho ) + + IMPLICIT NONE + + ! Function definition + REAL(wp), DIMENSION(jpi,jpj) :: t_imp + ! Dummy variables + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_dsst ! Delta SST + REAL(wp), INTENT(IN) :: p_rdt ! Time-step + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_abflux ! Heat forcing + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_fvel ! Friction velocity + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: p_fla ! Langmuir number + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: pmu ! Structure parameter + REAL(wp), DIMENSION(jpi,jpj), INTENT(IN) :: pthick ! Layer thickness + REAL(dp), DIMENSION(jpi,jpj), INTENT(IN) :: prho ! Water density + + ! Local variables + REAL(wp) :: z_olength ! Obukhov length + REAL(wp) :: z_sigma, z_sigma2 + REAL(wp) :: z_term1, z_term2 + REAL(wp) :: z_stabfunc ! stability function value + REAL(wp) :: z_fvel + + CHARACTER(200) :: warn_string + + INTEGER :: ji,jj + + DO_2D( 1, 1, 1, 1 ) + + ! Only calculate outside tmask + IF ( tmask(ji,jj,1) /= 1._wp ) THEN + t_imp(ji,jj) = 0._wp + CYCLE + END IF + + IF (p_fvel(ji,jj) < pp_min_fvel) THEN + z_fvel = pp_min_fvel + WRITE(warn_string,*) "diurnal_sst_takaya step: "& + &//"friction velocity < minimum\n" & + &//"Setting friction velocity =",pp_min_fvel + CALL ctl_warn(warn_string) + + ELSE + z_fvel = p_fvel(ji,jj) + ENDIF + + ! Calculate the Obukhov length + IF ( (z_fvel < pp_veltol ) .AND. & + & (p_dsst(ji,jj) > 0._wp) ) THEN + z_olength = z_fvel / & + & SQRT( p_dsst(ji,jj) * vkarmn * grav * & + & pp_alpha / ( 5._wp * pthick(ji,jj) ) ) + ELSE + z_olength = & + & ( prho(ji,jj) * rcp * z_fvel**3._wp ) / & + & ( vkarmn * grav * pp_alpha *& + & p_abflux(ji,jj) ) + ENDIF + + ! Calculate the stability function + z_sigma = pthick(ji,jj) / z_olength + z_sigma2 = z_sigma * z_sigma + IF ( z_sigma >= 0. ) THEN + z_stabfunc = 1._wp + & + & ( ( 5._wp * z_sigma + 4._wp * z_sigma2 ) / & + & ( 1._wp + 3._wp * z_sigma + 0.25_wp * & + & z_sigma2 ) ) + ELSE + z_stabfunc = 1._wp / & + & SQRT( 1._wp - 16._wp * z_sigma ) + ENDIF + + ! Calculate the T increment + z_term1 = ( p_abflux(ji,jj) * ( pmu(ji,jj) + 1._wp) / & + & ( pmu(ji,jj) * pthick(ji,jj) * prho(ji,jj) * rcp ) ) + + + z_term2 = -( ( pmu(ji,jj) + 1._wp) * & + & ( vkarmn * z_fvel * p_fla(ji,jj) ) / & + & ( pthick(ji,jj) * z_stabfunc ) ) + + t_imp(ji,jj) = ( p_dsst(ji,jj) + p_rdt * z_term1 ) / & + ( 1._wp - p_rdt * z_term2 ) + + END_2D + + END FUNCTION t_imp + +END MODULE diu_bulk \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/diu_coolskin.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/diu_coolskin.F90 new file mode 100644 index 0000000..e0d30c8 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/diu_coolskin.F90 @@ -0,0 +1,143 @@ +MODULE diu_coolskin + !!====================================================================== + !! *** MODULE diu_coolskin *** + !! Cool skin thickness and delta T correction using Artele et al. (2002) + !! [see also Tu and Tsuang (2005)] + !! + !!===================================================================== + !! History : ! 2012-01 (P. Sykes) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! diurnal_sst_coolskin_init : initialisation of the cool skin + !! diurnal_sst_coolskin_step : time-stepping of the cool skin corrections + !!---------------------------------------------------------------------- + USE par_kind + USE phycst + USE dom_oce + USE in_out_manager + USE sbc_oce + USE lib_mpp + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + ! Namelist parameters + + ! Parameters + REAL(wp), PRIVATE, PARAMETER :: pp_k = 0.596_wp ! Thermal conductivity of seawater + REAL(wp), PRIVATE, PARAMETER :: pp_v = 1.05e-6_wp ! Kinematic viscosity of seawater + REAL(wp), PRIVATE, PARAMETER :: pp_C = 86400 ! seconds [see Tu and Tsuang (2005)] + REAL(wp), PRIVATE, PARAMETER :: pp_cw = 3993._wp ! specific heat capacity of seawater + REAL(wp), PRIVATE, PARAMETER :: pp_h = 10._wp ! reference depth [using 10m from Artale et al. (2002)] + REAL(wp), PRIVATE, PARAMETER :: pp_rhoa = 1.20421_wp ! density of air (at 20C) + REAL(wp), PRIVATE, PARAMETER :: pp_cda = 1.45e-3_wp ! assumed air-sea drag coefficient for calculating wind speed + + ! Key variables + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_csdsst ! Cool skin delta SST + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: x_csthick ! Cool skin thickness + PUBLIC diurnal_sst_coolskin_step, diurnal_sst_coolskin_init + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diu_coolskin.F90 14072 2020-12-04 07:48:38Z laurent $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + CONTAINS + + SUBROUTINE diurnal_sst_coolskin_init + !!---------------------------------------------------------------------- + !! *** ROUTINE diurnal_sst_coolskin_init *** + !! + !! ** Purpose : initialise the cool skin model + !! + !! ** Method : + !! + !! ** Reference : + !! + !!---------------------------------------------------------------------- + ALLOCATE( x_csdsst(jpi,jpj), x_csthick(jpi,jpj) ) + x_csdsst = 0. + x_csthick = 0. + ! + END SUBROUTINE diurnal_sst_coolskin_init + + + SUBROUTINE diurnal_sst_coolskin_step(psqflux, pstauflux, psrho, pDt) + !!---------------------------------------------------------------------- + !! *** ROUTINE diurnal_sst_takaya_step *** + !! + !! ** Purpose : Time-step the Artale cool skin model + !! + !! ** Method : + !! + !! ** Reference : + !!---------------------------------------------------------------------- + ! Dummy variables + REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: psqflux ! Heat (non-solar)(Watts) + REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: pstauflux ! Wind stress (kg/ m s^2) + REAL(dp), INTENT(IN), DIMENSION(jpi,jpj) :: psrho ! Water density (kg/m^3) + REAL(wp), INTENT(IN) :: pDt ! Time-step + + ! Local variables + REAL(wp), DIMENSION(jpi,jpj) :: z_fv ! Friction velocity + REAL(wp), DIMENSION(jpi,jpj) :: z_gamma ! Dimensionless function of wind speed + REAL(wp), DIMENSION(jpi,jpj) :: z_lamda ! Sauders (dimensionless) proportionality constant + REAL(wp), DIMENSION(jpi,jpj) :: z_wspd ! Wind speed (m/s) + REAL(wp) :: z_ztx ! Temporary u wind stress + REAL(wp) :: z_zty ! Temporary v wind stress + REAL(wp) :: z_zmod ! Temporary total wind stress + + INTEGER :: ji,jj + !!---------------------------------------------------------------------- + ! + IF( .NOT. (ln_blk .OR. ln_abl) ) CALL ctl_stop("diu_coolskin.f90: diurnal flux processing only implemented for bulk forcing") + ! + DO_2D( 1, 1, 1, 1 ) + ! + ! Calcualte wind speed from wind stress and friction velocity + IF( tmask(ji,jj,1) == 1. .AND. pstauflux(ji,jj) /= 0 .AND. psrho(ji,jj) /=0 ) THEN + z_fv(ji,jj) = SQRT( pstauflux(ji,jj) / psrho(ji,jj) ) + z_wspd(ji,jj) = SQRT( pstauflux(ji,jj) / ( pp_cda * pp_rhoa ) ) + ELSE + z_fv(ji,jj) = 0. + z_wspd(ji,jj) = 0. + ENDIF + ! + ! Calculate gamma function which is dependent upon wind speed + IF( tmask(ji,jj,1) == 1. ) THEN + IF( ( z_wspd(ji,jj) <= 7.5 ) ) z_gamma(ji,jj) = ( 0.2 * z_wspd(ji,jj) ) + 0.5 + IF( ( z_wspd(ji,jj) > 7.5 ) .AND. ( z_wspd(ji,jj) < 10. ) ) z_gamma(ji,jj) = ( 1.6 * z_wspd(ji,jj) ) - 10. + IF( ( z_wspd(ji,jj) >= 10. ) ) z_gamma(ji,jj) = 6. + ENDIF + ! + ! Calculate lamda function + IF( tmask(ji,jj,1) == 1. .AND. z_fv(ji,jj) /= 0 ) THEN + z_lamda(ji,jj) = ( z_fv(ji,jj) * pp_k * pp_C ) / ( z_gamma(ji,jj) * psrho(ji,jj) * pp_cw * pp_h * pp_v ) + ELSE + z_lamda(ji,jj) = 0. + ENDIF + ! + ! Calculate the cool skin thickness - only when heat flux is out of the ocean + IF( tmask(ji,jj,1) == 1. .AND. z_fv(ji,jj) /= 0 .AND. psqflux(ji,jj) < 0 ) THEN + x_csthick(ji,jj) = ( z_lamda(ji,jj) * pp_v ) / z_fv(ji,jj) + ELSE + x_csthick(ji,jj) = 0. + ENDIF + ! + ! Calculate the cool skin correction - only when the heat flux is out of the ocean + IF( tmask(ji,jj,1) == 1. .AND. x_csthick(ji,jj) /= 0. .AND. psqflux(ji,jj) < 0. ) THEN + x_csdsst(ji,jj) = ( psqflux(ji,jj) * x_csthick(ji,jj) ) / pp_k + ELSE + x_csdsst(ji,jj) = 0. + ENDIF + ! + END_2D + ! + END SUBROUTINE diurnal_sst_coolskin_step + + !!====================================================================== +END MODULE diu_coolskin \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/diu_layers.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/diu_layers.F90 new file mode 100644 index 0000000..22546ad --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/diu_layers.F90 @@ -0,0 +1,51 @@ +MODULE diu_layers + !!====================================================================== + !! *** MODULE diu_layers ** + !! Apply coolskin and warm layer calculations + !!====================================================================== + !! History : 3.7 ! 2015-11 (J. While) Original code + + USE diu_bulk ! diurnal SST bulk routines (diurnal_sst_takaya routine) + USE diu_coolskin ! diurnal cool skin correction (diurnal_sst_coolskin routine) + USE oce + USE iom + USE sbc_oce + USE sbcmod ! surface boundary condition (sbc routine) + + IMPLICIT NONE + PRIVATE + + PUBLIC diurnal_sst_bulk_init ! called by nemogcm.F90 + PUBLIC diurnal_sst_coolskin_init ! called by nemogcm.F90 + PUBLIC diurnal_layers ! called by step.F90 or step_diu.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: step_diu.F90 10922 2019-05-02 15:10:39Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + CONTAINS + + SUBROUTINE diurnal_layers( kstp ) + INTEGER, INTENT(in) :: kstp ! ocean time-step index + !!---------------------------------------------------------------------- + !! *** ROUTINE diurnal_layers *** + !! + !! ** Purpose : - Apply coolskin and warm layer calculations + !! + !!---------------------------------------------------------------------- + + ! Cool skin + + CALL diurnal_sst_coolskin_step( qns, taum, rhop(:,:,1), rn_Dt) + + CALL iom_put( "sst_wl" , x_dsst ) ! warm layer (write out before update below). + CALL iom_put( "sst_cs" , x_csdsst ) ! cool skin + + ! Diurnal warm layer model + CALL diurnal_sst_takaya_step( kstp, qsr, qns, taum, rhop(:,:,1), rn_Dt) + + END SUBROUTINE diurnal_layers + +END MODULE diu_layers \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/solfrac_mod.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/solfrac_mod.F90 new file mode 100644 index 0000000..3fb80cd --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/solfrac_mod.F90 @@ -0,0 +1,56 @@ +MODULE solfrac_mod + !!====================================================================== + !! *** MODULE solfrac *** + !! POSH representation of solar absorption (Gntermann, 2009) + !!===================================================================== + !! History : ! 11-10 (J. While) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! solfrac : function to calculate the solar fraction + !!---------------------------------------------------------------------- + + USE par_kind + IMPLICIT NONE + + ! Parameters + REAL(wp), PRIVATE, PARAMETER, DIMENSION(9) :: & + & pp_wgt = (/0.2370, 0.36, 0.1790, & + & 0.087, 0.08, 0.025, & + & 0.025, 0.007, 0.0004/) + REAL(wp), PRIVATE, PARAMETER, DIMENSION(9) :: & + & pp_len = (/34.84, 2.266, 0.0315, & + & 0.0055, 8.32e-4, 1.26e-4, & + & 3.13e-4, 7.82e-4, 1.44e-5/) + + PUBLIC solfrac + +CONTAINS + + REAL(dp) FUNCTION solfrac(ptop,pbottom) + !!---------------------------------------------------------------------- + !! *** ROUTINE solfrac *** + !! + !! ** Purpose : Calculate the solar fraction absorbed between two + !! layers + !! + !! ** Reference : POSH a model of diurnal warming, Gentemann et al, + !! JGR, 2009 + !!---------------------------------------------------------------------- + + ! Dummy variabes + REAL(wp), INTENT(IN) :: ptop, pbottom ! Top and bottom of layer + + ! local variables + INTEGER :: jt + + ! Calculate the solar fraction absorbed between the two layers + solfrac = 0._wp + DO jt = 1, 9 + solfrac = solfrac + pp_wgt(jt) * ( exp ( -ptop / pp_len(jt) ) & + & - exp ( -pbottom / pp_len(jt) ) ) + END DO + + END FUNCTION solfrac + +END MODULE solfrac_mod \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/step_diu.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/step_diu.F90 new file mode 100644 index 0000000..afc6c58 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DIU/step_diu.F90 @@ -0,0 +1,82 @@ +MODULE step_diu + !!====================================================================== + !! *** MODULE stp_diu *** + !! Time-stepping of diurnal cycle models + !!====================================================================== + !! History : 3.7 ! 2015-11 (J. While) Original code + + USE diu_layers ! diurnal SST bulk and coolskin routines + USE iom + USE sbc_oce + USE sbcmod ! surface boundary condition (sbc routine) + USE diaobs ! Observation operator + USE oce + USE daymod + USE restart ! ocean restart (rst_wri routine) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC stp_diurnal ! called by nemogcm.F90 or step.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: step_diu.F90 12377 2020-02-12 14:39:06Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + CONTAINS + + SUBROUTINE stp_diurnal( kstp ) + INTEGER, INTENT(in) :: kstp ! ocean time-step index + !!---------------------------------------------------------------------- + !! *** ROUTINE stp_diurnal *** + !! + !! ** Purpose : - Time stepping of diurnal SST model only + !! + !! ** Method : -1- Update forcings and data + !! -2- Update ocean physics + !! -3- Compute the t and s trends + !! -4- Update t and s + !! -5- Compute the momentum trends + !! -6- Update the horizontal velocity + !! -7- Compute the diagnostics variables (rd,N2, div,cur,w) + !! -8- Outputs and diagnostics + !!---------------------------------------------------------------------- + INTEGER :: jk ! dummy loop indices + INTEGER :: indic ! error indicator if < 0 + REAL(wp), DIMENSION(jpi,jpj) :: z_fvel_bkginc, z_hflux_bkginc + INTEGER :: Nbb, Nnn, Naa, Nrhs ! local definitions as placeholders for now + !! --------------------------------------------------------------------- + + IF(ln_diurnal_only) THEN + indic = 0 ! reset to no error condition + IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init) + + CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell iom we are at time step kstp + IF( ln_crs ) THEN + CALL iom_setkt( kstp - nit000 + 1, TRIM(cxios_context)//"_crs" ) ! tell iom we are at time step kstp + ENDIF + + CALL sbc ( kstp, Nbb, Nnn ) ! Sea Boundary Conditions + ENDIF + + call diurnal_layers( kstp ) ! coolskin and warm layer calculations + + IF( ln_diurnal_only ) THEN + ! WILL HAVE TO INCREMENT Nbb and Nnn here in ln_diurnal_only case ! + IF( ln_diaobs ) CALL dia_obs( kstp, Nnn ) ! obs-minus-model (assimilation) diagnostics (call after dynamics update) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Control and restarts + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file + IF( lrst_oce ) CALL rst_write ( kstp, Nbb, Nnn ) ! write output ocean restart file + + IF( ln_timing .AND. kstp == nit000 ) CALL timing_reset + ENDIF + + END SUBROUTINE stp_diurnal + +END MODULE step_diu \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/closea.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/closea.F90 new file mode 100644 index 0000000..58c4518 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/closea.F90 @@ -0,0 +1,263 @@ +MODULE closea + !!====================================================================== + !! *** MODULE closea *** + !! + !! User define : specific treatments associated with closed seas + !!====================================================================== + !! History : 8.2 ! 2000-05 (O. Marti) Original code + !! NEMO 1.0 ! 2002-06 (E. Durand, G. Madec) F90 + !! 3.0 ! 2006-07 (G. Madec) add clo_rnf, clo_ups, clo_bat + !! 3.4 ! 2014-12 (P.G. Fogli) sbc_clo bug fix & mpp reproducibility + !! 4.0 ! 2016-06 (G. Madec) move to usrdef_closea, remove clo_ups + !! 4.0 ! 2017-12 (D. Storkey) new formulation based on masks read from file + !! 4.1 ! 2019-07 (P. Mathiot) update to the new domcfg.nc input file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_clo : read in masks which define closed seas and runoff areas + !! clo_rnf : set close sea outflows as river mouths (see sbcrnf) + !! clo_msk : set to zero a field over closed sea (see domzgr) + !!---------------------------------------------------------------------- + USE in_out_manager ! I/O manager + ! + USE diu_bulk , ONLY: ln_diurnal_only ! used for sanity check + USE iom , ONLY: iom_open, iom_get, iom_close, jpdom_global ! I/O routines + USE lib_fortran , ONLY: glob_sum ! fortran library + USE lib_mpp , ONLY: mpp_max, ctl_nam, ctl_stop ! MPP library + + IMPLICIT NONE + + PRIVATE + + PUBLIC dom_clo ! called by domain module + PUBLIC clo_rnf ! called by sbcrnf module + PUBLIC clo_msk ! called in domzgr module + + LOGICAL, PUBLIC :: ln_maskcs !: logical to mask all closed sea + LOGICAL, PUBLIC :: ln_mask_csundef !: logical to mask all undefined closed sea + LOGICAL, PUBLIC :: ln_clo_rnf !: closed sea treated as runoff (update rnf mask) + + ! WARNING: keep default definitions in the following lines as dom_clo is called only if ln_closea = .true. + LOGICAL, PUBLIC :: l_sbc_clo = .FALSE. !: T => net evap/precip over closed seas spread outover the globe/river mouth + LOGICAL, PUBLIC :: l_clo_rnf = .FALSE. !: T => Some closed seas output freshwater (RNF) to specified runoff points. + + INTEGER, PUBLIC :: ncsg = 0 !: number of closed seas global mappings (inferred from closea_mask_glo field) + INTEGER, PUBLIC :: ncsr = 0 !: number of closed seas rnf mappings (inferred from closea_mask_rnf field) + INTEGER, PUBLIC :: ncse = 0 !: number of closed seas empmr mappings (inferred from closea_mask_emp field) + + INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_opnsea, mask_csundef !: mask defining the open sea and the undefined closed sea + + INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_csglo , mask_csgrpglo !: mask of integers defining closed seas + INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_csrnf , mask_csgrprnf !: mask of integers defining closed seas rnf mappings + INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_csemp , mask_csgrpemp !: mask of integers defining closed seas empmr mappings + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: closea.F90 13558 2020-10-02 15:30:22Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_clo() + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_clo *** + !! + !! ** Purpose : Closed sea domain initialization + !! + !! ** Action : Read mask_cs* fields (if needed) from domain_cfg file and infer + !! number of closed seas for each case (glo, rnf, emp) from mask_cs* field. + !! + !! ** Output : mask_csglo and mask_csgrpglo : integer values defining mappings from closed seas and associated groups to the open ocean for net fluxes. + !! mask_csrnf and mask_csgrprnf : integer values defining mappings from closed seas and associated groups to a runoff area for downwards flux only. + !! mask_csemp and mask_csgrpemp : integer values defining mappings from closed seas and associated groups to a runoff area for net fluxes. + !!---------------------------------------------------------------------- + INTEGER :: ios ! io status + !! + NAMELIST/namclo/ ln_maskcs, ln_mask_csundef, ln_clo_rnf + !!--------------------------------------------------------------------- + !! + READ ( numnam_ref, namclo, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namclo in reference namelist' ) + READ ( numnam_cfg, namclo, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namclo in configuration namelist' ) + IF(lwm) WRITE ( numond, namclo ) + !! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)'dom_clo : read in masks to define closed seas ' + IF(lwp) WRITE(numout,*)'~~~~~~~' + IF(lwp) WRITE(numout,*) + !! + !! check option compatibility + IF( .NOT. ln_read_cfg ) THEN + CALL ctl_stop('Suppression of closed seas does not work with ln_read_cfg = .true. . Set ln_closea = .false. .') + ENDIF + !! + IF( (.NOT. ln_maskcs) .AND. ln_diurnal_only ) THEN + CALL ctl_stop('Special handling of freshwater fluxes over closed seas not compatible with ln_diurnal_only.') + END IF + ! + ! read the closed seas masks (if they exist) from domain_cfg file (if it exists) + ! ------------------------------------------------------------------------------ + ! + ! load mask of open sea + CALL alloc_csmask( mask_opnsea ) + CALL read_csmask( cn_domcfg, 'mask_opensea' , mask_opnsea ) + ! + IF ( ln_maskcs ) THEN + ! closed sea are masked + IF(lwp) WRITE(numout,*)' ln_maskcs = T : all closed seas are masked' + IF(lwp) WRITE(numout,*) + ! no special treatment of closed sea + ! no redistribution of emp unbalance over closed sea into river mouth/open ocean + l_sbc_clo = .false. ; l_clo_rnf = .false. + ELSE + ! redistribution of emp unbalance over closed sea into river mouth/open ocean + IF(lwp) WRITE(numout,*)' ln_maskcs = F : net emp is corrected over defined closed seas' + ! + l_sbc_clo = .true. + ! + ! river mouth from lakes added to rnf mask for special treatment + IF ( ln_clo_rnf) l_clo_rnf = .true. + ! + IF ( ln_mask_csundef) THEN + ! closed sea not defined (ie not in the domcfg namelist used to build the domcfg.nc file) are masked + IF(lwp) WRITE(numout,*)' ln_mask_csundef = T : all undefined closed seas are masked' + ! + CALL alloc_csmask( mask_csundef ) + CALL read_csmask( cn_domcfg, 'mask_csundef', mask_csundef ) + ! revert the mask for masking of undefined closed seas in domzgr + ! (0 over the undefined closed sea and 1 elsewhere) + mask_csundef(:,:) = 1 - mask_csundef(:,:) + END IF + IF(lwp) WRITE(numout,*) + ! + ! allocate source mask for each cases + CALL alloc_csmask( mask_csglo ) + CALL alloc_csmask( mask_csrnf ) + CALL alloc_csmask( mask_csemp ) + ! + ! load source mask of cs for each cases + CALL read_csmask( cn_domcfg, 'mask_csglo', mask_csglo ) + CALL read_csmask( cn_domcfg, 'mask_csrnf', mask_csrnf ) + CALL read_csmask( cn_domcfg, 'mask_csemp', mask_csemp ) + ! + ! compute number of cs for each cases + ncsg = MAXVAL( mask_csglo(:,:) ) ; CALL mpp_max( 'closea', ncsg ) + ncsr = MAXVAL( mask_csrnf(:,:) ) ; CALL mpp_max( 'closea', ncsr ) + ncse = MAXVAL( mask_csemp(:,:) ) ; CALL mpp_max( 'closea', ncse ) + ! + ! allocate closed sea group masks + !(used to defined the target area in case multiple lakes have the same river mouth (great lakes for example)) + CALL alloc_csmask( mask_csgrpglo ) + CALL alloc_csmask( mask_csgrprnf ) + CALL alloc_csmask( mask_csgrpemp ) + + ! load mask of cs group for each cases + CALL read_csmask( cn_domcfg, 'mask_csgrpglo', mask_csgrpglo ) + CALL read_csmask( cn_domcfg, 'mask_csgrprnf', mask_csgrprnf ) + CALL read_csmask( cn_domcfg, 'mask_csgrpemp', mask_csgrpemp ) + ! + END IF + END SUBROUTINE dom_clo + + SUBROUTINE clo_rnf( p_rnfmsk ) + !!--------------------------------------------------------------------- + !! *** ROUTINE clo_rnf *** + !! + !! ** Purpose : allow the treatment of closed sea outflow grid-points + !! to be the same as river mouth grid-points + !! + !! ** Method : set to 1 the runoff mask (mskrnf, see sbcrnf module) + !! at the closed sea outflow grid-point. + !! + !! ** Action : update (p_)mskrnf (set 1 at closed sea outflow) + !!---------------------------------------------------------------------- + !! subroutine parameter + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: p_rnfmsk ! river runoff mask (rnfmsk array) + !! + !! local variables + REAL(wp), DIMENSION(jpi,jpj) :: zmsk + !!---------------------------------------------------------------------- + ! + ! zmsk > 0 where cs river mouth defined (case rnf and emp) + zmsk(:,:) = ( mask_csgrprnf (:,:) + mask_csgrpemp(:,:) ) * mask_opnsea(:,:) + WHERE( zmsk(:,:) > 0 ) + p_rnfmsk(:,:) = 1.0_wp + END WHERE + ! + END SUBROUTINE clo_rnf + + SUBROUTINE clo_msk( k_top, k_bot, k_mask, cd_prt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE clo_msk *** + !! + !! ** Purpose : Suppress closed sea from the domain + !! + !! ** Method : Where closea_mask > 0 set first and last ocean level to 0 + !! (As currently coded you can't define a closea_mask field in + !! usr_def_zgr). + !! + !! ** Action : set k_top=0 and k_bot=0 over closed seas + !!---------------------------------------------------------------------- + !! subroutine parameter + INTEGER, DIMENSION(:,:), INTENT(inout) :: k_top, k_bot ! ocean first and last level indices + INTEGER, DIMENSION(:,:), INTENT(in ) :: k_mask ! mask used to mask ktop and k_bot + CHARACTER(LEN=*), INTENT(in ) :: cd_prt ! text for control print + !! + !! local variables + !!---------------------------------------------------------------------- + !! + IF ( lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'clo_msk : Suppression closed seas based on ',TRIM(cd_prt),' field.' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) + ENDIF + !! + k_top(:,:) = k_top(:,:) * k_mask(:,:) + k_bot(:,:) = k_bot(:,:) * k_mask(:,:) + !! + END SUBROUTINE clo_msk + + SUBROUTINE read_csmask(cd_file, cd_var, k_mskout) + !!--------------------------------------------------------------------- + !! *** ROUTINE read_csmask *** + !! + !! ** Purpose : read mask in cd_filec file + !!---------------------------------------------------------------------- + ! subroutine parameter + CHARACTER(LEN=256), INTENT(in ) :: cd_file ! netcdf file name + CHARACTER(LEN= * ), INTENT(in ) :: cd_var ! netcdf variable name + INTEGER, DIMENSION(:,:), INTENT( out) :: k_mskout ! output mask variable + ! + ! local variables + INTEGER :: ics ! netcdf id + REAL(wp), DIMENSION(jpi,jpj) :: zdta ! netcdf data + !!---------------------------------------------------------------------- + ! + CALL iom_open ( cd_file, ics ) + CALL iom_get ( ics, jpdom_global, TRIM(cd_var), zdta ) + CALL iom_close( ics ) + k_mskout(:,:) = NINT(zdta(:,:)) + ! + END SUBROUTINE read_csmask + + SUBROUTINE alloc_csmask( kmask ) + !!--------------------------------------------------------------------- + !! *** ROUTINE alloc_csmask *** + !! + !! ** Purpose : allocated cs mask + !!---------------------------------------------------------------------- + ! subroutine parameter + INTEGER, ALLOCATABLE, DIMENSION(:,:), INTENT(inout) :: kmask + ! + ! local variables + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + ALLOCATE( kmask(jpi,jpj) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'alloc_csmask: failed to allocate surf array') + ! + END SUBROUTINE alloc_csmask + +END MODULE closea \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/daymod.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/daymod.F90 new file mode 100644 index 0000000..39e2db3 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/daymod.F90 @@ -0,0 +1,414 @@ +MODULE daymod + !!====================================================================== + !! *** MODULE daymod *** + !! Ocean : management of the model calendar + !!===================================================================== + !! History : OPA ! 1994-09 (M. Pontaud M. Imbard) Original code + !! ! 1997-03 (O. Marti) + !! ! 1997-05 (G. Madec) + !! ! 1997-08 (M. Imbard) + !! NEMO 1.0 ! 2003-09 (G. Madec) F90 + nyear, nmonth, nday + !! ! 2004-01 (A.M. Treguier) new calculation based on adatrj + !! ! 2006-08 (G. Madec) surface module major update + !! ! 2015-11 (D. Lea) Allow non-zero initial time of day + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! day : calendar + !!---------------------------------------------------------------------- + !! ----------- WARNING ----------- + !! ------------------------------- + !! sbcmod assume that the time step is dividing the number of second of + !! in a day, i.e. ===> MOD( rday, rn_Dt ) == 0 + !! except when user defined forcing is used (see sbcmod.F90) + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE ioipsl , ONLY : ymds2ju ! for calendar + USE trc_oce , ONLY : l_offline ! offline flag + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE iom ! + USE timing ! Timing + USE restart ! restart + + IMPLICIT NONE + PRIVATE + + PUBLIC day ! called by step.F90 + PUBLIC day_init ! called by istate.F90 + PUBLIC day_mth ! Needed by TAM + + INTEGER, PUBLIC :: nsecd, nsecd05, ndt, ndt05 !: (PUBLIC for TAM) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: daymod.F90 14072 2020-12-04 07:48:38Z laurent $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE day_init + !!---------------------------------------------------------------------- + !! *** ROUTINE day_init *** + !! + !! ** Purpose : Initialization of the calendar values to their values 1 time step before nit000 + !! because day will be called at the beginning of step + !! + !! ** Action : - nyear : current year + !! - nmonth : current month of the current nyear + !! - nday : current day of the current nmonth + !! - nday_year : current day of the current nyear + !! - nsec_year : seconds between 00h jan 1st of the current year and half of the current time step + !! - nsec_month : seconds between 00h 1st day of the current month and half of the current time step + !! - nsec_monday : seconds between 00h of the last Monday and half of the current time step + !! - nsec_day : seconds between 00h of the current day and half of the current time step + !! - nsec1jan000 : seconds between Jan. 1st 00h of nit000 year and Jan. 1st 00h of the current year + !! - nmonth_len, nyear_len, nmonth_beg through day_mth + !!---------------------------------------------------------------------- + INTEGER :: inbday, imonday, isecrst ! local integers + REAL(dp) :: zjul ! local scalar + !!---------------------------------------------------------------------- + ! + ! max number of seconds between each restart + IF( REAL( nitend - nit000 + 1 ) * rn_Dt > REAL( HUGE( nsec1jan000 ) ) ) THEN + CALL ctl_stop( 'The number of seconds between each restart exceeds the integer 4 max value: 2^31-1. ', & + & 'You must do a restart at higher frequency (or remove this stop and recompile the code in I8)' ) + ENDIF + nsecd = NINT( rday ) + nsecd05 = NINT( 0.5 * rday ) + ndt = NINT( rn_Dt ) + ndt05 = NINT( 0.5 * rn_Dt ) + + lrst_oce = .NOT. l_offline ! force definition of offline + IF( lrst_oce ) CALL day_rst( nit000, 'READ' ) + + ! set the calandar from ndastp (read in restart file and namelist) + nyear = ndastp / 10000 + nmonth = ( ndastp - (nyear * 10000) ) / 100 + nday = ndastp - (nyear * 10000) - ( nmonth * 100 ) + + nhour = nn_time0 / 100 + nminute = ( nn_time0 - nhour * 100 ) + isecrst = ( nhour * NINT(rhhmm) + nminute ) * NINT(rmmss) + + CALL ymds2ju( nyear, nmonth, nday, REAL(isecrst,dp), fjulday ) + IF( ABS(fjulday - REAL(NINT(fjulday),wp)) < 0.1 / rday ) fjulday = REAL(NINT(fjulday),wp) ! avoid truncation error + IF( nhour*NINT(rhhmm*rmmss) + nminute*NINT(rmmss) - ndt05 .LT. 0 ) fjulday = fjulday+1. ! move back to the day at nit000 (and not at nit000 - 1) + + nsec1jan000 = 0 + CALL day_mth + + IF ( nday == 0 ) THEN ! for ex if ndastp = ndate0 - 1 + nmonth = nmonth - 1 + nday = nmonth_len(nmonth) + ENDIF + IF ( nmonth == 0 ) THEN ! go at the end of previous year + nmonth = 12 + nyear = nyear - 1 + nsec1jan000 = nsec1jan000 - nsecd * nyear_len(0) + IF( nleapy == 1 ) CALL day_mth + ENDIF + + ! day since january 1st + nday_year = nday + SUM( nmonth_len(1:nmonth - 1) ) + + !compute number of days between last Monday and today + CALL ymds2ju( 1900, 01, 01, 0.0_dp, zjul ) ! compute julian day value of 01.01.1900 (our reference that was a Monday) + + inbday = FLOOR(fjulday - zjul) ! compute nb day between 01.01.1900 and start of current day + imonday = MOD(inbday, 7) ! compute nb day between last monday and current day + IF (imonday .LT. 0) imonday = imonday + 7 ! Avoid negative values for dates before 01.01.1900 + + ! number of seconds since the beginning of current year/month/week/day at the middle of the time-step + IF( isecrst - ndt05 .GT. 0 ) THEN + ! 1 timestep before current middle of first time step is still the same day + nsec_year = (nday_year-1) * nsecd + isecrst - ndt05 + nsec_month = (nday-1) * nsecd + isecrst - ndt05 + ELSE + ! 1 time step before the middle of the first time step is the previous day + nsec_year = nday_year * nsecd + isecrst - ndt05 + nsec_month = nday * nsecd + isecrst - ndt05 + ENDIF + nsec_monday = imonday * nsecd + isecrst - ndt05 + nsec_day = isecrst - ndt05 + IF( nsec_day .LT. 0 ) nsec_day = nsec_day + nsecd + IF( nsec_monday .LT. 0 ) nsec_monday = nsec_monday + nsecd*7 + + ! control print + IF(lwp) WRITE(numout,'(a,i6,a,i2,a,i2,a,i8,a,i8,a,i8,a,i8)') & + & ' =======>> 1/2 time step before the start of the run DATE Y/M/D = ', & + & nyear, '/', nmonth, '/', nday, ' nsec_day:', nsec_day, ' nsec_monday:', nsec_monday, ' & + & nsec_month:', nsec_month , ' nsec_year:' , nsec_year + + nsec000_1jan000 = nsec1jan000 + nsec_year + ndt05 + nsecend_1jan000 = nsec000_1jan000 + ndt * ( nitend - nit000 + 1 ) + + ! Up to now, calendar parameters are related to the end of previous run (nit000-1) + ! call day to set the calendar parameters at the begining of the current simulaton. needed by iom_init + CALL day( nit000 ) + ! + END SUBROUTINE day_init + + + SUBROUTINE day_mth + !!---------------------------------------------------------------------- + !! *** ROUTINE day_init *** + !! + !! ** Purpose : calendar values related to the months + !! + !! ** Action : - nyear_len : length in days of the previous/current year + !! - nmonth_len : length in days of the months of the current year + !! - nmonth_half : second since the beginning of the current year and the halft of the months + !! - nmonth_end : second since the beginning of the current year and the end of the months + !!---------------------------------------------------------------------- + INTEGER :: jm ,jy ! dummy loop indice + INTEGER, DIMENSION(12) :: idaymt ! length in days of the 12 months for non-leap year + !!---------------------------------------------------------------------- + + ! length of the month of the current year (from nleapy, read in namelist) + IF ( nleapy < 2 ) THEN + ! default values + idaymt(1:12) = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) + nmonth_len(-11: 25) = (/ idaymt(1:12), idaymt(1:12), idaymt(1:12), idaymt(1) /) + nyear_len(:) = 365 + ! + IF ( nleapy == 1 ) THEN ! we are using calandar with leap years + DO jy = -1,1 + IF ( MOD(nyear+jy, 4) == 0 .AND. ( MOD(nyear+jy, 400) == 0 .OR. MOD(nyear+jy, 100) /= 0 ) ) THEN + nmonth_len(2 + 12*jy) = 29 + nyear_len( 1 + jy) = 366 + ENDIF + ENDDO + ENDIF + ELSE + nmonth_len(:) = nleapy ! all months with nleapy days per year + nyear_len(:) = 12 * nleapy + ENDIF + + ! time since Jan 1st 0 1 2 ... 11 12 13 + ! ---------*--|--*--|--*--| ... |--*--|--*--|--*--|-------------------------------------- + ! <---> <---> <---> ... <---> <---> <---> + ! month number 0 1 2 ... 11 12 13 + nmonth_beg(1) = 0 + DO jm = 2, 25 + nmonth_beg(jm) = nmonth_beg(jm-1) + nsecd * nmonth_len(jm-1) + END DO + DO jm = 0,-11,-1 + nmonth_beg(jm) = nmonth_beg(jm+1) - nsecd * nmonth_len(jm) + END DO + ! + END SUBROUTINE day_mth + + + SUBROUTINE day( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE day *** + !! + !! ** Purpose : Compute the date with a day iteration IF necessary. + !! + !! ** Method : - ??? + !! + !! ** Action : - nyear : current year + !! - nmonth : current month of the year nyear + !! - nday : current day of the month nmonth + !! - nday_year : current day of the year nyear + !! - ndastp : = nyear*10000 + nmonth*100 + nday + !! - adatrj : date in days since the beginning of the run + !! - nsec_year : current time of the year (in second since 00h, jan 1st) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step indices + ! + CHARACTER (len=25) :: charout + REAL(dp) :: zprec ! fraction of day corresponding to 0.1 second + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('day') + ! + zprec = 0.1 / rday + ! ! New time-step + nsec_year = nsec_year + ndt + nsec_month = nsec_month + ndt + nsec_monday = nsec_monday + ndt + nsec_day = nsec_day + ndt + adatrj = adatrj + rn_Dt / rday + fjulday = fjulday + rn_Dt / rday + IF( ABS(fjulday - REAL(NINT(fjulday),wp)) < zprec ) fjulday = REAL(NINT(fjulday),wp) ! avoid truncation error + IF( ABS(adatrj - REAL(NINT(adatrj ),wp)) < zprec ) adatrj = REAL(NINT(adatrj ),wp) ! avoid truncation error + + IF( nsec_day > nsecd ) THEN ! New day + ! + nday = nday + 1 + nday_year = nday_year + 1 + nsec_day = ndt05 + ! + IF( nday == nmonth_len(nmonth) + 1 ) THEN ! New month + nday = 1 + nmonth = nmonth + 1 + nsec_month = ndt05 + IF( nmonth == 13 ) THEN ! New year + nyear = nyear + 1 + nmonth = 1 + nday_year = 1 + nsec_year = ndt05 + nsec1jan000 = nsec1jan000 + nsecd * nyear_len(1) + IF( nleapy == 1 ) CALL day_mth + ENDIF + ENDIF + ! + ndastp = nyear * 10000 + nmonth * 100 + nday ! New date + ! + !compute first day of the year in julian days + CALL ymds2ju( nyear, 01, 01, 0.0_dp, fjulstartyear ) + ! + IF(lwp) WRITE(numout,'(a,i8,a,i4.4,a,i2.2,a,i2.2,a,i3.3)') '======>> time-step =', kt, & + & ' New day, DATE Y/M/D = ', nyear, '/', nmonth, '/', nday, ' nday_year = ', nday_year + IF(lwp) WRITE(numout,'(a,i8,a,i7,a,i5)') ' nsec_year = ', nsec_year, & + & ' nsec_month = ', nsec_month, ' nsec_day = ', nsec_day, ' nsec_monday = ', nsec_monday + ENDIF + + IF( nsec_monday > 7*nsecd ) nsec_monday = ndt05 ! New week + + IF(sn_cfctl%l_prtctl) THEN + WRITE(charout,FMT="('kt =', I4,' d/m/y =',I2,I2,I4)") kt, nday, nmonth, nyear + CALL prt_ctl_info( charout ) + ENDIF + + IF( .NOT. l_offline ) CALL rst_opn( kt ) ! Open the restart file if needed and control lrst_oce + IF( lrst_oce ) CALL day_rst( kt, 'WRITE' ) ! write day restart information + ! + IF( ln_timing ) CALL timing_stop('day') + ! + END SUBROUTINE day + + + SUBROUTINE day_rst( kt, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE day_rst *** + !! + !! ** Purpose : Read or write calendar in restart file: + !! + !! WRITE(READ) mode: + !! kt : number of time step since the begining of the experiment at the + !! end of the current(previous) run + !! adatrj(0) : number of elapsed days since the begining of the experiment at the + !! end of the current(previous) run (REAL -> keep fractions of day) + !! ndastp : date at the end of the current(previous) run (coded as yyyymmdd integer) + !! + !! According to namelist parameter nrstdt, + !! nrstdt = 0 no control on the date (nit000 is arbitrary). + !! nrstdt = 1 we verify that nit000 is equal to the last + !! time step of previous run + 1. + !! In both those options, the exact duration of the experiment + !! since the beginning (cumulated duration of all previous restart runs) + !! is not stored in the restart and is assumed to be (nit000-1)*rn_Dt. + !! This is valid is the time step has remained constant. + !! + !! nrstdt = 2 the duration of the experiment in days (adatrj) + !! has been stored in the restart file. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + ! + REAL(dp) :: zkt, zndastp, zdayfrac, ksecs, ktime + INTEGER :: ihour, iminute, isecond + !!---------------------------------------------------------------------- + + IF( TRIM(cdrw) == 'READ' ) THEN + IF( iom_varid( numror, 'kt', ldstop = .FALSE. ) > 0 ) THEN + ! Get Calendar informations + CALL iom_get( numror, 'kt', zkt ) ! last time-step of previous run + IF(lwp) THEN + WRITE(numout,*) ' *** Info read in restart : ' + WRITE(numout,*) ' previous time-step : ', NINT( zkt ) + WRITE(numout,*) ' *** restart option' + SELECT CASE ( nrstdt ) + CASE ( 0 ) ; WRITE(numout,*) ' nrstdt = 0 : no control of nit000' + CASE ( 1 ) ; WRITE(numout,*) ' nrstdt = 1 : no control the date at nit000 (use ndate0 read in the namelist)' + CASE ( 2 ) ; WRITE(numout,*) ' nrstdt = 2 : calendar parameters read in restart' + END SELECT + WRITE(numout,*) + ENDIF + ! Control of date + IF( nit000 - NINT( zkt ) /= 1 .AND. nrstdt /= 0 ) & + & CALL ctl_stop( ' ===>>>> : problem with nit000 for the restart', & + & ' verify the restart file or rerun with nrstdt = 0 (namelist)' ) + ! define ndastp and adatrj + IF ( nrstdt == 2 ) THEN + ! read the parameters corresponding to nit000 - 1 (last time step of previous run) + CALL iom_get( numror, 'ndastp', zndastp ) + ndastp = NINT( zndastp ) + CALL iom_get( numror, 'adatrj', adatrj ) + CALL iom_get( numror, 'ntime' , ktime ) + nn_time0 = NINT(ktime) + ! calculate start time in hours and minutes + zdayfrac = adatrj - REAL(INT(adatrj), wp) + ksecs = NINT(zdayfrac * rday) ! Nearest second to catch rounding errors in adatrj + ihour = ksecs / NINT( rhhmm*rmmss ) + iminute = ksecs / NINT(rmmss) - ihour*NINT(rhhmm) + + ! Add to nn_time0 + nhour = nn_time0 / 100 + nminute = ( nn_time0 - nhour * 100 ) + nminute = nminute + iminute + + IF( nminute >= NINT(rhhmm) ) THEN + nminute = nminute - NINT(rhhmm) + nhour = nhour+1 + ENDIF + nhour=nhour+ihour + IF( nhour >= NINT(rjjhh) ) THEN + nhour = nhour - NINT(rjjhh) + adatrj = adatrj + 1. + ENDIF + nn_time0 = nhour * 100 + nminute + adatrj = REAL(INT(adatrj), wp) ! adatrj set to integer as nn_time0 updated + ELSE + ! parameters corresponding to nit000 - 1 (as we start the step loop with a call to day) + ndastp = ndate0 ! ndate0 read in the namelist in dom_nam + nhour = nn_time0 / 100 + nminute = ( nn_time0 - nhour * 100 ) + isecond = ( nhour * NINT(rhhmm) + nminute ) * NINT(rmmss) + IF( isecond - ndt05 .lt. 0 ) ndastp = ndastp - 1 ! Start hour is specified in the namelist (default 0) + adatrj = ( REAL( nit000-1, wp ) * rn_Dt ) / rday + ! note this is wrong if time step has changed during run + ENDIF + ELSE + ! parameters corresponding to nit000 - 1 (as we start the step loop with a call to day) + ndastp = ndate0 ! ndate0 read in the namelist in dom_nam + nhour = nn_time0 / 100 + nminute = ( nn_time0 - nhour * 100 ) + isecond = ( nhour * NINT(rhhmm) + nminute ) * NINT(rmmss) + IF( isecond - ndt05 .LT. 0 ) ndastp = ndastp - 1 ! Start hour is specified in the namelist (default 0) + adatrj = ( REAL( nit000-1, wp ) * rn_Dt ) / rday + ENDIF + IF( ABS(adatrj - REAL(NINT(adatrj),wp)) < 0.1 / rday ) adatrj = REAL(NINT(adatrj),wp) ! avoid truncation error + ! + IF(lwp) THEN + WRITE(numout,*) ' *** Info used values : ' + WRITE(numout,*) ' date ndastp : ', ndastp + WRITE(numout,*) ' number of elapsed days since the begining of run : ', adatrj + WRITE(numout,*) ' nn_time0 : ',nn_time0 + WRITE(numout,*) + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN + ! + IF( kt == nitrst ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'rst_write : write oce restart file kt =', kt + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + ! calendar control + CALL iom_rstput( kt, nitrst, numrow, 'kt' , REAL( kt , wp) ) ! time-step + CALL iom_rstput( kt, nitrst, numrow, 'ndastp' , REAL( ndastp, wp) ) ! date + CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj ) ! number of elapsed days since + ! ! the begining of the run [s] + CALL iom_rstput( kt, nitrst, numrow, 'ntime' , REAL( nn_time0, wp) ) ! time + ENDIF + ! + END SUBROUTINE day_rst + + !!====================================================================== +END MODULE daymod diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/depth_e3.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/depth_e3.F90 new file mode 100644 index 0000000..67c4950 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/depth_e3.F90 @@ -0,0 +1,163 @@ +MODULE depth_e3 + !!====================================================================== + !! *** MODULE depth_e3 *** + !! + !! zgr : vertical coordinate system + !!====================================================================== + !! History : 4.0 ! 2016-11 (S. Flavoni, G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! depth_to_e3 : use the depth of t- and w-points to calculate e3t & e3w + !! (generic interface for 1D and 3D fields) + !! e3_to_depth : use e3t & e3w to calculate the depth of t- and w-points + !! (generic interface for 1D and 3D fields) + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce ! ocean domain + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + INTERFACE depth_to_e3 + MODULE PROCEDURE depth_to_e3_1d, depth_to_e3_3d + END INTERFACE + + INTERFACE e3_to_depth + MODULE PROCEDURE e3_to_depth_1d, e3_to_depth_3d + END INTERFACE + + PUBLIC depth_to_e3 ! called by usrdef_zgr + PUBLIC e3_to_depth ! called by domzgr.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: depth_e3.F90 12377 2020-02-12 14:39:06Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE depth_to_e3_1d( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d ) + !!--------------------------------------------------------------------- + !! *** ROUTINE depth_to_e3_1d *** + !! + !! ** Purpose : compute e3t & e3w scale factors from t- & w-depths of model levels + !! + !! ** Method : The scale factors are given by the discrete derivative + !! of the depth: + !! e3w(jk) = dk[ dept_1d ] + !! e3t(jk) = dk[ depw_1d ] + !! with, at top and bottom : + !! e3w( 1 ) = 2 * ( dept( 1 ) - depw( 1 ) ) + !! e3t(jpk) = 2 * ( dept(jpk) - depw(jpk) ) + !! + !! ** Action : - pe3t_1d , pe3w_1d : scale factors at T- and W-levels (m) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:), INTENT(in ) :: pdept_1d, pdepw_1d ! depths [m] + REAL(wp), DIMENSION(:), INTENT( out) :: pe3t_1d , pe3w_1d ! e3.=dk[depth] [m] + ! + INTEGER :: jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + ! use pdep. at w- and t-points to compute e3. (e3. = dk[depth]) + ! + pe3w_1d( 1 ) = 2._wp * ( pdept_1d(1) - pdepw_1d(1) ) + DO jk = 1, jpkm1 + pe3w_1d(jk+1) = pdept_1d(jk+1) - pdept_1d(jk) + pe3t_1d(jk ) = pdepw_1d(jk+1) - pdepw_1d(jk) + END DO + pe3t_1d(jpk) = 2._wp * ( pdept_1d(jpk) - pdepw_1d(jpk) ) + ! + END SUBROUTINE depth_to_e3_1d + + + SUBROUTINE depth_to_e3_3d( pdept_3d, pdepw_3d, pe3t_3d, pe3w_3d ) + !!--------------------------------------------------------------------- + !! *** ROUTINE depth_to_e3_3d *** + !! + !! ** Purpose : compute e3t & e3w scale factors from t- & w-depths of model levels + !! + !! ** Method : The scale factors are given by the discrete derivative + !! of the depth: + !! e3w(jk) = dk[ dept_1d ] + !! e3t(jk) = dk[ depw_1d ] + !! with, at top and bottom : + !! e3w( 1 ) = 2 * ( dept( 1 ) - depw( 1 ) ) + !! e3t(jpk) = 2 * ( dept(jpk) - depw(jpk) ) + !! + !! ** Action : - pe3t_1d , pe3w_1d : scale factors at T- and W-levels (m) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdept_3d, pdepw_3d ! depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pe3t_3d , pe3w_3d ! e3.=dk[depth] [m] + ! + INTEGER :: jk ! dummy loop indices + !!---------------------------------------------------------------------- + pe3w_3d(:,:, 1 ) = 2._wp * ( pdept_3d(:,:,1) - pdepw_3d(:,:,1) ) + DO jk = 1, jpkm1 + pe3w_3d(:,:,jk+1) = pdept_3d(:,:,jk+1) - pdept_3d(:,:,jk) + pe3t_3d(:,:,jk ) = pdepw_3d(:,:,jk+1) - pdepw_3d(:,:,jk) + END DO + pe3t_3d(:,:,jpk) = 2._wp * ( pdept_3d(:,:,jpk) - pdepw_3d(:,:,jpk) ) + ! + END SUBROUTINE depth_to_e3_3d + + + SUBROUTINE e3_to_depth_1d( pe3t_1d, pe3w_1d, pdept_1d, pdepw_1d ) + !!--------------------------------------------------------------------- + !! *** ROUTINE e3_to_depth_1d *** + !! + !! ** Purpose : compute t- & w-depths of model levels from e3t & e3w scale factors + !! + !! ** Method : The t- & w-depth are given by the summation of e3w & e3t, resp. + !! + !! ** Action : - pe3t_1d, pe3w_1d : scale factor of t- and w-point (m) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:), INTENT(in ) :: pe3t_1d , pe3w_1d ! vert. scale factors [m] + REAL(wp), DIMENSION(:), INTENT( out) :: pdept_1d, pdepw_1d ! depth = SUM( e3 ) [m] + ! + INTEGER :: jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + pdepw_1d(1) = 0.0_wp + pdept_1d(1) = 0.5_wp * pe3w_1d(1) + DO jk = 2, jpk + pdepw_1d(jk) = pdepw_1d(jk-1) + pe3t_1d(jk-1) + pdept_1d(jk) = pdept_1d(jk-1) + pe3w_1d(jk ) + END DO + ! + END SUBROUTINE e3_to_depth_1d + + + SUBROUTINE e3_to_depth_3d( pe3t_3d, pe3w_3d, pdept_3d, pdepw_3d ) + !!--------------------------------------------------------------------- + !! *** ROUTINE e3_to_depth_3d *** + !! + !! ** Purpose : compute t- & w-depths of model levels from e3t & e3w scale factors + !! + !! ** Method : The t- & w-depth are given by the summation of e3w & e3t, resp. + !! + !! ** Action : - pe3t_1d, pe3w_1d : scale factor of t- and w-point (m) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pe3w_3d! vert. scale factors [m] + REAL(dp), DIMENSION(:,:,:), INTENT(in ) :: pe3t_3d! vert. scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdept_3d, pdepw_3d ! depth = SUM( e3 ) [m] + ! + INTEGER :: jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + pdepw_3d(:,:,1) = 0.0_wp + pdept_3d(:,:,1) = 0.5_wp * pe3w_3d(:,:,1) + DO jk = 2, jpk + pdepw_3d(:,:,jk) = pdepw_3d(:,:,jk-1) + pe3t_3d(:,:,jk-1) + pdept_3d(:,:,jk) = pdept_3d(:,:,jk-1) + pe3w_3d(:,:,jk ) + END DO + ! + END SUBROUTINE e3_to_depth_3d + + !!====================================================================== +END MODULE depth_e3 \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/dom_oce.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/dom_oce.F90 new file mode 100644 index 0000000..57b4f23 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/dom_oce.F90 @@ -0,0 +1,359 @@ +MODULE dom_oce + !!====================================================================== + !! *** MODULE dom_oce *** + !! ** Purpose : Define in memory all the ocean space domain variables + !!====================================================================== + !! History : 1.0 ! 2005-10 (A. Beckmann, G. Madec) reactivate s-coordinate + !! 3.3 ! 2010-11 (G. Madec) add mbk. arrays associated to the deepest ocean level + !! 3.4 ! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation + !! 3.5 ! 2012 (S. Mocavero, I. Epicoco) Add arrays associated + !! to the optimization of BDY communications + !! 3.7 ! 2015-11 (G. Madec) introduce surface and scale factor ratio + !! - ! 2015-11 (G. Madec, A. Coward) time varying zgr by default + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename prognostic variables in preparation for new time scheme. + !! 4.x ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! Agrif_Root : dummy function used when lk_agrif=F + !! Agrif_Fixed : dummy function used when lk_agrif=F + !! Agrif_CFixed : dummy function used when lk_agrif=F + !! dom_oce_alloc : dynamical allocation of dom_oce arrays + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + + IMPLICIT NONE + PUBLIC ! allows the acces to par_oce when dom_oce is used (exception to coding rules) + + PUBLIC dom_oce_alloc ! Called from nemogcm.F90 + + !!---------------------------------------------------------------------- + !! time & space domain namelist + !! ---------------------------- + ! !!* Namelist namdom : time & space domain * + LOGICAL , PUBLIC :: ln_linssh !: =T linear free surface ==>> model level are fixed in time + LOGICAL , PUBLIC :: ln_meshmask !: =T create a mesh-mask file (mesh_mask.nc) + REAL(wp), PUBLIC :: rn_Dt !: time step for the dynamics and tracer + REAL(wp), PUBLIC :: rn_atfp !: asselin time filter parameter + LOGICAL , PUBLIC :: ln_1st_euler !: =T start with forward time step or not (=F) + LOGICAL , PUBLIC :: ln_crs !: Apply grid coarsening to dynamical model output or online passive tracers + LOGICAL , PUBLIC :: ln_c1d !: =T single column domain (1x1 pt) + + !! Free surface parameters + !! ======================= + LOGICAL , PUBLIC :: ln_dynspg_exp !: Explicit free surface flag + LOGICAL , PUBLIC :: ln_dynspg_ts !: Split-Explicit free surface flag + + !! Time splitting parameters + !! ========================= + LOGICAL, PUBLIC :: ln_bt_fw !: Forward integration of barotropic sub-stepping + LOGICAL, PUBLIC :: ln_bt_av !: Time averaging of barotropic variables + LOGICAL, PUBLIC :: ln_bt_auto !: Set number of barotropic iterations automatically + INTEGER, PUBLIC :: nn_bt_flt !: Filter choice + INTEGER, PUBLIC :: nn_e !: Number of barotropic iterations during one baroclinic step (rn_Dt) + REAL(wp), PUBLIC :: rn_bt_cmax !: Maximum allowed courant number (used if ln_bt_auto=T) + REAL(wp), PUBLIC :: rn_bt_alpha !: Time stepping diffusion parameter + + + ! !!! associated variables + LOGICAL , PUBLIC :: l_1st_euler !: Euler 1st time-step flag (=T if ln_restart=F or ln_1st_euler=T) + REAL(wp), PUBLIC :: rDt, r1_Dt !: Current model timestep and reciprocal + !: rDt = 2 * rn_Dt if leapfrog and l_1st_euler = F + !: = rn_Dt if leapfrog and l_1st_euler = T + !: = rn_Dt if RK3 + + !!---------------------------------------------------------------------- + !! space domain parameters + !!---------------------------------------------------------------------- + LOGICAL , PUBLIC :: l_Iperio, l_Jperio ! i- j-periodicity + LOGICAL , PUBLIC :: l_NFold ! North Pole folding + CHARACTER(len=1), PUBLIC :: c_NFtype ! type of North pole Folding: T or F point + + ! Tiling namelist + LOGICAL, PUBLIC :: ln_tile + INTEGER :: nn_ltile_i, nn_ltile_j + + ! Domain tiling + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntsi_a !: start of internal part of tile domain + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntsj_a ! + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntei_a !: end of internal part of tile domain + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntej_a ! + LOGICAL, PUBLIC :: l_istiled ! whether tiling is currently active or not + + ! !: domain MPP decomposition parameters + INTEGER , PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom + INTEGER , PUBLIC :: narea !: number for local area (starting at 1) = MPI rank + 1 + INTEGER, PUBLIC :: nidom !: IOIPSL things... + + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig !: local ==> global domain, including halos (jpiglo), i-index + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg !: local ==> global domain, including halos (jpjglo), j-index + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig0 !: local ==> global domain, excluding halos (Ni0glo), i-index + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg0 !: local ==> global domain, excluding halos (Nj0glo), j-index + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mi0, mi1 !: global, including halos (jpiglo) ==> local domain i-index + ! !: (mi0=1 and mi1=0 if global index not in local domain) + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1 !: global, including halos (jpjglo) ==> local domain j-index + ! !: (mj0=1 and mj1=0 if global index not in local domain) + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nfimpp, nfproc, nfjpi + + !!---------------------------------------------------------------------- + !! horizontal curvilinear coordinate and scale factors + !! --------------------------------------------------------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: glamt , glamu, glamv , glamf !: longitude at t, u, v, f-points [degree] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: gphit , gphiu, gphiv , gphif !: latitude at t, u, v, f-points [degree] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: r1_e1t, r1_e2t!: t-point horizontal scale factors [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1t, e2t!: t-point horizontal scale factors [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e2u, r1_e1u, r1_e2u!: horizontal scale factors at u-point [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1u!: horizontal scale factors at u-point [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1v, r1_e1v, r1_e2v!: horizontal scale factors at v-point [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e2v!: horizontal scale factors at v-point [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: r1_e1f, r1_e2f!: horizontal scale factors at f-point [m] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1f, e2f!: horizontal scale factors at f-point [m] + ! + REAL(dp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2t , r1_e1e2t !: associated metrics at t-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2u , r1_e1e2u , e2_e1u !: associated metrics at u-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , r1_e1e2v , e1_e2v !: associated metrics at v-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2f , r1_e1e2f !: associated metrics at f-point + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ff_f , ff_t !: Coriolis factor at f- & t-points [1/s] + + !!---------------------------------------------------------------------- + !! vertical coordinate and scale factors + !! --------------------------------------------------------------------- +#if defined key_qco + LOGICAL, PUBLIC, PARAMETER :: lk_qco = .TRUE. !: qco key flag +#else + LOGICAL, PUBLIC, PARAMETER :: lk_qco = .FALSE. !: qco key flag +#endif +#if defined key_linssh + LOGICAL, PUBLIC, PARAMETER :: lk_linssh = .TRUE. !: linssh key flag +#else + LOGICAL, PUBLIC, PARAMETER :: lk_linssh = .FALSE. !: linssh key flag +#endif + LOGICAL, PUBLIC :: ln_zco !: z-coordinate - full step + LOGICAL, PUBLIC :: ln_zps !: z-coordinate - partial step + LOGICAL, PUBLIC :: ln_sco !: s-coordinate or hybrid z-s coordinate + LOGICAL, PUBLIC :: ln_isfcav !: presence of ISF + ! ! reference scale factors + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t_0 !: t- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3u_0 !: u- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3v_0 !: v- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3f_0 !: f- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3w_0 !: w- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3uw_0 !: uw-vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3vw_0 !: vw-vert. scale factor [m] + + ! ! time-dependent scale factors (domvvl) +#if defined key_qco || defined key_linssh +#else + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e3t, e3u, e3v, e3w, e3uw, e3vw !: vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3f !: F-point vert. scale factor [m] +#endif + ! ! time-dependent ratio ssh / h_0 (domqco) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: r3u, r3v!: time-dependent ratio at t-, u- and v-point [-] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: r3t!: time-dependent ratio at t-, u- and v-point [-] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3f !: mid-time-level ratio at f-point [-] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3u_f, r3v_f!: now time-filtered ratio at t-, u- and v-point [-] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r3t_f!: now time-filtered ratio at t-, u- and v-point [-] + + ! ! reference depths of cells + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0 !: t- depth [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 !: w- depth [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0 !: w- depth (sum of e3w) [m] + + ! ! time-dependent depths of cells (domvvl) +#if defined key_qco || defined key_linssh +#else + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: gdept, gdepw + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w +#endif + ! ! reference heights of ocean water column and its inverse + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_0, r1_ht_0 !: t-depth [m] and [1/m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_0, r1_hu_0 !: u-depth [m] and [1/m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_0, r1_hv_0 !: v-depth [m] and [1/m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hf_0, r1_hf_0 !: f-depth [m] and [1/m] + + ! ! time-dependent heights of ocean water column (domvvl) +#if defined key_qco || defined key_linssh +#else + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht !: t-points [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hu, r1_hu !: u-depth [m] and [1/m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hv, r1_hv !: v-depth [m] and [1/m] +#endif + INTEGER, PUBLIC :: nla10 !: deepest W level Above ~10m (nlb10 - 1) + INTEGER, PUBLIC :: nlb10 !: shallowest W level Bellow ~10m (nla10 + 1) + + !! 1D reference vertical coordinate + !! =-----------------====------ + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gdept_1d, gdepw_1d !: reference depth of t- and w-points (m) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: e3t_1d , e3w_1d !: reference vertical scale factors at T- and W-pts (m) + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfdep, bathy + + !!---------------------------------------------------------------------- + !! masks, top and bottom ocean point position + !! --------------------------------------------------------------------- +!!gm Proposition of new name for top/bottom vertical indices +! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mtk_t, mtk_u, mtk_v !: top first wet T-, U-, and V-level (ISF) +! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbk_t, mbk_u, mbk_v !: bottom last wet T-, U-, and V-level +!!gm + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt, mbku, mbkv, mbkf !: bottom last wet T-, U-, V- and F-level + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_i !: interior (excluding halos+duplicated points) domain T-point mask + + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mikt, miku, mikv, mikf !: top first wet T-, U-, V-, F-level (ISF) + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask, ssfmask !: surface mask at T-,U-, V- and F-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, wmask, fmask !: land/ocean mask at T-, U-, V-, W- and F-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wumask, wvmask !: land/ocean mask at WU- and WV-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: fe3mask !: land/ocean mask at F-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_upd, umask_upd, vmask_upd !: land/ocean mask at F-pts + + !!---------------------------------------------------------------------- + !! calendar variables + !! --------------------------------------------------------------------- + INTEGER , PUBLIC :: nyear !: current year + INTEGER , PUBLIC :: nmonth !: current month + INTEGER , PUBLIC :: nday !: current day of the month + INTEGER , PUBLIC :: nhour !: current hour + INTEGER , PUBLIC :: nminute !: current minute + INTEGER , PUBLIC :: ndastp !: time step date in yyyymmdd format + INTEGER , PUBLIC :: nday_year !: current day counted from jan 1st of the current year + INTEGER , PUBLIC :: nsec_year !: seconds between 00h jan 1st of the current year and half of the current time step + INTEGER , PUBLIC :: nsec_month !: seconds between 00h 1st day of the current month and half of the current time step + INTEGER , PUBLIC :: nsec_monday !: seconds between 00h of the last Monday and half of the current time step + INTEGER , PUBLIC :: nsec_day !: seconds between 00h of the current day and half of the current time step + REAL(dp), PUBLIC :: fjulday !: current julian day + REAL(dp), PUBLIC :: fjulstartyear !: first day of the current year in julian days + REAL(wp), PUBLIC :: adatrj !: number of elapsed days since the begining of the whole simulation + ! !: (cumulative duration of previous runs that may have used different time-step size) + INTEGER , PUBLIC, DIMENSION( 0: 2) :: nyear_len !: length in days of the previous/current/next year + INTEGER , PUBLIC, DIMENSION(-11:25) :: nmonth_len !: length in days of the months of the current year + INTEGER , PUBLIC, DIMENSION(-11:25) :: nmonth_beg !: second since Jan 1st 0h of the current year and the half of the months + INTEGER , PUBLIC :: nsec1jan000 !: second since Jan 1st 0h of nit000 year and Jan 1st 0h the current year + INTEGER , PUBLIC :: nsec000_1jan000 !: second since Jan 1st 0h of nit000 year and nit000 + INTEGER , PUBLIC :: nsecend_1jan000 !: second since Jan 1st 0h of nit000 year and nitend + + !!---------------------------------------------------------------------- + !! variable defined here to avoid circular dependencies... + !! --------------------------------------------------------------------- + INTEGER, PUBLIC :: nbasin ! number of basin to be considered in diaprt (glo, atl, pac, ind, ipc) + + !!---------------------------------------------------------------------- + !! agrif domain + !!---------------------------------------------------------------------- +#if defined key_agrif + LOGICAL, PUBLIC, PARAMETER :: lk_agrif = .TRUE. !: agrif flag + LOGICAL, PUBLIC :: lk_south, lk_north, lk_west, lk_east !: Child grid boundaries (interpolation or not) +#else + LOGICAL, PUBLIC, PARAMETER :: lk_agrif = .FALSE. !: agrif flag +#endif + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dom_oce.F90 15556 2021-11-29 15:23:06Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +#if ! defined key_agrif + !!---------------------------------------------------------------------- + !! NOT 'key_agrif' dummy function No AGRIF zoom + !!---------------------------------------------------------------------- + LOGICAL FUNCTION Agrif_Root() + Agrif_Root = .TRUE. + END FUNCTION Agrif_Root + + INTEGER FUNCTION Agrif_Fixed() + Agrif_Fixed = 0 + END FUNCTION Agrif_Fixed + + CHARACTER(len=3) FUNCTION Agrif_CFixed() + Agrif_CFixed = '0' + END FUNCTION Agrif_CFixed +#endif + + INTEGER FUNCTION dom_oce_alloc() + !!---------------------------------------------------------------------- + INTEGER :: ii + INTEGER, DIMENSION(30) :: ierr + !!---------------------------------------------------------------------- + ii = 0 ; ierr(:) = 0 + ! + ii = ii+1 + ALLOCATE( glamt(jpi,jpj) , glamu(jpi,jpj) , glamv(jpi,jpj) , glamf(jpi,jpj) , & + & gphit(jpi,jpj) , gphiu(jpi,jpj) , gphiv(jpi,jpj) , gphif(jpi,jpj) , & + & e1t (jpi,jpj) , e2t (jpi,jpj) , r1_e1t(jpi,jpj) , r1_e2t(jpi,jpj) , & + & e1u (jpi,jpj) , e2u (jpi,jpj) , r1_e1u(jpi,jpj) , r1_e2u(jpi,jpj) , & + & e1v (jpi,jpj) , e2v (jpi,jpj) , r1_e1v(jpi,jpj) , r1_e2v(jpi,jpj) , & + & e1f (jpi,jpj) , e2f (jpi,jpj) , r1_e1f(jpi,jpj) , r1_e2f(jpi,jpj) , & + & e1e2t(jpi,jpj) , r1_e1e2t(jpi,jpj) , & + & e1e2u(jpi,jpj) , r1_e1e2u(jpi,jpj) , e2_e1u(jpi,jpj) , & + & e1e2v(jpi,jpj) , r1_e1e2v(jpi,jpj) , e1_e2v(jpi,jpj) , & + & e1e2f(jpi,jpj) , r1_e1e2f(jpi,jpj) , & + & ff_f (jpi,jpj) , ff_t (jpi,jpj) , STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( gdept_0 (jpi,jpj,jpk) , gdepw_0 (jpi,jpj,jpk) , gde3w_0(jpi,jpj,jpk) , & + & gdept_1d( jpk) , gdepw_1d( jpk) , STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( e3t_0 (jpi,jpj,jpk) , e3u_0 (jpi,jpj,jpk) , e3v_0 (jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) , & + & e3w_0 (jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , & + & e3t_1d( jpk) , e3w_1d( jpk) , STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj) , hv_0(jpi,jpj) , hf_0(jpi,jpj) , & + & r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj) , r1_hv_0(jpi,jpj), r1_hf_0(jpi,jpj) , STAT=ierr(ii) ) + ! +#if defined key_qco + ! qco : ssh to h ratio and specific fmask + ii = ii+1 + ALLOCATE( r3t (jpi,jpj,jpt) , r3u (jpi,jpj,jpt) , r3v (jpi,jpj,jpt) , r3f (jpi,jpj) , & + & r3t_f(jpi,jpj) , r3u_f(jpi,jpj) , r3v_f(jpi,jpj) , STAT=ierr(ii) ) + ! + ii = ii+1 + ! +#elif defined key_linssh + ! linear ssh no time varying coordinate arrays +#else + ! vvl : time varation for all vertical coordinate variables + ii = ii+1 + ALLOCATE( gdept (jpi,jpj,jpk,jpt) , gdepw (jpi,jpj,jpk,jpt) , gde3w (jpi,jpj,jpk) , STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) , & + & e3w(jpi,jpj,jpk,jpt) , e3uw(jpi,jpj,jpk,jpt) , e3vw(jpi,jpj,jpk,jpt) , STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( ht (jpi,jpj) , hu (jpi,jpj,jpt), hv (jpi,jpj,jpt) , & + & r1_hu (jpi,jpj,jpt), r1_hv (jpi,jpj,jpt) , STAT=ierr(ii) ) +#endif + ! + ii = ii+1 + ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( tmask_i(jpi,jpj) , & + & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) , & + & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , mbkf(jpi,jpj) , STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj), mikf(jpi,jpj), STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , & + & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , fe3mask(jpi,jpj,jpk), STAT=ierr(ii) ) + ! + ii = ii+1 + ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(ii) ) + ! +#if defined key_agrif + ii = ii+1 + ALLOCATE( tmask_upd(jpi,jpj) , umask_upd(jpi,jpj), vmask_upd(jpi,jpj) , STAT=ierr(ii) ) +#endif + ! + dom_oce_alloc = MAXVAL(ierr) + ! + END FUNCTION dom_oce_alloc + + !!====================================================================== +END MODULE dom_oce \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domain.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domain.F90 new file mode 100644 index 0000000..b7a3430 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domain.F90 @@ -0,0 +1,765 @@ +MODULE domain + !!============================================================================== + !! *** MODULE domain *** + !! Ocean initialization : domain initialization + !!============================================================================== + !! History : OPA ! 1990-10 (C. Levy - G. Madec) Original code + !! ! 1992-01 (M. Imbard) insert time step initialization + !! ! 1996-06 (G. Madec) generalized vertical coordinate + !! ! 1997-02 (G. Madec) creation of domwri.F + !! ! 2001-05 (E.Durand - G. Madec) insert closed sea + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! 2.0 ! 2005-11 (V. Garnier) Surface pressure gradient organization + !! 3.3 ! 2010-11 (G. Madec) initialisation in C1D configuration + !! 3.6 ! 2013 ( J. Simeon, C. Calone, G. Madec, C. Ethe ) Online coarsening of outputs + !! 3.7 ! 2015-11 (G. Madec, A. Coward) time varying zgr by default + !! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface + !! 4.1 ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_init : initialize the space and time domain + !! dom_nam : read and contral domain namelists + !! dom_ctl : control print for the ocean domain + !! domain_cfg : read the global domain size in domain configuration file + !! cfg_write : create the domain configuration file + !!---------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce ! domain: ocean + USE domtile ! tiling utilities +#if defined key_qco + USE domqco ! quasi-eulerian coord. +#elif defined key_linssh + ! ! fix in time coord. +#else + USE domvvl ! variable volume coord. +#endif +#if defined key_agrif + USE agrif_oce_interp, ONLY : Agrif_istate_ssh ! ssh interpolated from parent +#endif + USE sbc_oce ! surface boundary condition: ocean + USE trc_oce ! shared ocean & passive tracers variab + USE phycst ! physical constants + USE domhgr ! domain: set the horizontal mesh + USE domzgr ! domain: set the vertical mesh + USE dommsk ! domain: set the mask system + USE domwri ! domain: write the meshmask file + USE wet_dry , ONLY : ll_wd ! wet & drying flag + USE closea , ONLY : dom_clo ! closed seas routine + USE c1d + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_mpp ! distributed memory computing library + USE restart ! only for lrst_oce and rst_read_ssh + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_init ! called by nemogcm.F90 + PUBLIC domain_cfg ! called by nemogcm.F90 + + !! * Substitutions +# include "single_precision_substitute.h90" +# include "do_loop_substitute.h90" + !!------------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domain.F90 15270 2021-09-17 14:27:55Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!------------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_init( Kbb, Kmm, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_init *** + !! + !! ** Purpose : Domain initialization. Call the routines that are + !! required to create the arrays which define the space + !! and time domain of the ocean model. + !! + !! ** Method : - dom_msk: compute the masks from the bathymetry file + !! - dom_hgr: compute or read the horizontal grid-point position + !! and scale factors, and the coriolis factor + !! - dom_zgr: define the vertical coordinate and the bathymetry + !! - dom_wri: create the meshmask file (ln_meshmask=T) + !! - 1D configuration, move Coriolis, u and v at T-point + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices + ! + INTEGER :: ji, jj, jk, jt ! dummy loop indices + INTEGER :: iconf = 0 ! local integers + REAL(wp):: zrdt + CHARACTER (len=64) :: cform = "(A12, 3(A13, I7))" + INTEGER , DIMENSION(jpi,jpj) :: ik_top , ik_bot ! top and bottom ocean level + REAL(wp), DIMENSION(jpi,jpj) :: z1_hu_0, z1_hv_0 + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! Ocean domain Parameters (control print) + WRITE(numout,*) + WRITE(numout,*) 'dom_init : domain initialization' + WRITE(numout,*) '~~~~~~~~' + ! + WRITE(numout,*) ' Domain info' + WRITE(numout,*) ' dimension of model:' + WRITE(numout,*) ' Local domain Global domain Data domain ' + WRITE(numout,cform) ' ',' jpi : ', jpi, ' jpiglo : ', jpiglo + WRITE(numout,cform) ' ',' jpj : ', jpj, ' jpjglo : ', jpjglo + WRITE(numout,cform) ' ',' jpk : ', jpk, ' jpkglo : ', jpkglo + WRITE(numout,cform) ' ' ,' jpij : ', jpij + WRITE(numout,*) ' mpp local domain info (mpp):' + WRITE(numout,*) ' jpni : ', jpni, ' nn_hls : ', nn_hls + WRITE(numout,*) ' jpnj : ', jpnj, ' nn_hls : ', nn_hls + WRITE(numout,*) ' jpnij : ', jpnij + WRITE(numout,*) ' lateral boundary of the Global domain:' + WRITE(numout,*) ' cyclic east-west :', l_Iperio + WRITE(numout,*) ' cyclic north-south :', l_Jperio + WRITE(numout,*) ' North Pole folding :', l_NFold + WRITE(numout,*) ' type of North pole Folding:', c_NFtype + WRITE(numout,*) ' Ocean model configuration used:' + WRITE(numout,*) ' cn_cfg = ', TRIM( cn_cfg ), ' nn_cfg = ', nn_cfg + ENDIF + + ! + ! !== Reference coordinate system ==! + ! + CALL dom_nam ! read namelist ( namrun, namdom ) + CALL dom_tile_init ! Tile domain + + IF( ln_c1d ) CALL c1d_init ! 1D column configuration + ! + CALL dom_hgr ! Horizontal mesh + + IF( ln_closea ) CALL dom_clo ! Read in masks to define closed seas and lakes + + CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry (return top and bottom ocean t-level indices) + + CALL dom_msk( ik_top, ik_bot ) ! Masks + ! + ht_0(:,:) = 0._wp ! Reference ocean thickness + hu_0(:,:) = 0._wp + hv_0(:,:) = 0._wp + hf_0(:,:) = 0._wp + DO jk = 1, jpkm1 + ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk) + hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk) + hv_0(:,:) = hv_0(:,:) + e3v_0(:,:,jk) * vmask(:,:,jk) + END DO + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + hf_0(ji,jj) = hf_0(ji,jj) + e3f_0(ji,jj,jk)*vmask(ji,jj,jk)*vmask(ji+1,jj,jk) + END_3D + CALL lbc_lnk('domain', hf_0, 'F', 1._wp) + ! + IF( lk_SWE ) THEN ! SWE case redefine hf_0 + hf_0(:,:) = hf_0(:,:) + e3f_0(:,:,1) * ssfmask(:,:) + ENDIF + ! + r1_ht_0(:,:) = ssmask (:,:) / ( ht_0(:,:) + 1._wp - ssmask (:,:) ) + r1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) ) + r1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) ) + r1_hf_0(:,:) = ssfmask(:,:) / ( hf_0(:,:) + 1._wp - ssfmask(:,:) ) + ! + IF( ll_wd ) THEN ! wet and drying (check ht_0 >= 0) + DO_2D( 1, 1, 1, 1 ) + IF( ht_0(ji,jj) < 0._wp .AND. ssmask(ji,jj) == 1._wp ) THEN + CALL ctl_stop( 'dom_init : ht_0 must be positive at potentially wet points' ) + ENDIF + END_2D + ENDIF + ! + ! !== initialisation of time varying coordinate ==! + ! + ! != ssh initialization + ! + IF( l_SAS ) THEN !* No ocean dynamics calculation : set to 0 + ssh(:,:,:) = 0._wp +#if defined key_agrif + ELSEIF( .NOT.Agrif_root() .AND. & + & ln_init_chfrpar ) THEN !* Interpolate initial ssh from parent + CALL Agrif_istate_ssh( Kbb, Kmm, Kaa ) +#endif + ELSE !* Read in restart file or set by user + CALL rst_read_ssh( Kbb, Kmm, Kaa ) + ENDIF + ! +#if defined key_qco + ! != Quasi-Euerian coordinate case + ! + IF( .NOT.l_offline ) CALL dom_qco_init( Kbb, Kmm, Kaa ) +#elif defined key_linssh + ! != Fix in time : key_linssh case, set through domzgr_substitute.h90 +#else + ! + IF( ln_linssh ) THEN != Fix in time : set to the reference one for all + ! + DO jt = 1, jpt ! depth of t- and w-grid-points + gdept(:,:,:,jt) = gdept_0(:,:,:) + gdepw(:,:,:,jt) = gdepw_0(:,:,:) + END DO + gde3w(:,:,:) = gde3w_0(:,:,:) ! = gdept as the sum of e3t + ! + DO jt = 1, jpt ! vertical scale factors + e3t (:,:,:,jt) = e3t_0(:,:,:) + e3u (:,:,:,jt) = e3u_0(:,:,:) + e3v (:,:,:,jt) = e3v_0(:,:,:) + e3w (:,:,:,jt) = e3w_0(:,:,:) + e3uw(:,:,:,jt) = e3uw_0(:,:,:) + e3vw(:,:,:,jt) = e3vw_0(:,:,:) + END DO + e3f (:,:,:) = e3f_0(:,:,:) + ! + DO jt = 1, jpt ! water column thickness and its inverse + hu(:,:,jt) = hu_0(:,:) + hv(:,:,jt) = hv_0(:,:) + r1_hu(:,:,jt) = r1_hu_0(:,:) + r1_hv(:,:,jt) = r1_hv_0(:,:) + END DO + ht (:,:) = ht_0(:,:) + ! + ELSE != Time varying : initialize before/now/after variables + ! + IF( .NOT.l_offline ) CALL dom_vvl_init( Kbb, Kmm, Kaa ) + ! + ENDIF +#endif + + ! + +#if defined key_agrif + IF( .NOT. Agrif_Root() ) CALL Agrif_Init_Domain( Kbb, Kmm, Kaa ) +#endif + IF( ln_meshmask ) CALL dom_wri ! Create a domain file + IF( .NOT.ln_rstart ) CALL dom_ctl ! Domain control + ! + IF( ln_write_cfg ) CALL cfg_write ! create the configuration file + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_init : ==>>> END of domain initialization' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) + ENDIF + ! + END SUBROUTINE dom_init + + + SUBROUTINE dom_nam + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_nam *** + !! + !! ** Purpose : read domaine namelists and print the variables. + !! + !! ** input : - namrun namelist + !! - namdom namelist + !! - namtile namelist + !! - namnc4 namelist ! "key_netcdf4" only + !!---------------------------------------------------------------------- + USE ioipsl + !! + INTEGER :: ios ! Local integer + REAL(wp):: zrdt + !!---------------------------------------------------------------------- + ! + NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list, & + & nn_no , cn_exp , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl , & + & nn_it000, nn_itend , nn_date0 , nn_time0 , nn_leapy , nn_istate , & + & nn_stock, nn_write , ln_mskland , ln_clobber , nn_chunksz, ln_1st_euler , & + & ln_cfmeta, ln_xios_read, nn_wxios + NAMELIST/namdom/ ln_linssh, rn_Dt, rn_atfp, ln_crs, ln_c1d, ln_meshmask + NAMELIST/namtile/ ln_tile, nn_ltile_i, nn_ltile_j +#if defined key_netcdf4 + NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip +#endif + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_nam : domain initialization through namelist read' + WRITE(numout,*) '~~~~~~~ ' + ENDIF + ! + ! !=======================! + ! !== namelist namdom ==! + ! !=======================! + ! + READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' ) + READ ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' ) + IF(lwm) WRITE( numond, namdom ) + ! +#if defined key_linssh + ln_linssh = lk_linssh ! overwrite ln_linssh with the logical associated with key_linssh +#endif + ! +#if defined key_agrif + IF( .NOT. Agrif_Root() ) THEN ! AGRIF child, subdivide the Parent timestep + rn_Dt = Agrif_Parent (rn_Dt ) / Agrif_Rhot() + ENDIF +#endif + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Namelist : namdom --- space & time domain' + WRITE(numout,*) ' linear free surface (=T) ln_linssh = ', ln_linssh + WRITE(numout,*) ' create mesh/mask file ln_meshmask = ', ln_meshmask + WRITE(numout,*) ' ocean time step rn_Dt = ', rn_Dt + WRITE(numout,*) ' asselin time filter parameter rn_atfp = ', rn_atfp + WRITE(numout,*) ' online coarsening of dynamical fields ln_crs = ', ln_crs + WRITE(numout,*) ' single column domain (1x1pt) ln_c1d = ', ln_c1d + ENDIF + ! + ! set current model timestep rDt = 2*rn_Dt if MLF or rDt = rn_Dt if RK3 + rDt = 2._wp * rn_Dt + r1_Dt = 1._wp / rDt + ! + IF( l_SAS .AND. .NOT.ln_linssh ) THEN + CALL ctl_warn( 'SAS requires linear ssh : force ln_linssh = T' ) + ln_linssh = .TRUE. + ENDIF + ! +#if defined key_qco + IF( ln_linssh ) CALL ctl_stop( 'STOP','domain: key_qco and ln_linssh=T or key_linssh are incompatible' ) +#endif + ! + ! !=======================! + ! !== namelist namrun ==! + ! !=======================! + ! + READ ( numnam_ref, namrun, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in reference namelist' ) + READ ( numnam_cfg, namrun, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namrun in configuration namelist' ) + IF(lwm) WRITE ( numond, namrun ) + +#if defined key_agrif + IF( .NOT. Agrif_Root() ) THEN + nn_it000 = (Agrif_Parent(nn_it000)-1)*Agrif_IRhot() + 1 + nn_itend = Agrif_Parent(nn_itend) *Agrif_IRhot() + ENDIF +#endif + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : namrun --- run parameters' + WRITE(numout,*) ' Assimilation cycle nn_no = ', nn_no + WRITE(numout,*) ' experiment name for output cn_exp = ', TRIM( cn_exp ) + WRITE(numout,*) ' file prefix restart input cn_ocerst_in = ', TRIM( cn_ocerst_in ) + WRITE(numout,*) ' restart input directory cn_ocerst_indir = ', TRIM( cn_ocerst_indir ) + WRITE(numout,*) ' file prefix restart output cn_ocerst_out = ', TRIM( cn_ocerst_out ) + WRITE(numout,*) ' restart output directory cn_ocerst_outdir= ', TRIM( cn_ocerst_outdir ) + WRITE(numout,*) ' restart logical ln_rstart = ', ln_rstart + WRITE(numout,*) ' start with forward time step ln_1st_euler = ', ln_1st_euler + WRITE(numout,*) ' control of time step nn_rstctl = ', nn_rstctl + WRITE(numout,*) ' number of the first time step nn_it000 = ', nn_it000 + WRITE(numout,*) ' number of the last time step nn_itend = ', nn_itend + WRITE(numout,*) ' initial calendar date aammjj nn_date0 = ', nn_date0 + WRITE(numout,*) ' initial time of day in hhmm nn_time0 = ', nn_time0 + WRITE(numout,*) ' leap year calendar (0/1) nn_leapy = ', nn_leapy + WRITE(numout,*) ' initial state output nn_istate = ', nn_istate + IF( ln_rst_list ) THEN + WRITE(numout,*) ' list of restart dump times nn_stocklist =', nn_stocklist + ELSE + WRITE(numout,*) ' frequency of restart file nn_stock = ', nn_stock + ENDIF +#if ! defined key_xios + WRITE(numout,*) ' frequency of output file nn_write = ', nn_write +#endif + WRITE(numout,*) ' mask land points ln_mskland = ', ln_mskland + WRITE(numout,*) ' additional CF standard metadata ln_cfmeta = ', ln_cfmeta + WRITE(numout,*) ' overwrite an existing file ln_clobber = ', ln_clobber + WRITE(numout,*) ' NetCDF chunksize (bytes) nn_chunksz = ', nn_chunksz + IF( TRIM(Agrif_CFixed()) == '0' ) THEN + WRITE(numout,*) ' READ restart for a single file using XIOS ln_xios_read =', ln_xios_read + WRITE(numout,*) ' Write restart using XIOS nn_wxios = ', nn_wxios + ELSE + WRITE(numout,*) " AGRIF: nn_wxios will be ingored. See setting for parent" + WRITE(numout,*) " AGRIF: ln_xios_read will be ingored. See setting for parent" + ENDIF + ENDIF + + cexper = cn_exp ! conversion DOCTOR names into model names (this should disappear soon) + nrstdt = nn_rstctl + nit000 = nn_it000 + nitend = nn_itend + ndate0 = nn_date0 + nleapy = nn_leapy + ninist = nn_istate + ! + ! !== Set parameters for restart reading using xIOS ==! + ! + IF( TRIM(Agrif_CFixed()) == '0' ) THEN + lrxios = ln_xios_read .AND. ln_rstart + IF( nn_wxios > 0 ) lwxios = .TRUE. !* set output file type for XIOS based on NEMO namelist + nxioso = nn_wxios + ENDIF + ! !== Check consistency between ln_rstart and ln_1st_euler ==! (i.e. set l_1st_euler) + l_1st_euler = ln_1st_euler + ! + IF( ln_rstart ) THEN !* Restart case + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' open the restart file' + CALL rst_read_open !- Open the restart file + ! + IF( iom_varid( numror, 'rdt', ldstop = .FALSE. ) > 0 ) THEN !- Check time-step consistency and force Euler restart if changed + CALL iom_get( numror, 'rdt', zrdt ) + IF( zrdt /= rn_Dt ) THEN + IF(lwp) WRITE( numout,*) + IF(lwp) WRITE( numout,*) ' rn_Dt = ', rn_Dt,' not equal to the READ one rdt = ', zrdt + IF(lwp) WRITE( numout,*) + IF(lwp) WRITE( numout,*) ' ==>>> forced euler first time-step' + l_1st_euler = .TRUE. + ENDIF + ENDIF + ! + IF( .NOT.l_SAS .AND. iom_varid( numror, 'sshb', ldstop = .FALSE. ) <= 0 ) THEN !- Check absence of one of the Kbb field (here sshb) + ! ! (any Kbb field is missing ==> all Kbb fields are missing) + IF( .NOT.l_1st_euler ) THEN + CALL ctl_warn('dom_nam : ssh at Kbb not found in restart files ', & + & 'l_1st_euler forced to .true. and ' , & + & 'ssh(Kbb) = ssh(Kmm) ' ) + l_1st_euler = .TRUE. + ENDIF + ENDIF + ELSEIF( .NOT.l_1st_euler ) THEN !* Initialization case + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)' ==>>> Start from rest (ln_rstart=F)' + IF(lwp) WRITE(numout,*)' an Euler initial time step is used : l_1st_euler is forced to .true. ' + l_1st_euler = .TRUE. + ENDIF + ! + ! !== control of output frequency ==! + ! + IF( .NOT. ln_rst_list ) THEN ! we use nn_stock + IF( nn_stock == -1 ) CALL ctl_warn( 'nn_stock = -1 --> no restart will be done' ) + IF( nn_stock == 0 .OR. nn_stock > nitend ) THEN + WRITE(ctmp1,*) 'nn_stock = ', nn_stock, ' it is forced to ', nitend + CALL ctl_warn( ctmp1 ) + nn_stock = nitend + ENDIF + ENDIF +#if ! defined key_xios + IF( nn_write == -1 ) CALL ctl_warn( 'nn_write = -1 --> no output files will be done' ) + IF ( nn_write == 0 ) THEN + WRITE(ctmp1,*) 'nn_write = ', nn_write, ' it is forced to ', nitend + CALL ctl_warn( ctmp1 ) + nn_write = nitend + ENDIF +#endif + + IF( Agrif_Root() ) THEN + IF(lwp) WRITE(numout,*) + SELECT CASE ( nleapy ) !== Choose calendar for IOIPSL ==! + CASE ( 1 ) + CALL ioconf_calendar('gregorian') + IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "gregorian", i.e. leap year' + CASE ( 0 ) + CALL ioconf_calendar('noleap') + IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "noleap", i.e. no leap year' + CASE ( 30 ) + CALL ioconf_calendar('360d') + IF(lwp) WRITE(numout,*) ' ==>>> The IOIPSL calendar is "360d", i.e. 360 days in a year' + END SELECT + ENDIF + ! + ! !========================! + ! !== namelist namtile ==! + ! !========================! + ! + READ ( numnam_ref, namtile, IOSTAT = ios, ERR = 905 ) +905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtile in reference namelist' ) + READ ( numnam_cfg, namtile, IOSTAT = ios, ERR = 906 ) +906 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtile in configuration namelist' ) + IF(lwm) WRITE( numond, namtile ) + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Namelist : namtile --- Domain tiling decomposition' + WRITE(numout,*) ' Tiling (T) or not (F) ln_tile = ', ln_tile + WRITE(numout,*) ' Length of tile in i nn_ltile_i = ', nn_ltile_i + WRITE(numout,*) ' Length of tile in j nn_ltile_j = ', nn_ltile_j + WRITE(numout,*) + IF( ln_tile ) THEN + WRITE(numout,*) ' The domain will be decomposed into tiles of size', nn_ltile_i, 'x', nn_ltile_j + ELSE + WRITE(numout,*) ' Domain tiling will NOT be used' + ENDIF + ENDIF + ! +#if defined key_netcdf4 + ! !=======================! + ! !== namelist namnc4 ==! NetCDF 4 case ("key_netcdf4" defined) + ! !=======================! + ! + READ ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907) +907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in reference namelist' ) + READ ( numnam_cfg, namnc4, IOSTAT = ios, ERR = 908 ) +908 IF( ios > 0 ) CALL ctl_nam ( ios , 'namnc4 in configuration namelist' ) + IF(lwm) WRITE( numond, namnc4 ) + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' Namelist namnc4 - Netcdf4 chunking parameters ("key_netcdf4" defined)' + WRITE(numout,*) ' number of chunks in i-dimension nn_nchunks_i = ', nn_nchunks_i + WRITE(numout,*) ' number of chunks in j-dimension nn_nchunks_j = ', nn_nchunks_j + WRITE(numout,*) ' number of chunks in k-dimension nn_nchunks_k = ', nn_nchunks_k + WRITE(numout,*) ' apply netcdf4/hdf5 chunking & compression ln_nc4zip = ', ln_nc4zip + ENDIF + + ! Put the netcdf4 settings into a simple structure (snc4set, defined in in_out_manager module) + ! Note the chunk size in the unlimited (time) dimension will be fixed at 1 + snc4set%ni = nn_nchunks_i + snc4set%nj = nn_nchunks_j + snc4set%nk = nn_nchunks_k + snc4set%luse = ln_nc4zip +#else + snc4set%luse = .FALSE. ! No NetCDF 4 case +#endif + ! + END SUBROUTINE dom_nam + + + SUBROUTINE dom_ctl + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_ctl *** + !! + !! ** Purpose : Domain control. + !! + !! ** Method : compute and print extrema of masked scale factors + !!---------------------------------------------------------------------- + LOGICAL, DIMENSION(jpi,jpj) :: llmsk + INTEGER, DIMENSION(2) :: imil, imip, imi1, imi2, imal, imap, ima1, ima2 + REAL(wp) :: zglmin, zglmax, zgpmin, zgpmax, ze1min, ze1max, ze2min, ze2max + !!---------------------------------------------------------------------- + ! + llmsk = tmask_i(:,:) == 1._wp + ! + CALL mpp_minloc( 'domain', REAL(glamt(:,:),dp), llmsk, zglmin, imil ) + CALL mpp_minloc( 'domain', REAL(gphit(:,:),dp), llmsk, zgpmin, imip ) + CALL mpp_minloc( 'domain', CASTDP(e1t(:,:)), llmsk, ze1min, imi1 ) + CALL mpp_minloc( 'domain', CASTDP(e2t(:,:)), llmsk, ze2min, imi2 ) + CALL mpp_maxloc( 'domain', CASTDP(glamt(:,:)), llmsk, zglmax, imal ) + CALL mpp_maxloc( 'domain', CASTDP(gphit(:,:)), llmsk, zgpmax, imap ) + CALL mpp_maxloc( 'domain', e1t(:,:), llmsk, ze1max, ima1 ) + CALL mpp_maxloc( 'domain', e2t(:,:), llmsk, ze2max, ima2 ) + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,"(14x,'glamt mini: ',1f10.2,' at i = ',i5,' j= ',i5)") zglmin, imil(1), imil(2) + WRITE(numout,"(14x,'glamt maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") zglmax, imal(1), imal(2) + WRITE(numout,"(14x,'gphit mini: ',1f10.2,' at i = ',i5,' j= ',i5)") zgpmin, imip(1), imip(2) + WRITE(numout,"(14x,'gphit maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") zgpmax, imap(1), imap(2) + WRITE(numout,"(14x,' e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, imi1(1), imi1(2) + WRITE(numout,"(14x,' e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, ima1(1), ima1(2) + WRITE(numout,"(14x,' e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, imi2(1), imi2(2) + WRITE(numout,"(14x,' e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, ima2(1), ima2(2) + ENDIF + ! + END SUBROUTINE dom_ctl + + + SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) + !!---------------------------------------------------------------------- + !! *** ROUTINE domain_cfg *** + !! + !! ** Purpose : read the domain size in domain configuration file + !! + !! ** Method : read the cn_domcfg NetCDF file + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name + INTEGER , INTENT(out) :: kk_cfg ! configuration resolution + INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes + LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity + LOGICAL , INTENT(out) :: ldNFold ! North pole folding + CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F + ! + CHARACTER(len=7) :: catt ! 'T', 'F', '-' or 'UNKNOWN' + INTEGER :: inum, iperio, iatt ! local integer + REAL(wp) :: zorca_res ! local scalars + REAL(wp) :: zperio ! - - + INTEGER, DIMENSION(4) :: idvar, idimsz ! size of dimensions + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) ' ' + WRITE(numout,*) 'domain_cfg : domain size read in ', TRIM( cn_domcfg ), ' file' + WRITE(numout,*) '~~~~~~~~~~ ' + ENDIF + ! + CALL iom_open( cn_domcfg, inum ) + ! + CALL iom_getatt( inum, 'CfgName', cd_cfg ) ! returns 'UNKNOWN' if not found + CALL iom_getatt( inum, 'CfgIndex', kk_cfg ) ! returns -999 if not found + ! + ! ------- keep compatibility with OLD VERSION... start ------- + IF( cd_cfg == 'UNKNOWN' .AND. kk_cfg == -999 ) THEN + IF( iom_varid( inum, 'ORCA' , ldstop = .FALSE. ) > 0 .AND. & + & iom_varid( inum, 'ORCA_index' , ldstop = .FALSE. ) > 0 ) THEN + ! + cd_cfg = 'ORCA' + CALL iom_get( inum, 'ORCA_index', zorca_res ) ; kk_cfg = NINT( zorca_res ) + ! + ELSE + CALL iom_getatt( inum, 'cn_cfg', cd_cfg ) ! returns 'UNKNOWN' if not found + CALL iom_getatt( inum, 'nn_cfg', kk_cfg ) ! returns -999 if not found + ENDIF + ENDIF + ! ------- keep compatibility with OLD VERSION... end ------- + ! + idvar = iom_varid( inum, 'e3t_0', kdimsz = idimsz ) ! use e3t_0, that must exist, to get jp(ijk)glo + kpi = idimsz(1) + kpj = idimsz(2) + kpk = idimsz(3) + ! + CALL iom_getatt( inum, 'Iperio', iatt ) ; ldIperio = iatt == 1 ! returns -999 if not found -> default = .false. + CALL iom_getatt( inum, 'Jperio', iatt ) ; ldJperio = iatt == 1 ! returns -999 if not found -> default = .false. + CALL iom_getatt( inum, 'NFold', iatt ) ; ldNFold = iatt == 1 ! returns -999 if not found -> default = .false. + CALL iom_getatt( inum, 'NFtype', catt ) ! returns 'UNKNOWN' if not found + IF( LEN_TRIM(catt) == 1 ) THEN ; cdNFtype = TRIM(catt) + ELSE ; cdNFtype = '-' + ENDIF + ! + ! ------- keep compatibility with OLD VERSION... start ------- + IF( iatt == -999 .AND. catt == 'UNKNOWN' .AND. iom_varid( inum, 'jperio', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( inum, 'jperio', zperio ) ; iperio = NINT( zperio ) + ldIperio = iperio == 1 .OR. iperio == 4 .OR. iperio == 6 .OR. iperio == 7 ! i-periodicity + ldJperio = iperio == 2 .OR. iperio == 7 ! j-periodicity + ldNFold = iperio >= 3 .AND. iperio <= 6 ! North pole folding + IF( iperio == 3 .OR. iperio == 4 ) THEN ; cdNFtype = 'T' ! folding at T point + ELSEIF( iperio == 5 .OR. iperio == 6 ) THEN ; cdNFtype = 'F' ! folding at F point + ELSE ; cdNFtype = '-' ! default value + ENDIF + ENDIF + ! ------- keep compatibility with OLD VERSION... end ------- + ! + CALL iom_close( inum ) + ! + IF(lwp) THEN + WRITE(numout,*) ' .' + WRITE(numout,*) ' ==>>> ', TRIM(cn_cfg), ' configuration ' + WRITE(numout,*) ' .' + WRITE(numout,*) ' nn_cfg = ', kk_cfg + WRITE(numout,*) ' Ni0glo = ', kpi + WRITE(numout,*) ' Nj0glo = ', kpj + WRITE(numout,*) ' jpkglo = ', kpk + ENDIF + ! + END SUBROUTINE domain_cfg + + + SUBROUTINE cfg_write + !!---------------------------------------------------------------------- + !! *** ROUTINE cfg_write *** + !! + !! ** Purpose : Create the "cn_domcfg_out" file, a NetCDF file which + !! contains all the ocean domain informations required to + !! define an ocean configuration. + !! + !! ** Method : Write in a file all the arrays required to set up an + !! ocean configuration. + !! + !! ** output file : domcfg_out.nc : domain size, characteristics, horizontal + !! mesh, Coriolis parameter, and vertical scale factors + !! NB: also contain ORCA family information + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: inum ! local units + CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'cfg_write : create the domain configuration file (', TRIM(cn_domcfg_out),'.nc)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~' + ! + ! ! ============================= ! + ! ! create 'domcfg_out.nc' file ! + ! ! ============================= ! + ! + clnam = cn_domcfg_out ! filename (configuration information) + CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) + ! + ! !== Configuration specificities ==! + ! + CALL iom_putatt( inum, 'CfgName', TRIM(cn_cfg) ) + CALL iom_putatt( inum, 'CfgIndex', nn_cfg ) + ! + ! !== domain characteristics ==! + ! + ! ! lateral boundary of the global domain + CALL iom_putatt( inum, 'Iperio', COUNT( (/l_Iperio/) ) ) + CALL iom_putatt( inum, 'Jperio', COUNT( (/l_Jperio/) ) ) + CALL iom_putatt( inum, 'NFold', COUNT( (/l_NFold /) ) ) + CALL iom_putatt( inum, 'NFtype', c_NFtype ) + + ! ! type of vertical coordinate + IF(ln_zco) CALL iom_putatt( inum, 'VertCoord', 'zco' ) + IF(ln_zps) CALL iom_putatt( inum, 'VertCoord', 'zps' ) + IF(ln_sco) CALL iom_putatt( inum, 'VertCoord', 'sco' ) + + ! ! ocean cavities under iceshelves + CALL iom_putatt( inum, 'IsfCav', COUNT( (/ln_isfcav/) ) ) + ! + ! !== horizontal mesh ! + ! + CALL iom_rstput( 0, 0, inum, 'glamt', glamt, ktype = jp_r8 ) ! latitude + CALL iom_rstput( 0, 0, inum, 'glamu', glamu, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'glamv', glamv, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'glamf', glamf, ktype = jp_r8 ) + ! + CALL iom_rstput( 0, 0, inum, 'gphit', gphit, ktype = jp_r8 ) ! longitude + CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'gphif', gphif, ktype = jp_r8 ) + ! + CALL iom_rstput( 0, 0, inum, 'e1t' , e1t , ktype = jp_r8 ) ! i-scale factors (e1.) + CALL iom_rstput( 0, 0, inum, 'e1u' , e1u , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e1v' , e1v , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e1f' , e1f , ktype = jp_r8 ) + ! + CALL iom_rstput( 0, 0, inum, 'e2t' , e2t , ktype = jp_r8 ) ! j-scale factors (e2.) + CALL iom_rstput( 0, 0, inum, 'e2u' , e2u , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e2v' , e2v , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e2f' , e2f , ktype = jp_r8 ) + ! + CALL iom_rstput( 0, 0, inum, 'ff_f' , ff_f , ktype = jp_r8 ) ! coriolis factor + CALL iom_rstput( 0, 0, inum, 'ff_t' , ff_t , ktype = jp_r8 ) + ! + ! !== vertical mesh ==! + ! + CALL iom_rstput( 0, 0, inum, 'e3t_1d' , e3t_1d , ktype = jp_r8 ) ! reference 1D-coordinate + CALL iom_rstput( 0, 0, inum, 'e3w_1d' , e3w_1d , ktype = jp_r8 ) + ! + CALL iom_rstput( 0, 0, inum, 'e3t_0' , e3t_0 , ktype = jp_r8 ) ! vertical scale factors + CALL iom_rstput( 0, 0, inum, 'e3u_0' , e3u_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3v_0' , e3v_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3f_0' , e3f_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3w_0' , e3w_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3uw_0' , e3uw_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3vw_0' , e3vw_0 , ktype = jp_r8 ) + ! + ! !== wet top and bottom level ==! (caution: multiplied by ssmask) + ! + CALL iom_rstput( 0, 0, inum, 'top_level' , REAL( mikt, wp )*ssmask , ktype = jp_i4 ) ! nb of ocean T-points (ISF) + CALL iom_rstput( 0, 0, inum, 'bottom_level' , REAL( mbkt, wp )*ssmask , ktype = jp_i4 ) ! nb of ocean T-points + ! + IF( ln_sco ) THEN ! s-coordinate: store grid stiffness ratio (Not required anyway) + CALL dom_stiff( z2d ) + CALL iom_rstput( 0, 0, inum, 'stiffness', z2d ) ! ! Max. grid stiffness ratio + ENDIF + ! + IF( ll_wd ) THEN ! wetting and drying domain + CALL iom_rstput( 0, 0, inum, 'ht_0' , ht_0 , ktype = jp_r8 ) + ENDIF + ! ! ============================ ! + ! ! close the files + ! ! ============================ ! + CALL iom_close( inum ) + ! + END SUBROUTINE cfg_write + + !!====================================================================== +END MODULE domain diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domhgr.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domhgr.F90 new file mode 100644 index 0000000..2906154 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domhgr.F90 @@ -0,0 +1,249 @@ +MODULE domhgr + !!============================================================================== + !! *** MODULE domhgr *** + !! Ocean initialization : domain initialization + !!============================================================================== + !! History : OPA ! 1988-03 (G. Madec) Original code + !! 7.0 ! 1996-01 (G. Madec) terrain following coordinates + !! 8.0 ! 1997-02 (G. Madec) print mesh informations + !! 8.1 ! 1999-11 (M. Imbard) NetCDF format with IO-IPSL + !! 8.2 ! 2000-08 (D. Ludicone) Reduced section at Bab el Mandeb + !! - ! 2001-09 (M. Levy) eel config: grid in km, beta-plane + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module, namelist + !! - ! 2004-01 (A.M. Treguier, J.M. Molines) Case 4 (Mercator mesh) + !! use of parameters in par_CONFIG-Rxx.h90, not in namelist + !! - ! 2004-05 (A. Koch-Larrouy) Add Gyre configuration + !! 3.7 ! 2015-09 (G. Madec, S. Flavoni) add cell surface and their inverse + !! add optional read of e1e2u & e1e2v + !! - ! 2016-04 (S. Flavoni, G. Madec) new configuration interface: read or usrdef.F90 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_hgr : initialize the horizontal mesh + !! hgr_read : read horizontal information in the domain configuration file + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + USE usrdef_hgr ! User defined routine + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lib_mpp ! MPP library + USE lbclnk ! lateal boundary condition / mpp exchanges + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_hgr ! called by domain.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domhgr.F90 15056 2021-06-25 07:37:44Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_hgr + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_hgr *** + !! + !! ** Purpose : Read or compute the geographical position (in degrees) + !! of the model grid-points, the horizontal scale factors (in meters), + !! the associated horizontal metrics, and the Coriolis factor (in s-1). + !! + !! ** Method : Controlled by ln_read_cfg logical + !! =T : all needed arrays are read in mesh_mask.nc file + !! =F : user-defined configuration, all needed arrays + !! are computed in usr-def_hgr subroutine + !! + !! If Coriolis factor is neither read nor computed (iff=0) + !! it is computed from gphit assuming that the mesh is + !! defined on the sphere : + !! ff = 2.*omega*sin(gphif) (in s-1) + !! + !! If u- & v-surfaces are neither read nor computed (ie1e2u_v=0) + !! (i.e. no use of reduced scale factors in some straits) + !! they are computed from e1u, e2u, e1v and e2v as: + !! e1e2u = e1u*e2u and e1e2v = e1v*e2v + !! + !! ** Action : - define longitude & latitude of t-, u-, v- and f-points (in degrees) + !! - define Coriolis parameter at f-point (in 1/s) + !! - define i- & j-scale factors at t-, u-, v- and f-points (in meters) + !! - define associated horizontal metrics at t-, u-, v- and f-points + !! (inverse of scale factors 1/e1 & 1/e2, surface e1*e2, ratios e1/e2 & e2/e1) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ie1e2u_v ! flag for u- & v-surfaces + INTEGER :: iff ! flag for Coriolis parameter + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dom_hgr') + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_hgr : define the horizontal mesh from ithe following par_oce parameters ' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' namcfg : read (=T) or user defined (=F) configuration ln_read_cfg = ', ln_read_cfg + ENDIF + ! + IF( ln_read_cfg ) THEN !== read in mesh_mask.nc file ==! + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> read horizontal mesh in ', TRIM( cn_domcfg ), ' file' + ! + CALL hgr_read ( glamt , glamu , glamv , glamf , & ! geographic position (required) + & gphit , gphiu , gphiv , gphif , & ! - - + & iff , ff_f , ff_t , & ! Coriolis parameter (if not on the sphere) + & e1t , e1u , e1v , e1f , & ! scale factors (required) + & e2t , e2u , e2v , e2f , & ! - - - + & ie1e2u_v , e1e2u , e1e2v ) ! u- & v-surfaces (if gridsize reduction in some straits) + ! + ELSE !== User defined configuration ==! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' User defined horizontal mesh (usr_def_hgr)' + ! + CALL usr_def_hgr( glamt , glamu , glamv , glamf , & ! geographic position (required) + & gphit , gphiu , gphiv , gphif , & ! + & iff , ff_f , ff_t , & ! Coriolis parameter (if domain not on the sphere) + & e1t , e1u , e1v , e1f , & ! scale factors (required) + & e2t , e2u , e2v , e2f , & ! + & ie1e2u_v , e1e2u , e1e2v ) ! u- & v-surfaces (if gridsize reduction is used in strait(s)) + ! + ! make sure that periodicities are properly applied + CALL lbc_lnk( 'dom_hgr', glamt, 'T', 1._wp, glamu, 'U', 1._wp, glamv, 'V', 1._wp, glamf, 'F', 1._wp, & + & gphit, 'T', 1._wp, gphiu, 'U', 1._wp, gphiv, 'V', 1._wp, gphif, 'F', 1._wp, & + & e2u, 'U', 1._wp, e1v, 'V', 1._wp, kfillmode = jpfillcopy ) ! do not put 0 over closed boundaries + CALL lbc_lnk( 'dom_hgr', e1t, 'T', 1._dp, e2t, 'T', 1._dp, e1u, 'U', 1._dp, e2v, 'V', 1._dp, & + & e1f, 'F', 1._dp, e2f, 'F', 1._dp, kfillmode = jpfillcopy) + ! + ENDIF + ! + ! !== Coriolis parameter ==! (if necessary) + ! + IF( iff == 0 ) THEN ! Coriolis parameter has not been defined + IF(lwp) WRITE(numout,*) ' Coriolis parameter calculated on the sphere from gphif & gphit' + ff_f(:,:) = 2._wp * omega * SIN( rad * gphif(:,:) ) ! compute it on the sphere at f-point + ff_t(:,:) = 2._wp * omega * SIN( rad * gphit(:,:) ) ! - - - at t-point + ELSE + IF( ln_read_cfg ) THEN + IF(lwp) WRITE(numout,*) ' Coriolis parameter have been read in ', TRIM( cn_domcfg ), ' file' + ELSE + CALL lbc_lnk( 'dom_hgr', ff_t, 'T', 1._wp, ff_f, 'F', 1._wp, kfillmode = jpfillcopy ) ! do not put 0 if closed + IF(lwp) WRITE(numout,*) ' Coriolis parameter have been set in usr_def_hgr routine' + ENDIF + ENDIF + ! + ! !== associated horizontal metrics ==! + ! + r1_e1t(:,:) = 1._wp / e1t(:,:) ; r1_e2t (:,:) = 1._wp / e2t(:,:) + r1_e1u(:,:) = 1._wp / e1u(:,:) ; r1_e2u (:,:) = 1._wp / e2u(:,:) + r1_e1v(:,:) = 1._wp / e1v(:,:) ; r1_e2v (:,:) = 1._wp / e2v(:,:) + r1_e1f(:,:) = 1._wp / e1f(:,:) ; r1_e2f (:,:) = 1._wp / e2f(:,:) + ! + e1e2t (:,:) = e1t(:,:) * e2t(:,:) ; r1_e1e2t(:,:) = 1._wp / e1e2t(:,:) + e1e2f (:,:) = e1f(:,:) * e2f(:,:) ; r1_e1e2f(:,:) = 1._wp / e1e2f(:,:) + IF( ie1e2u_v == 0 ) THEN ! u- & v-surfaces have not been defined + IF(lwp) WRITE(numout,*) ' u- & v-surfaces calculated as e1 e2 product' + e1e2u (:,:) = e1u(:,:) * e2u(:,:) ! compute them + e1e2v (:,:) = e1v(:,:) * e2v(:,:) + ELSE + IF( ln_read_cfg ) THEN + IF(lwp) WRITE(numout,*) ' u- & v-surfaces have been read in ', TRIM( cn_domcfg ), ' file:' + IF(lwp) WRITE(numout,*) ' grid size reduction in strait(s) is used' + ELSE + CALL lbc_lnk( 'dom_hgr', e1e2u, 'U', 1._wp, e1e2v, 'V', 1._wp, kfillmode = jpfillcopy ) ! do not put 0 if closed + IF(lwp) WRITE(numout,*) ' u- & v-surfaces have been have been set in usr_def_hgr routine' + ENDIF + ENDIF + r1_e1e2u(:,:) = 1._wp / e1e2u(:,:) ! compute their invert in any cases + r1_e1e2v(:,:) = 1._wp / e1e2v(:,:) + ! + e2_e1u(:,:) = e2u(:,:) / e1u(:,:) + e1_e2v(:,:) = e1v(:,:) / e2v(:,:) + ! + IF( ln_timing ) CALL timing_stop('dom_hgr') + ! + END SUBROUTINE dom_hgr + + + SUBROUTINE hgr_read( plamt , plamu , plamv , plamf , & ! gridpoints position (required) + & pphit , pphiu , pphiv , pphif , & + & kff , pff_f , pff_t , & ! Coriolis parameter (if not on the sphere) + & pe1t , pe1u , pe1v , pe1f , & ! scale factors (required) + & pe2t , pe2u , pe2v , pe2f , & + & ke1e2u_v , pe1e2u , pe1e2v ) ! u- & v-surfaces (if gridsize reduction in some straits) + !!--------------------------------------------------------------------- + !! *** ROUTINE hgr_read *** + !! + !! ** Purpose : Read a mesh_mask file in NetCDF format using IOM + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), INTENT(out) :: plamt, plamu, plamv, plamf ! longitude outputs + REAL(wp), DIMENSION(:,:), INTENT(out) :: pphit, pphiu, pphiv, pphif ! latitude outputs + INTEGER , INTENT(out) :: kff ! =1 Coriolis parameter read here, =0 otherwise + REAL(wp), DIMENSION(:,:), INTENT(out) :: pff_f, pff_t ! Coriolis factor at f-point (if found in file) + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1v! i-scale factors + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe1t, pe1u, pe1f! i-scale factors + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe2u! j-scale factors + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2v, pe2f! j-scale factors + INTEGER , INTENT(out) :: ke1e2u_v ! =1 u- & v-surfaces read here, =0 otherwise + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if found in file) + ! + INTEGER :: inum ! logical unit + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' hgr_read : read the horizontal coordinates in mesh_mask' + WRITE(numout,*) ' ~~~~~~~~ jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpk = ', jpk + ENDIF + ! + CALL iom_open( cn_domcfg, inum ) + ! + CALL iom_get( inum, jpdom_global, 'glamt', plamt, cd_type = 'T', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'glamu', plamu, cd_type = 'U', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'glamv', plamv, cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'glamf', plamf, cd_type = 'F', psgn = 1._dp, kfill = jpfillcopy ) + ! + CALL iom_get( inum, jpdom_global, 'gphit', pphit, cd_type = 'T', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'gphiu', pphiu, cd_type = 'U', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'gphiv', pphiv, cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'gphif', pphif, cd_type = 'F', psgn = 1._dp, kfill = jpfillcopy ) + ! + CALL iom_get( inum, jpdom_global, 'e1t' , pe1t , cd_type = 'T', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e1u' , pe1u , cd_type = 'U', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e1v' , pe1v , cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e1f' , pe1f , cd_type = 'F', psgn = 1._dp, kfill = jpfillcopy ) + ! + CALL iom_get( inum, jpdom_global, 'e2t' , pe2t , cd_type = 'T', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e2u' , pe2u , cd_type = 'U', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e2v' , pe2v , cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e2f' , pe2f , cd_type = 'F', psgn = 1._dp, kfill = jpfillcopy ) + ! + IF( iom_varid( inum, 'ff_f', ldstop = .FALSE. ) > 0 .AND. & + & iom_varid( inum, 'ff_t', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) ' Coriolis factor at f- and t-points read in ', TRIM( cn_domcfg ), ' file' + CALL iom_get( inum, jpdom_global, 'ff_f', pff_f, cd_type = 'F', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'ff_t', pff_t, cd_type = 'T', psgn = 1._dp, kfill = jpfillcopy ) + kff = 1 + ELSE + kff = 0 + ENDIF + ! + IF( iom_varid( inum, 'e1e2u', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) ' e1e2u & e1e2v read in ', TRIM( cn_domcfg ), ' file' + CALL iom_get( inum, jpdom_global, 'e1e2u', pe1e2u, cd_type = 'U', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e1e2v', pe1e2v, cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + ke1e2u_v = 1 + ELSE + ke1e2u_v = 0 + ENDIF + ! + CALL iom_close( inum ) + ! + END SUBROUTINE hgr_read + + !!====================================================================== +END MODULE domhgr diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/dommsk.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/dommsk.F90 new file mode 100644 index 0000000..7996483 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/dommsk.F90 @@ -0,0 +1,233 @@ +MODULE dommsk + !!====================================================================== + !! *** MODULE dommsk *** + !! Ocean initialization : domain land/sea mask + !!====================================================================== + !! History : OPA ! 1987-07 (G. Madec) Original code + !! 6.0 ! 1993-03 (M. Guyon) symetrical conditions (M. Guyon) + !! 7.0 ! 1996-01 (G. Madec) suppression of common work arrays + !! - ! 1996-05 (G. Madec) mask computed from tmask + !! 8.0 ! 1997-02 (G. Madec) mesh information put in domhgr.F + !! 8.1 ! 1997-07 (G. Madec) modification of kbat and fmask + !! - ! 1998-05 (G. Roullet) free surface + !! 8.2 ! 2000-03 (G. Madec) no slip accurate + !! - ! 2001-09 (J.-M. Molines) Open boundaries + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! - ! 2005-11 (V. Garnier) Surface pressure gradient organization + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !! 3.6 ! 2015-05 (P. Mathiot) ISF: add wmask,wumask and wvmask + !! 4.0 ! 2016-06 (G. Madec, S. Flavoni) domain configuration / user defined interface + !! 4.x ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_msk : compute land/ocean mask + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE domutl ! + USE usrdef_fmask ! user defined fmask + USE bdy_oce ! open boundary + ! + USE in_out_manager ! I/O manager + USE iom ! IOM library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! Massively Parallel Processing library + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_msk ! routine called by inidom.F90 + + ! !!* Namelist namlbc : lateral boundary condition * + REAL(wp) :: rn_shlat ! type of lateral boundary condition on velocity + LOGICAL, PUBLIC :: ln_vorlat ! consistency of vorticity boundary condition + ! with analytical eqs. + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dommsk.F90 15556 2021-11-29 15:23:06Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_msk( k_top, k_bot ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_msk *** + !! + !! ** Purpose : Compute land/ocean mask arrays at tracer points, hori- + !! zontal velocity points (u & v), vorticity points (f) points. + !! + !! ** Method : The ocean/land mask at t-point is deduced from ko_top + !! and ko_bot, the indices of the fist and last ocean t-levels which + !! are either defined in usrdef_zgr or read in zgr_read. + !! The velocity masks (umask, vmask, wmask, wumask, wvmask) + !! are deduced from a product of the two neighboring tmask. + !! The vorticity mask (fmask) is deduced from tmask taking + !! into account the choice of lateral boundary condition (rn_shlat) : + !! rn_shlat = 0, free slip (no shear along the coast) + !! rn_shlat = 2, no slip (specified zero velocity at the coast) + !! 0 < rn_shlat < 2, partial slip | non-linear velocity profile + !! 2 < rn_shlat, strong slip | in the lateral boundary layer + !! + !! ** Action : tmask, umask, vmask, wmask, wumask, wvmask : land/ocean mask + !! at t-, u-, v- w, wu-, and wv-points (=0. or 1.) + !! fmask : land/ocean mask at f-point (=0., or =1., or + !! =rn_shlat along lateral boundaries) + !! ssmask , ssumask, ssvmask, ssfmask : 2D ocean mask, i.e. at least 1 wet cell in the vertical + !! tmask_i : ssmask * ( excludes halo+duplicated points (NP folding) ) + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(:,:), INTENT(in) :: k_top, k_bot ! first and last ocean level + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iktop, ikbot ! - - + INTEGER :: ios, inum + !! + NAMELIST/namlbc/ rn_shlat, ln_vorlat + NAMELIST/nambdy/ ln_bdy ,nb_bdy, ln_coords_file, cn_coords_file, & + & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & + & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, & + & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & + & cn_ice, nn_ice_dta, & + & ln_vol, nn_volctl, nn_rimwidth + !!--------------------------------------------------------------------- + ! + READ ( numnam_ref, namlbc, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlbc in reference namelist' ) + READ ( numnam_cfg, namlbc, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlbc in configuration namelist' ) + IF(lwm) WRITE ( numond, namlbc ) + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dommsk : ocean mask ' + WRITE(numout,*) '~~~~~~' + WRITE(numout,*) ' Namelist namlbc' + WRITE(numout,*) ' lateral momentum boundary cond. rn_shlat = ',rn_shlat + WRITE(numout,*) ' consistency with analytical form ln_vorlat = ',ln_vorlat + ENDIF + ! + IF(lwp) WRITE(numout,*) + IF ( rn_shlat == 0. ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral free-slip' + ELSEIF ( rn_shlat == 2. ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral no-slip' + ELSEIF ( 0. < rn_shlat .AND. rn_shlat < 2. ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral partial-slip' + ELSEIF ( 2. < rn_shlat ) THEN ; IF(lwp) WRITE(numout,*) ' ==>>> ocean lateral strong-slip' + ELSE + CALL ctl_stop( 'dom_msk: wrong value for rn_shlat (i.e. a negalive value). We stop.' ) + ENDIF + + ! Ocean/land mask at t-point (computed from ko_top and ko_bot) + ! ---------------------------- + ! + tmask(:,:,:) = 0._wp + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + iktop = k_top(ji,jj) + ikbot = k_bot(ji,jj) + IF( iktop /= 0 ) THEN ! water in the column + tmask(ji,jj,iktop:ikbot) = 1._wp + ENDIF + END_2D + ! + ! Mask corrections for bdy (read in mppini2) + READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' ) + READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist' ) + ! ------------------------ + IF ( ln_bdy .AND. ln_mask_file ) THEN + CALL iom_open( cn_mask_file, inum ) + CALL iom_get ( inum, jpdom_global, 'bdy_msk', bdytmask(:,:) ) + CALL iom_close( inum ) + DO_3D( 1, 1, 1, 1, 1, jpkm1 ) + tmask(ji,jj,jk) = tmask(ji,jj,jk) * bdytmask(ji,jj) + END_3D + ENDIF + + ! Ocean/land mask at u-, v-, and f-points (computed from tmask) + ! ---------------------------------------- + ! NB: at this point, fmask is designed for free slip lateral boundary condition + DO_3D( 0, 0, 0, 0, 1, jpk ) + umask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) + vmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji ,jj+1,jk) + fmask(ji,jj,jk) = tmask(ji,jj ,jk) * tmask(ji+1,jj ,jk) & + & * tmask(ji,jj+1,jk) * tmask(ji+1,jj+1,jk) + END_3D + ! + ! In case of a coarsened grid, account her for possibly aditionnal + ! masked points; these have been read in the mesh file and stored in mbku, mbkv, mbkf + DO_2D( 0, 0, 0, 0 ) + IF ( MAXVAL(umask(ji,jj,:))/=0._wp ) umask(ji,jj,mbku(ji,jj)+1:jpk) = 0._wp + IF ( MAXVAL(vmask(ji,jj,:))/=0._wp ) vmask(ji,jj,mbkv(ji,jj)+1:jpk) = 0._wp + IF ( MAXVAL(fmask(ji,jj,:))/=0._wp ) fmask(ji,jj,mbkf(ji,jj)+1:jpk) = 0._wp + END_2D + CALL lbc_lnk( 'dommsk', umask, 'U', 1.0_wp, vmask, 'V', 1.0_wp, fmask, 'F', 1.0_wp ) ! Lateral boundary conditions + + ! Ocean/land mask at wu-, wv- and w points (computed from tmask) + !----------------------------------------- + wmask (:,:,1) = tmask(:,:,1) ! surface + wumask(:,:,1) = umask(:,:,1) + wvmask(:,:,1) = vmask(:,:,1) + DO jk = 2, jpk ! interior values + wmask (:,:,jk) = tmask(:,:,jk) * tmask(:,:,jk-1) + wumask(:,:,jk) = umask(:,:,jk) * umask(:,:,jk-1) + wvmask(:,:,jk) = vmask(:,:,jk) * vmask(:,:,jk-1) + END DO + + ! Ocean/land column mask at t-, u-, and v-points (i.e. at least 1 wet cell in the vertical) + ! ---------------------------------------------- + ssmask (:,:) = MAXVAL( tmask(:,:,:), DIM=3 ) + ssumask(:,:) = MAXVAL( umask(:,:,:), DIM=3 ) + ssvmask(:,:) = MAXVAL( vmask(:,:,:), DIM=3 ) + ssfmask(:,:) = MAXVAL( fmask(:,:,:), DIM=3 ) + IF( lk_SWE ) THEN ! Shallow Water Eq. case : redefine ssfmask + DO_2D( 0, 0, 0, 0 ) + ssfmask(ji,jj) = MAX( ssmask(ji,jj+1), ssmask(ji+1,jj+1), & + & ssmask(ji,jj ), ssmask(ji+1,jj ) ) + END_2D + CALL lbc_lnk( 'dommsk', ssfmask, 'F', 1.0_wp ) + ENDIF + fe3mask(:,:,:) = fmask(:,:,:) + + ! Interior domain mask (used for global sum) : 2D ocean mask x (halo+duplicated points) mask + ! -------------------- + ! + CALL dom_uniq( tmask_i, 'T' ) + tmask_i(:,:) = ssmask(:,:) * tmask_i(:,:) + + ! Lateral boundary conditions on velocity (modify fmask) + ! --------------------------------------- + IF( rn_shlat /= 0._wp ) THEN ! Not free-slip lateral boundary condition + ! + DO_3D( 0, 0, 0, 0, 1, jpk ) + IF( fmask(ji,jj,jk) == 0._wp ) THEN + fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(ji,jj,jk), umask(ji,jj+1,jk), & + & vmask(ji,jj,jk), vmask(ji+1,jj,jk) ) ) + ENDIF + END_3D + CALL lbc_lnk( 'dommsk', fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask + ! + ! CAUTION : The fmask may be further modified in dyn_vor_init ( dynvor.F90 ) depending on ln_vorlat + ! + ENDIF + + ! User defined alteration of fmask (use to reduce ocean transport in specified straits) + ! -------------------------------- + ! + CALL usr_def_fmask( cn_cfg, nn_cfg, fmask ) + ! +#if defined key_agrif + ! Reset masks defining updated points over parent grids + ! = 1 : updated point from child(s) + ! = 0 : point not updated + ! + tmask_upd(:,:) = 0._wp + umask_upd(:,:) = 0._wp + vmask_upd(:,:) = 0._wp +#endif + ! + END SUBROUTINE dom_msk + + !!====================================================================== +END MODULE dommsk \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domqco.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domqco.F90 new file mode 100644 index 0000000..2588bda --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domqco.F90 @@ -0,0 +1,295 @@ +MODULE domqco + !!====================================================================== + !! *** MODULE domqco *** + !! Ocean : + !!====================================================================== + !! History : 2.0 ! 2006-06 (B. Levier, L. Marie) original code + !! 3.1 ! 2009-02 (G. Madec, M. Leclair, R. Benshila) pure z* coordinate + !! 3.3 ! 2011-10 (M. Leclair) totally rewrote domvvl: vvl option includes z_star and z_tilde coordinates + !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) add time level indices for prognostic variables + !! - ! 2020-02 (S. Techene, G. Madec) quasi-eulerian coordinate (z* or s*) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_qco_init : define initial vertical scale factors, depths and column thickness + !! dom_qco_zgr : Set ssh/h_0 ratio at t + !! dom_qco_r3c : Compute ssh/h_0 ratio at t-, u-, v-, and optionally f-points + !! qco_ctl : Check the vvl options + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE phycst ! physical constant + USE dom_oce ! ocean space and time domain + USE dynadv , ONLY : ln_dynadv_vec + USE isf_oce ! iceshelf cavities + USE sbc_oce ! ocean surface boundary condition + USE wet_dry ! wetting and drying + USE usrdef_istate ! user defined initial state (wad only) + USE restart ! ocean restart + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! distributed memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_qco_init ! called by domain.F90 + PUBLIC dom_qco_zgr ! called by isfcpl.F90 + PUBLIC dom_qco_r3c ! called by steplf.F90 + + ! !!* Namelist nam_vvl + LOGICAL , PUBLIC :: ln_vvl_zstar = .FALSE. ! zstar vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_ztilde = .FALSE. ! ztilde vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_layer = .FALSE. ! level vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_ztilde_as_zstar = .FALSE. ! ztilde vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_zstar_at_eqtor = .FALSE. ! ztilde vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_kepe = .FALSE. ! kinetic/potential energy transfer + ! ! conservation: not used yet + ! + INTEGER :: nn_vvl_interp = 0 ! scale factors anomaly interpolation method at U-V-F points + ! =0 linear with no bottom correction over steps (old) + ! =1 linear with bottom correction over steps + ! =2 "qco like", i.e. proportional to thicknesses at rest + ! + REAL(wp) :: rn_ahe3 ! thickness diffusion coefficient + REAL(wp) :: rn_rst_e3t ! ztilde to zstar restoration timescale [days] + REAL(wp) :: rn_lf_cutoff ! cutoff frequency for low-pass filter [days] + REAL(wp) :: rn_zdef_max ! maximum fractional e3t deformation + LOGICAL , PUBLIC :: ln_vvl_dbg = .FALSE. ! debug control prints + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domvvl.F90 12377 2020-02-12 14:39:06Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_qco_init( Kbb, Kmm, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_qco_init *** + !! + !! ** Purpose : Initialization of all ssh. to h._0 ratio + !! + !! ** Method : - use restart file and/or initialize + !! - compute ssh. to h._0 ratio + !! + !! ** Action : - r3(t/u/v)_b + !! - r3(t/u/v/f)_n + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! time level indices + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dom_qco_init : Variable volume activated' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ! + CALL qco_ctl ! choose vertical coordinate (z_star, z_tilde or layer) + ! + CALL dom_qco_zgr( Kbb, Kmm ) ! interpolation scale factor, depth and water column + ! +#if defined key_agrif + ! We need to define r3[tuv](Kaa) for AGRIF initialisation (should not be a + ! problem for the restartability...) + r3t(:,:,Kaa) = r3t(:,:,Kmm) + r3u(:,:,Kaa) = r3u(:,:,Kmm) + r3v(:,:,Kaa) = r3v(:,:,Kmm) +#endif + ! + END SUBROUTINE dom_qco_init + + + SUBROUTINE dom_qco_zgr( Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_qco_init *** + !! + !! ** Purpose : Initialization of all r3. = ssh./h._0 ratios + !! + !! ** Method : Call domqco using Kbb and Kmm + !! NB: dom_qco_zgr is called by dom_qco_init it uses ssh from ssh_init + !! + !! ** Action : - r3(t/u/v)(Kbb) + !! - r3(t/u/v/f)(Kmm) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm ! time level indices + !!---------------------------------------------------------------------- + ! + ! !== Set of all other vertical scale factors ==! (now and before) + ! ! Horizontal interpolation of e3t +#if defined key_RK3 + CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb), r3f(:,:) ) + CALL dom_qco_r3c( ssh(:,:,Kmm), r3t(:,:,Kmm), r3u(:,:,Kmm), r3v(:,:,Kmm) ) +#else + CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb) ) + CALL dom_qco_r3c( ssh(:,:,Kmm), r3t(:,:,Kmm), r3u(:,:,Kmm), r3v(:,:,Kmm), r3f(:,:) ) +#endif + ! dom_qco_r3c defines over [nn_hls, nn_hls-1, nn_hls, nn_hls-1] + IF( nn_hls == 2 ) CALL lbc_lnk( 'dom_qco_zgr', r3u(:,:,Kbb), 'U', 1._wp, r3v(:,:,Kbb), 'V', 1._wp, & + & r3u(:,:,Kmm), 'U', 1._wp, r3v(:,:,Kmm), 'V', 1._wp, r3f(:,:), 'F', 1._wp ) + ! ! r3f is needed for agrif + END SUBROUTINE dom_qco_zgr + + + SUBROUTINE dom_qco_r3c( pssh, pr3t, pr3u, pr3v, pr3f ) + !!--------------------------------------------------------------------- + !! *** ROUTINE r3c *** + !! + !! ** Purpose : compute the filtered ratio ssh/h_0 at t-,u-,v-,f-points + !! + !! ** Method : - compute the ssh at u- and v-points (f-point optional) + !! Vector Form : surface weighted averaging + !! Flux Form : simple averaging + !! - compute the ratio ssh/h_0 at t-,u-,v-pts, (f-pt optional) + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:) , INTENT(in ) :: pssh ! sea surface height [m] + REAL(wp), DIMENSION(:,:) , INTENT( out) :: pr3u, pr3v! ssh/h0 ratio at t-, u-, v-,points [-] + REAL(dp), DIMENSION(:,:) , INTENT( out) :: pr3t! ssh/h0 ratio at t-, u-, v-,points [-] + REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT( out) :: pr3f ! ssh/h0 ratio at f-point [-] + ! + INTEGER :: ji, jj ! dummy loop indices + !!---------------------------------------------------------------------- + ! + ! + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + pr3t(ji,jj) = pssh(ji,jj) * r1_ht_0(ji,jj) !== ratio at t-point ==! + END_2D + ! + ! + ! !== ratio at u-,v-point ==! + ! +!!st IF( ln_dynadv_vec ) THEN !- Vector Form (thickness weighted averaging) +#if ! defined key_qcoTest_FluxForm + ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average + DO_2D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + pr3u(ji,jj) = 0.5_wp * ( e1e2t(ji ,jj) * pssh(ji ,jj) & + & + e1e2t(ji+1,jj) * pssh(ji+1,jj) ) * r1_hu_0(ji,jj) * r1_e1e2u(ji,jj) + pr3v(ji,jj) = 0.5_wp * ( e1e2t(ji,jj ) * pssh(ji,jj ) & + & + e1e2t(ji,jj+1) * pssh(ji,jj+1) ) * r1_hv_0(ji,jj) * r1_e1e2v(ji,jj) + END_2D +!!st ELSE !- Flux Form (simple averaging) +#else + DO_2D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + pr3u(ji,jj) = 0.5_wp * ( pssh(ji,jj) + pssh(ji+1,jj ) ) * r1_hu_0(ji,jj) + pr3v(ji,jj) = 0.5_wp * ( pssh(ji,jj) + pssh(ji ,jj+1) ) * r1_hv_0(ji,jj) + END_2D +!!st ENDIF +#endif + ! + IF( .NOT.PRESENT( pr3f ) ) THEN !- lbc on ratio at u-, v-points only + IF (nn_hls==1) CALL lbc_lnk( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp ) + ! + ! + ELSE !== ratio at f-point ==! + ! +!!st IF( ln_dynadv_vec ) THEN !- Vector Form (thickness weighted averaging) +#if ! defined key_qcoTest_FluxForm + ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average + + DO_2D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + pr3f(ji,jj) = 0.25_wp * ( ( e1e2t(ji ,jj ) * pssh(ji ,jj ) & + & + e1e2t(ji+1,jj ) * pssh(ji+1,jj ) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( e1e2t(ji ,jj+1) * pssh(ji ,jj+1) & + & + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * r1_hf_0(ji,jj) * r1_e1e2f(ji,jj) + END_2D +!!st ELSE !- Flux Form (simple averaging) +#else + DO_2D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + pr3f(ji,jj) = 0.25_wp * ( ( pssh(ji,jj ) + pssh(ji+1,jj ) ) & + & + ( pssh(ji,jj+1) + pssh(ji+1,jj+1) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * r1_hf_0(ji,jj) + END_2D +!!st ENDIF +#endif + ! ! lbc on ratio at u-,v-,f-points + IF (nn_hls==1) CALL lbc_lnk( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp, pr3f, 'F', 1._wp ) + ! + ENDIF + ! + END SUBROUTINE dom_qco_r3c + + + SUBROUTINE qco_ctl + !!--------------------------------------------------------------------- + !! *** ROUTINE qco_ctl *** + !! + !! ** Purpose : Control the consistency between namelist options + !! for vertical coordinate + !!---------------------------------------------------------------------- + INTEGER :: ioptio, ios + !! + NAMELIST/nam_vvl/ ln_vvl_zstar, ln_vvl_ztilde, ln_vvl_layer, ln_vvl_ztilde_as_zstar, & + & ln_vvl_zstar_at_eqtor , rn_ahe3 , rn_rst_e3t , & + & rn_lf_cutoff , rn_zdef_max , ln_vvl_dbg , & ! not yet implemented: ln_vvl_kepe + & nn_vvl_interp + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_vvl in reference namelist' ) + READ ( numnam_cfg, nam_vvl, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_vvl in configuration namelist' ) + IF(lwm) WRITE ( numond, nam_vvl ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) + WRITE(numout,*) 'qco_ctl : choice/control of the variable vertical coordinate' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) ' Namelist nam_vvl : chose a vertical coordinate' + WRITE(numout,*) ' zstar ln_vvl_zstar = ', ln_vvl_zstar + WRITE(numout,*) ' ztilde ln_vvl_ztilde = ', ln_vvl_ztilde + WRITE(numout,*) ' layer ln_vvl_layer = ', ln_vvl_layer + WRITE(numout,*) ' ztilde as zstar ln_vvl_ztilde_as_zstar = ', ln_vvl_ztilde_as_zstar + WRITE(numout,*) ' ztilde near the equator ln_vvl_zstar_at_eqtor = ', ln_vvl_zstar_at_eqtor + WRITE(numout,*) ' !' + WRITE(numout,*) ' thickness diffusion coefficient rn_ahe3 = ', rn_ahe3 + WRITE(numout,*) ' maximum e3t deformation fractional change rn_zdef_max = ', rn_zdef_max + IF( ln_vvl_ztilde_as_zstar ) THEN + WRITE(numout,*) ' ztilde running in zstar emulation mode (ln_vvl_ztilde_as_zstar=T) ' + WRITE(numout,*) ' ignoring namelist timescale parameters and using:' + WRITE(numout,*) ' hard-wired : z-tilde to zstar restoration timescale (days)' + WRITE(numout,*) ' rn_rst_e3t = 0.e0' + WRITE(numout,*) ' hard-wired : z-tilde cutoff frequency of low-pass filter (days)' + WRITE(numout,*) ' rn_lf_cutoff = 1.0/rn_Dt' + ELSE + WRITE(numout,*) ' z-tilde to zstar restoration timescale (days) rn_rst_e3t = ', rn_rst_e3t + WRITE(numout,*) ' z-tilde cutoff frequency of low-pass filter (days) rn_lf_cutoff = ', rn_lf_cutoff + ENDIF + WRITE(numout,*) ' debug prints flag ln_vvl_dbg = ', ln_vvl_dbg + ENDIF + ! + ioptio = 0 ! Parameter control + IF( ln_vvl_ztilde_as_zstar ) ln_vvl_ztilde = .true. + IF( ln_vvl_zstar ) ioptio = ioptio + 1 + IF( ln_vvl_ztilde ) ioptio = ioptio + 1 + IF( ln_vvl_layer ) ioptio = ioptio + 1 + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE vertical coordinate in namelist nam_vvl' ) + ! + IF(lwp) THEN ! Print the choice + WRITE(numout,*) + IF( ln_vvl_zstar ) WRITE(numout,*) ' ==>>> zstar vertical coordinate is used' + IF( ln_vvl_ztilde ) WRITE(numout,*) ' ==>>> ztilde vertical coordinate is used' + IF( ln_vvl_layer ) WRITE(numout,*) ' ==>>> layer vertical coordinate is used' + IF( ln_vvl_ztilde_as_zstar ) WRITE(numout,*) ' ==>>> to emulate a zstar coordinate' + ENDIF + ! +#if defined key_agrif + IF( (.NOT.Agrif_Root()).AND.(.NOT.ln_vvl_zstar) ) CALL ctl_stop( 'AGRIF is implemented with zstar coordinate only' ) +#endif + ! + END SUBROUTINE qco_ctl + + !!====================================================================== +END MODULE domqco \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domtile.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domtile.F90 new file mode 100644 index 0000000..56abb21 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domtile.F90 @@ -0,0 +1,254 @@ +MODULE domtile + !!====================================================================== + !! *** MODULE domtile *** + !! Tiling utilities + !!====================================================================== + !! History : 4.2 ! 2020-12 (D. Calvert) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_tile : Set/initialise the current tile and domain indices + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + ! + USE prtctl ! Print control (prt_ctl_info routine) + USE lib_mpp , ONLY : ctl_stop, ctl_warn + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_tile ! called by step.F90 + PUBLIC dom_tile_start ! called by various + PUBLIC dom_tile_stop ! " " + PUBLIC dom_tile_init ! called by domain.F90 + + LOGICAL, ALLOCATABLE, DIMENSION(:) :: l_tilefin ! whether a tile is finished or not + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.2 , NEMO Consortium (2020) + !! $Id: domtile.F90 13982 2020-12-04 10:57:05Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_tile_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_tile_init *** + !! + !! ** Purpose : Initialise tile domain variables + !! + !! ** Action : - ntsi, ntsj : start of internal part of domain + !! - ntei, ntej : end of internal part of domain + !! - ntile : current tile number + !! - nijtile : total number of tiles + !! - nthl, nthr : modifier on DO loop macro bound offset (left, right) + !! - nthb, ntht : " " (bottom, top) + !! - l_istiled : whether tiling is currently active or not + !! - l_tilefin : whether a tile is finished or not + !!---------------------------------------------------------------------- + INTEGER :: jt ! dummy loop argument + INTEGER :: iitile, ijtile ! Local integers + !!---------------------------------------------------------------------- + IF( ln_tile .AND. nn_hls /= 2 ) CALL ctl_stop('dom_tile_init: Tiling is only supported for nn_hls = 2') + + ntile = 0 ! Initialise to full domain + nijtile = 1 + ntsi = Nis0 + ntsj = Njs0 + ntei = Nie0 + ntej = Nje0 + nthl = 0 + nthr = 0 + nthb = 0 + ntht = 0 + l_istiled = .FALSE. + + IF( ln_tile ) THEN ! Calculate tile domain indices + iitile = Ni_0 / nn_ltile_i ! Number of tiles + ijtile = Nj_0 / nn_ltile_j + IF( MOD( Ni_0, nn_ltile_i ) /= 0 ) iitile = iitile + 1 + IF( MOD( Nj_0, nn_ltile_j ) /= 0 ) ijtile = ijtile + 1 + + nijtile = iitile * ijtile + ALLOCATE( ntsi_a(0:nijtile), ntsj_a(0:nijtile), ntei_a(0:nijtile), ntej_a(0:nijtile), l_tilefin(nijtile) ) + + l_tilefin(:) = .FALSE. + + ntsi_a(0) = Nis0 ! Full domain + ntsj_a(0) = Njs0 + ntei_a(0) = Nie0 + ntej_a(0) = Nje0 + + DO jt = 1, nijtile ! Tile domains + ntsi_a(jt) = Nis0 + nn_ltile_i * MOD(jt - 1, iitile) + ntsj_a(jt) = Njs0 + nn_ltile_j * ((jt - 1) / iitile) + ntei_a(jt) = MIN(ntsi_a(jt) + nn_ltile_i - 1, Nie0) + ntej_a(jt) = MIN(ntsj_a(jt) + nn_ltile_j - 1, Nje0) + ENDDO + ENDIF + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dom_tile : Domain tiling decomposition' + WRITE(numout,*) '~~~~~~~~' + IF( ln_tile ) THEN + WRITE(numout,*) iitile, 'tiles in i' + WRITE(numout,*) ' Starting indices' + WRITE(numout,*) ' ', (ntsi_a(jt), jt=1, iitile) + WRITE(numout,*) ' Ending indices' + WRITE(numout,*) ' ', (ntei_a(jt), jt=1, iitile) + WRITE(numout,*) ijtile, 'tiles in j' + WRITE(numout,*) ' Starting indices' + WRITE(numout,*) ' ', (ntsj_a(jt), jt=1, nijtile, iitile) + WRITE(numout,*) ' Ending indices' + WRITE(numout,*) ' ', (ntej_a(jt), jt=1, nijtile, iitile) + ELSE + WRITE(numout,*) 'No domain tiling' + WRITE(numout,*) ' i indices =', ntsi, ':', ntei + WRITE(numout,*) ' j indices =', ntsj, ':', ntej + ENDIF + ENDIF + END SUBROUTINE dom_tile_init + + + SUBROUTINE dom_tile( ktsi, ktsj, ktei, ktej, ktile, ldhold, cstr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_tile *** + !! + !! ** Purpose : Set the current tile and its domain indices + !! + !! ** Action : - ktsi, ktsj : start of internal part of domain + !! - ktei, ktej : end of internal part of domain + !! - nthl, nthr : modifier on DO loop macro bound offset (left, right) + !! - nthb, ntht : " " (bottom, top) + !! - ktile : set the current tile number (ntile) + !!---------------------------------------------------------------------- + INTEGER, INTENT(out) :: ktsi, ktsj, ktei, ktej ! Tile domain indices + INTEGER, INTENT(in) :: ktile ! Tile number + LOGICAL, INTENT(in), OPTIONAL :: ldhold ! Pause/resume (.true.) or set (.false.) current tile + CHARACTER(len=*), INTENT(in), OPTIONAL :: cstr ! Debug information (added to warnings) + CHARACTER(len=23) :: clstr + LOGICAL :: llhold + CHARACTER(len=11) :: charout + INTEGER :: iitile + !!---------------------------------------------------------------------- + llhold = .FALSE. + IF( PRESENT(ldhold) ) llhold = ldhold + clstr = '' + IF( PRESENT(cstr) ) clstr = TRIM(' ('//TRIM(cstr)//')') + + IF( .NOT. ln_tile ) CALL ctl_stop('Cannot use dom_tile with ln_tile = .false.') + IF( .NOT. llhold ) THEN + IF( .NOT. l_istiled ) THEN + CALL ctl_warn('Cannot call dom_tile when tiling is inactive'//clstr) + RETURN + ENDIF + + IF( ntile /= 0 ) l_tilefin(ntile) = .TRUE. ! If setting a new tile, the current tile is complete + + ntile = ktile ! Set the new tile + IF(sn_cfctl%l_prtctl) THEN + WRITE(charout, FMT="('ntile =', I4)") ntile + CALL prt_ctl_info( charout ) + ENDIF + ENDIF + + ktsi = ntsi_a(ktile) ! Set the domain indices + ktsj = ntsj_a(ktile) + ktei = ntei_a(ktile) + ktej = ntej_a(ktile) + + ! Calculate the modifying factor on DO loop bounds (1 = do not work on points that have already been processed by a neighbouring tile) + nthl = 0 ; nthr = 0 ; nthb = 0 ; ntht = 0 + iitile = Ni_0 / nn_ltile_i + IF( MOD( Ni_0, nn_ltile_i ) /= 0 ) iitile = iitile + 1 + IF( ktsi > Nis0 ) THEN ; IF( l_tilefin(ktile - 1 ) ) nthl = 1 ; ENDIF ! Left adjacent tile + IF( ktei < Nie0 ) THEN ; IF( l_tilefin(ktile + 1 ) ) nthr = 1 ; ENDIF ! Right " " + IF( ktsj > Njs0 ) THEN ; IF( l_tilefin(ktile - iitile) ) nthb = 1 ; ENDIF ! Bottom " " + IF( ktej < Nje0 ) THEN ; IF( l_tilefin(ktile + iitile) ) ntht = 1 ; ENDIF ! Top " " + END SUBROUTINE dom_tile + + + SUBROUTINE dom_tile_start( ldhold, cstr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_tile_start *** + !! + !! ** Purpose : Start or resume the use of tiling + !! + !! ** Method : dom_tile_start & dom_tile_stop are used to declare a tiled region of code. + !! + !! Tiling is active/inactive (l_istiled = .true./.false.) within/outside of this code region. + !! After enabling tiling, no tile will initially be set (the full domain will be used) and dom_tile must + !! be called to set a specific tile to work on. Furthermore, all tiles will be marked as incomplete + !! (ln_tilefin(:) = .false.). + !! + !! Tiling can be paused/resumed within the tiled code region by calling dom_tile_stop/dom_tile_start + !! with ldhold = .true.. This can be used to temporarily revert back to using the full domain. + !! + !! CALL dom_tile_start ! Enable tiling + !! CALL dom_tile(ntsi, ntei, ntsj, ntej, ktile=n) ! Set current tile "n" + !! ... + !! CALL dom_tile_stop(.TRUE.) ! Pause tiling (temporarily disable) + !! ... + !! CALL dom_tile_start(.TRUE.) ! Resume tiling + !! CALL dom_tile_stop ! Disable tiling + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in), OPTIONAL :: ldhold ! Resume (.true.) or start (.false.) + LOGICAL :: llhold + CHARACTER(len=*), INTENT(in), OPTIONAL :: cstr ! Debug information (added to warnings) + CHARACTER(len=23) :: clstr + !!---------------------------------------------------------------------- + llhold = .FALSE. + IF( PRESENT(ldhold) ) llhold = ldhold + clstr = '' + IF( PRESENT(cstr) ) clstr = TRIM(' ('//TRIM(cstr)//')') + + IF( .NOT. ln_tile ) CALL ctl_stop('Cannot resume/start tiling as ln_tile = .false.') + IF( l_istiled ) THEN + CALL ctl_warn('Cannot resume/start tiling as it is already active'//clstr) + RETURN + ! TODO: [tiling] this warning will always be raised outside a tiling loop (cannot check for pause rather than stop) + ELSE IF( llhold .AND. ntile == 0 ) THEN + CALL ctl_warn('Cannot resume tiling as it is not paused'//clstr) + RETURN + ENDIF + + ! Whether resumed or started, the tiling is made active. If resumed, the domain indices for the current tile are used. + IF( llhold ) CALL dom_tile(ntsi, ntsj, ntei, ntej, ktile=ntile, ldhold=.TRUE., cstr='dom_tile_start'//clstr) + l_istiled = .TRUE. + END SUBROUTINE dom_tile_start + + + SUBROUTINE dom_tile_stop( ldhold, cstr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_tile_stop *** + !! + !! ** Purpose : End or pause the use of tiling + !! + !! ** Method : See dom_tile_start + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in), OPTIONAL :: ldhold ! Pause (.true.) or stop (.false.) + LOGICAL :: llhold + CHARACTER(len=*), INTENT(in), OPTIONAL :: cstr ! Debug information (added to warnings) + CHARACTER(len=23) :: clstr + !!---------------------------------------------------------------------- + llhold = .FALSE. + IF( PRESENT(ldhold) ) llhold = ldhold + clstr = '' + IF( PRESENT(cstr) ) clstr = TRIM(' ('//TRIM(cstr)//')') + + IF( .NOT. ln_tile ) CALL ctl_stop('Cannot pause/stop tiling as ln_tile = .false.') + IF( .NOT. l_istiled ) THEN + CALL ctl_warn('Cannot pause/stop tiling as it is inactive'//clstr) + RETURN + ENDIF + + ! Whether paused or stopped, the tiling is made inactive and the full domain indices are used. + ! If stopped, there is no active tile (ntile = 0) and the finished tile indicators are reset + CALL dom_tile(ntsi, ntsj, ntei, ntej, ktile=0, ldhold=llhold, cstr='dom_tile_stop'//clstr) + IF( .NOT. llhold ) l_tilefin(:) = .FALSE. + l_istiled = .FALSE. + END SUBROUTINE dom_tile_stop + !!====================================================================== +END MODULE domtile \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domutl.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domutl.F90 new file mode 100644 index 0000000..a3976e8 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domutl.F90 @@ -0,0 +1,183 @@ +MODULE domutl + !!====================================================================== + !! *** MODULE domutl *** + !! Grid utilities: + !!====================================================================== + !! History : 4.2 ! 2020-04 (S. Masson) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_ngb : find the closest grid point from a given lon/lat position + !! dom_uniq : identify unique point of a grid (TUVF) + !!---------------------------------------------------------------------- + ! + USE dom_oce ! ocean space and time domain + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! for mppsum + + IMPLICIT NONE + PRIVATE + + INTERFACE is_tile + MODULE PROCEDURE is_tile_2d_sp, is_tile_3d_sp, is_tile_4d_sp, is_tile_2d_dp, is_tile_3d_dp, is_tile_4d_dp + END INTERFACE is_tile + + PUBLIC dom_ngb ! routine called in iom.F90 module + PUBLIC dom_uniq ! Called by dommsk and domwri + PUBLIC is_tile + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.2 , NEMO Consortium (2020) + !! $Id: domutl.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_ngb( plon, plat, kii, kjj, cdgrid, kkk ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_ngb *** + !! + !! ** Purpose : find the closest grid point from a given lon/lat position + !! + !! ** Method : look for minimum distance in cylindrical projection + !! -> not good if located at too high latitude... + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: plon, plat ! longitude,latitude of the point + INTEGER , INTENT( out) :: kii, kjj ! i-,j-index of the closes grid point + INTEGER , INTENT(in ), OPTIONAL :: kkk ! k-index of the mask level used + CHARACTER(len=1), INTENT(in ) :: cdgrid ! grid name 'T', 'U', 'V', 'W' + ! + INTEGER :: ik ! working level + INTEGER , DIMENSION(2) :: iloc + REAL(wp) :: zlon, zmini + REAL(wp), DIMENSION(jpi,jpj) :: zglam, zgphi, zdist + LOGICAL , DIMENSION(jpi,jpj) :: llmsk + !!-------------------------------------------------------------------- + ! + ik = 1 + IF ( PRESENT(kkk) ) ik=kkk + ! + SELECT CASE( cdgrid ) + CASE( 'U' ) ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; llmsk(:,:) = tmask_i(:,:) * umask(:,:,ik) == 1._wp + CASE( 'V' ) ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; llmsk(:,:) = tmask_i(:,:) * vmask(:,:,ik) == 1._wp + CASE( 'F' ) ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; llmsk(:,:) = tmask_i(:,:) * fmask(:,:,ik) == 1._wp + CASE DEFAULT; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; llmsk(:,:) = tmask_i(:,:) * tmask(:,:,ik) == 1._wp + END SELECT + ! + zlon = MOD( plon + 720., 360. ) ! plon between 0 and 360 + zglam(:,:) = MOD( zglam(:,:) + 720., 360. ) ! glam between 0 and 360 + IF( zlon > 270. ) zlon = zlon - 360. ! zlon between -90 and 270 + IF( zlon < 90. ) WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360. ! glam between -180 and 180 + zglam(:,:) = zglam(:,:) - zlon + ! + zgphi(:,:) = zgphi(:,:) - plat + zdist(:,:) = zglam(:,:) * zglam(:,:) + zgphi(:,:) * zgphi(:,:) + ! + CALL mpp_minloc( 'domngb', REAL(zdist(:,:),dp), llmsk, zmini, iloc, ldhalo = .TRUE. ) + kii = iloc(1) + kjj = iloc(2) + ! + END SUBROUTINE dom_ngb + + + SUBROUTINE dom_uniq( puniq, cdgrd ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_uniq *** + !! + !! ** Purpose : identify unique point of a grid (TUVF) + !! + !! ** Method : 1) aplly lbc_lnk on an array with different values for each element + !! 2) check which elements have been changed + !!---------------------------------------------------------------------- + CHARACTER(len=1) , INTENT(in ) :: cdgrd ! + REAL(wp), DIMENSION(:,:), INTENT(inout) :: puniq ! + ! + REAL(wp) :: zshift ! shift value link to the process number + INTEGER :: ji ! dummy loop indices + LOGICAL , DIMENSION(jpi,jpj,1) :: lluniq ! store whether each point is unique or not + REAL(wp), DIMENSION(jpi,jpj ) :: ztstref + !!---------------------------------------------------------------------- + ! + ! build an array with different values for each element + ! in mpp: make sure that these values are different even between process + ! -> apply a shift value according to the process number + zshift = jpimax * jpjmax * ( narea - 1 ) + ztstref(:,:) = RESHAPE( (/ (zshift + REAL(ji,wp), ji = 1, jpi*jpj) /), (/ jpi, jpj /) ) + ! + puniq(:,:) = ztstref(:,:) ! default definition + CALL lbc_lnk( 'domwri', puniq, cdgrd, 1._wp ) ! apply boundary conditions + lluniq(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have not been changed + ! + puniq(:,:) = REAL( COUNT( lluniq(:,:,:), dim = 3 ), wp ) + ! + END SUBROUTINE dom_uniq + + + INTEGER FUNCTION is_tile_2d_sp( pt ) + REAL(sp), DIMENSION(:,:), INTENT(in) :: pt + + IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN + is_tile_2d_sp = 1 + ELSE + is_tile_2d_sp = 0 + ENDIF + END FUNCTION is_tile_2d_sp + + + INTEGER FUNCTION is_tile_2d_dp( pt ) + REAL(dp), DIMENSION(:,:), INTENT(in) :: pt + + IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN + is_tile_2d_dp = 1 + ELSE + is_tile_2d_dp = 0 + ENDIF + END FUNCTION is_tile_2d_dp + + + INTEGER FUNCTION is_tile_3d_sp( pt ) + REAL(sp), DIMENSION(:,:,:), INTENT(in) :: pt + + IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN + is_tile_3d_sp = 1 + ELSE + is_tile_3d_sp = 0 + ENDIF + END FUNCTION is_tile_3d_sp + + + INTEGER FUNCTION is_tile_3d_dp( pt ) + REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pt + + IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN + is_tile_3d_dp = 1 + ELSE + is_tile_3d_dp = 0 + ENDIF + END FUNCTION is_tile_3d_dp + + + INTEGER FUNCTION is_tile_4d_sp( pt ) + REAL(sp), DIMENSION(:,:,:,:), INTENT(in) :: pt + + IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN + is_tile_4d_sp = 1 + ELSE + is_tile_4d_sp = 0 + ENDIF + END FUNCTION is_tile_4d_sp + + + INTEGER FUNCTION is_tile_4d_dp( pt ) + REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: pt + + IF( l_istiled .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN + is_tile_4d_dp = 1 + ELSE + is_tile_4d_dp = 0 + ENDIF + END FUNCTION is_tile_4d_dp + !!====================================================================== +END MODULE domutl diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domvvl.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domvvl.F90 new file mode 100644 index 0000000..7dbd058 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domvvl.F90 @@ -0,0 +1,1105 @@ +MODULE domvvl + !!====================================================================== + !! *** MODULE domvvl *** + !! Ocean : + !!====================================================================== + !! History : 2.0 ! 2006-06 (B. Levier, L. Marie) original code + !! 3.1 ! 2009-02 (G. Madec, M. Leclair, R. Benshila) pure z* coordinate + !! 3.3 ! 2011-10 (M. Leclair) totally rewrote domvvl: vvl option includes z_star and z_tilde coordinates + !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename dom_vvl_sf_swp -> dom_vvl_sf_update for new timestepping + !! - ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio + !!---------------------------------------------------------------------- + + USE oce ! ocean dynamics and tracers + USE phycst ! physical constant + USE dom_oce ! ocean space and time domain + USE sbc_oce ! ocean surface boundary condition + USE wet_dry ! wetting and drying + USE usrdef_istate ! user defined initial state (wad only) + USE restart ! ocean restart + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! distributed memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + ! !!* Namelist nam_vvl + LOGICAL , PUBLIC :: ln_vvl_zstar = .FALSE. ! zstar vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_ztilde = .FALSE. ! ztilde vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_layer = .FALSE. ! level vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_ztilde_as_zstar = .FALSE. ! ztilde vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_zstar_at_eqtor = .FALSE. ! ztilde vertical coordinate + LOGICAL , PUBLIC :: ln_vvl_kepe = .FALSE. ! kinetic/potential energy transfer + ! + INTEGER :: nn_vvl_interp = 0 ! scale factors anomaly interpolation method at U-V-F points + ! =0 linear with no bottom correction over steps (old) + ! =1 linear with bottom correction over steps + ! =2 "qco like", i.e. proportional to thicknesses at rest + ! + ! ! conservation: not used yet + REAL(wp) :: rn_ahe3 ! thickness diffusion coefficient + REAL(wp) :: rn_rst_e3t ! ztilde to zstar restoration timescale [days] + REAL(wp) :: rn_lf_cutoff ! cutoff frequency for low-pass filter [days] + REAL(wp) :: rn_zdef_max ! maximum fractional e3t deformation + LOGICAL , PUBLIC :: ln_vvl_dbg = .FALSE. ! debug control prints + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: un_td, vn_td ! thickness diffusion transport + REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdiv_lf ! low frequency part of hz divergence + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_b, tilde_e3t_n ! baroclinic scale factors + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_a, dtilde_e3t_a ! baroclinic scale factors + REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_e3t ! retoring period for scale factors + REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_hdv ! retoring period for low freq. divergence + +#if defined key_qco || defined key_linssh + !!---------------------------------------------------------------------- + !! 'key_qco' Quasi-Eulerian vertical coordinate + !! OR EMPTY MODULE + !! 'key_linssh' Fix in time vertical coordinate + !!---------------------------------------------------------------------- +#else + !!---------------------------------------------------------------------- + !! Default key Old management of time varying vertical coordinate + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_vvl_init : define initial vertical scale factors, depths and column thickness + !! dom_vvl_sf_nxt : Compute next vertical scale factors + !! dom_vvl_sf_update : Swap vertical scale factors and update the vertical grid + !! dom_vvl_interpol : Interpolate vertical scale factors from one grid point to another + !! dom_vvl_rst : read/write restart file + !! dom_vvl_ctl : Check the vvl options + !!---------------------------------------------------------------------- + + PUBLIC dom_vvl_init ! called by domain.F90 + PUBLIC dom_vvl_zgr ! called by isfcpl.F90 + PUBLIC dom_vvl_sf_nxt ! called by step.F90 + PUBLIC dom_vvl_sf_update ! called by step.F90 + PUBLIC dom_vvl_interpol ! called by dynnxt.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domvvl.F90 15471 2021-11-04 16:28:56Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION dom_vvl_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION dom_vvl_alloc *** + !!---------------------------------------------------------------------- + IF( ln_vvl_zstar ) dom_vvl_alloc = 0 + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN + ALLOCATE( tilde_e3t_b(jpi,jpj,jpk) , tilde_e3t_n(jpi,jpj,jpk) , tilde_e3t_a(jpi,jpj,jpk) , & + & dtilde_e3t_a(jpi,jpj,jpk) , un_td (jpi,jpj,jpk) , vn_td (jpi,jpj,jpk) , & + & STAT = dom_vvl_alloc ) + CALL mpp_sum ( 'domvvl', dom_vvl_alloc ) + IF( dom_vvl_alloc /= 0 ) CALL ctl_stop( 'STOP', 'dom_vvl_alloc: failed to allocate arrays' ) + un_td = 0._wp + vn_td = 0._wp + ENDIF + IF( ln_vvl_ztilde ) THEN + ALLOCATE( frq_rst_e3t(jpi,jpj) , frq_rst_hdv(jpi,jpj) , hdiv_lf(jpi,jpj,jpk) , STAT= dom_vvl_alloc ) + CALL mpp_sum ( 'domvvl', dom_vvl_alloc ) + IF( dom_vvl_alloc /= 0 ) CALL ctl_stop( 'STOP', 'dom_vvl_alloc: failed to allocate arrays' ) + ENDIF + ! + END FUNCTION dom_vvl_alloc + + + SUBROUTINE dom_vvl_init( Kbb, Kmm, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_vvl_init *** + !! + !! ** Purpose : Initialization of all scale factors, depths + !! and water column heights + !! + !! ** Method : - use restart file and/or initialize + !! - interpolate scale factors + !! + !! ** Action : - e3t_(n/b) and tilde_e3t_(n/b) + !! - Regrid: e3[u/v](:,:,:,Kmm) + !! e3[u/v](:,:,:,Kmm) + !! e3w(:,:,:,Kmm) + !! e3[u/v]w_b + !! e3[u/v]w_n + !! gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w + !! - h(t/u/v)_0 + !! - frq_rst_e3t and frq_rst_hdv + !! + !! Reference : Leclair, M., and G. Madec, 2011, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dom_vvl_init : Variable volume activated' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ! + CALL dom_vvl_ctl ! choose vertical coordinate (z_star, z_tilde or layer) + ! + ! ! Allocate module arrays + IF( dom_vvl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dom_vvl_init : unable to allocate arrays' ) + ! + ! ! Read or initialize e3t_(b/n), tilde_e3t_(b/n) and hdiv_lf + CALL dom_vvl_rst( nit000, Kbb, Kmm, 'READ' ) + e3t(:,:,jpk,Kaa) = e3t_0(:,:,jpk) ! last level always inside the sea floor set one for all + ! + CALL dom_vvl_zgr(Kbb, Kmm, Kaa) ! interpolation scale factor, depth and water column + ! + END SUBROUTINE dom_vvl_init + + + SUBROUTINE dom_vvl_zgr(Kbb, Kmm, Kaa) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_vvl_init *** + !! + !! ** Purpose : Interpolation of all scale factors, + !! depths and water column heights + !! + !! ** Method : - interpolate scale factors + !! + !! ** Action : - e3t_(n/b) and tilde_e3t_(n/b) + !! - Regrid: e3(u/v)_n + !! e3(u/v)_b + !! e3w_n + !! e3(u/v)w_b + !! e3(u/v)w_n + !! gdept_n, gdepw_n and gde3w_n + !! - h(t/u/v)_0 + !! - frq_rst_e3t and frq_rst_hdv + !! + !! Reference : Leclair, M., and G. Madec, 2011, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk + INTEGER :: ii0, ii1, ij0, ij1 + REAL(wp):: zcoef + !!---------------------------------------------------------------------- + ! + ! !== Set of all other vertical scale factors ==! (now and before) + ! ! Horizontal interpolation of e3t + CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) ! from T to U + CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) + CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) ! from T to V + CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) + CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) ! from U to F + ! ! Vertical interpolation of e3t,u,v + CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) ! from T to W + CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3w (:,:,:,Kbb), 'W' ) + CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) ! from U to UW + CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) + CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) ! from V to UW + CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) + + ! We need to define e3[tuv]_a for AGRIF initialisation (should not be a problem for the restartability...) + e3t(:,:,:,Kaa) = e3t(:,:,:,Kmm) + e3u(:,:,:,Kaa) = e3u(:,:,:,Kmm) + e3v(:,:,:,Kaa) = e3v(:,:,:,Kmm) + ! + ! !== depth of t and w-point ==! (set the isf depth as it is in the initial timestep) + gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm) ! reference to the ocean surface (used for MLD and light penetration) + gdepw(:,:,1,Kmm) = 0.0_wp + gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm) ! reference to a common level z=0 for hpg + gdept(:,:,1,Kbb) = 0.5_wp * e3w(:,:,1,Kbb) + gdepw(:,:,1,Kbb) = 0.0_wp + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpk ) ! vertical sum + ! zcoef = tmask - wmask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt + ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) + ! ! 0.5 where jk = mikt +!!gm ??????? BUG ? gdept(:,:,:,Kmm) as well as gde3w does not include the thickness of ISF ?? + zcoef = ( tmask(ji,jj,jk) - wmask(ji,jj,jk) ) + gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm) + gdept(ji,jj,jk,Kmm) = zcoef * ( gdepw(ji,jj,jk ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm)) & + & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm)) + gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) + gdepw(ji,jj,jk,Kbb) = gdepw(ji,jj,jk-1,Kbb) + e3t(ji,jj,jk-1,Kbb) + gdept(ji,jj,jk,Kbb) = zcoef * ( gdepw(ji,jj,jk ,Kbb) + 0.5 * e3w(ji,jj,jk,Kbb)) & + & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kbb) + e3w(ji,jj,jk,Kbb)) + END_3D + ! + ! !== thickness of the water column !! (ocean portion only) + ht(:,:) = e3t(:,:,1,Kmm) * tmask(:,:,1) !!gm BUG : this should be 1/2 * e3w(k=1) .... + hu(:,:,Kbb) = e3u(:,:,1,Kbb) * umask(:,:,1) + hu(:,:,Kmm) = e3u(:,:,1,Kmm) * umask(:,:,1) + hv(:,:,Kbb) = e3v(:,:,1,Kbb) * vmask(:,:,1) + hv(:,:,Kmm) = e3v(:,:,1,Kmm) * vmask(:,:,1) + DO jk = 2, jpkm1 + ht(:,:) = ht(:,:) + e3t(:,:,jk,Kmm) * tmask(:,:,jk) + hu(:,:,Kbb) = hu(:,:,Kbb) + e3u(:,:,jk,Kbb) * umask(:,:,jk) + hu(:,:,Kmm) = hu(:,:,Kmm) + e3u(:,:,jk,Kmm) * umask(:,:,jk) + hv(:,:,Kbb) = hv(:,:,Kbb) + e3v(:,:,jk,Kbb) * vmask(:,:,jk) + hv(:,:,Kmm) = hv(:,:,Kmm) + e3v(:,:,jk,Kmm) * vmask(:,:,jk) + END DO + ! + ! !== inverse of water column thickness ==! (u- and v- points) + r1_hu(:,:,Kbb) = ssumask(:,:) / ( hu(:,:,Kbb) + 1._wp - ssumask(:,:) ) ! _i mask due to ISF + r1_hu(:,:,Kmm) = ssumask(:,:) / ( hu(:,:,Kmm) + 1._wp - ssumask(:,:) ) + r1_hv(:,:,Kbb) = ssvmask(:,:) / ( hv(:,:,Kbb) + 1._wp - ssvmask(:,:) ) + r1_hv(:,:,Kmm) = ssvmask(:,:) / ( hv(:,:,Kmm) + 1._wp - ssvmask(:,:) ) + + ! !== z_tilde coordinate case ==! (Restoring frequencies) + IF( ln_vvl_ztilde ) THEN +!!gm : idea: add here a READ in a file of custumized restoring frequency + ! ! Values in days provided via the namelist + ! ! use rsmall to avoid possible division by zero errors with faulty settings + frq_rst_e3t(:,:) = 2._wp * rpi / ( MAX( rn_rst_e3t , rsmall ) * 86400.0_wp ) + frq_rst_hdv(:,:) = 2._wp * rpi / ( MAX( rn_lf_cutoff, rsmall ) * 86400.0_wp ) + ! + IF( ln_vvl_ztilde_as_zstar ) THEN ! z-star emulation using z-tile + frq_rst_e3t(:,:) = 0._wp !Ignore namelist settings + frq_rst_hdv(:,:) = 1._wp / rn_Dt + ENDIF + IF ( ln_vvl_zstar_at_eqtor ) THEN ! use z-star in vicinity of the Equator + DO_2D( 1, 1, 1, 1 ) +!!gm case |gphi| >= 6 degrees is useless initialized just above by default + IF( ABS(gphit(ji,jj)) >= 6.) THEN + ! values outside the equatorial band and transition zone (ztilde) + frq_rst_e3t(ji,jj) = 2.0_wp * rpi / ( MAX( rn_rst_e3t , rsmall ) * 86400.e0_wp ) + frq_rst_hdv(ji,jj) = 2.0_wp * rpi / ( MAX( rn_lf_cutoff, rsmall ) * 86400.e0_wp ) + ELSEIF( ABS(gphit(ji,jj)) <= 2.5) THEN ! Equator strip ==> z-star + ! values inside the equatorial band (ztilde as zstar) + frq_rst_e3t(ji,jj) = 0.0_wp + frq_rst_hdv(ji,jj) = 1.0_wp / rn_Dt + ELSE ! transition band (2.5 to 6 degrees N/S) + ! ! (linearly transition from z-tilde to z-star) + frq_rst_e3t(ji,jj) = 0.0_wp + (frq_rst_e3t(ji,jj)-0.0_wp)*0.5_wp & + & * ( 1.0_wp - COS( rad*(ABS(gphit(ji,jj))-2.5_wp) & + & * 180._wp / 3.5_wp ) ) + frq_rst_hdv(ji,jj) = (1.0_wp / rn_Dt) & + & + ( frq_rst_hdv(ji,jj)-(1.e0_wp / rn_Dt) )*0.5_wp & + & * ( 1._wp - COS( rad*(ABS(gphit(ji,jj))-2.5_wp) & + & * 180._wp / 3.5_wp ) ) + ENDIF + END_2D + IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN + IF( nn_cfg == 3 ) THEN ! ORCA2: Suppress ztilde in the Foxe Basin for ORCA2 + ii0 = 103 + nn_hls - 1 ; ii1 = 111 + nn_hls - 1 + ij0 = 128 + nn_hls ; ij1 = 135 + nn_hls + frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.0_wp + frq_rst_hdv( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1.e0_wp / rn_Dt + ENDIF + ENDIF + ENDIF + ENDIF + ! + END SUBROUTINE dom_vvl_zgr + + + SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_vvl_sf_nxt *** + !! + !! ** Purpose : - compute the after scale factors used in tra_zdf, dynnxt, + !! tranxt and dynspg routines + !! + !! ** Method : - z_star case: Repartition of ssh INCREMENT proportionnaly to the level thickness. + !! - z_tilde_case: after scale factor increment = + !! high frequency part of horizontal divergence + !! + retsoring towards the background grid + !! + thickness difusion + !! Then repartition of ssh INCREMENT proportionnaly + !! to the "baroclinic" level thickness. + !! + !! ** Action : - hdiv_lf : restoring towards full baroclinic divergence in z_tilde case + !! - tilde_e3t_a: after increment of vertical scale factor + !! in z_tilde case + !! - e3(t/u/v)_a + !! + !! Reference : Leclair, M., and Madec, G. 2011, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! time step + INTEGER, INTENT( in ) :: Kbb, Kmm, Kaa ! time step + INTEGER, INTENT( in ), OPTIONAL :: kcall ! optional argument indicating call sequence + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER , DIMENSION(3) :: ijk_max, ijk_min ! temporary integers + REAL(wp) :: z_tmin, z_tmax ! local scalars + LOGICAL :: ll_do_bclinic ! local logical + REAL(wp), DIMENSION(jpi,jpj) :: zht, z_scale, zwu, zwv, zhdiv + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3t + LOGICAL , DIMENSION(:,:,:), ALLOCATABLE :: llmsk + !!---------------------------------------------------------------------- + ! + IF( ln_linssh ) RETURN ! No calculation in linear free surface + ! + IF( ln_timing ) CALL timing_start('dom_vvl_sf_nxt') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dom_vvl_sf_nxt : compute after scale factors' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' + ENDIF + + ll_do_bclinic = .TRUE. + IF( PRESENT(kcall) ) THEN + IF( kcall == 2 .AND. ln_vvl_ztilde ) ll_do_bclinic = .FALSE. + ENDIF + + ! ******************************* ! + ! After acale factors at t-points ! + ! ******************************* ! + ! ! --------------------------------------------- ! + ! ! z_star coordinate and barotropic z-tilde part ! + ! ! --------------------------------------------- ! + ! + z_scale(:,:) = ( ssh(:,:,Kaa) - ssh(:,:,Kbb) ) * ssmask(:,:) / ( ht_0(:,:) + ssh(:,:,Kmm) + 1. - ssmask(:,:) ) + DO jk = 1, jpkm1 + ! formally this is the same as e3t(:,:,:,Kaa) = e3t_0*(1+ssha/ht_0) + e3t(:,:,jk,Kaa) = e3t(:,:,jk,Kbb) + e3t(:,:,jk,Kmm) * z_scale(:,:) * tmask(:,:,jk) + END DO + ! + IF( (ln_vvl_ztilde .OR. ln_vvl_layer) .AND. ll_do_bclinic ) THEN ! z_tilde or layer coordinate ! + ! ! ------baroclinic part------ ! + ! I - initialization + ! ================== + + ! 1 - barotropic divergence + ! ------------------------- + zhdiv(:,:) = 0._wp + zht(:,:) = 0._wp + DO jk = 1, jpkm1 + zhdiv(:,:) = zhdiv(:,:) + e3t(:,:,jk,Kmm) * hdiv(:,:,jk) + zht (:,:) = zht (:,:) + e3t(:,:,jk,Kmm) * tmask(:,:,jk) + END DO + zhdiv(:,:) = zhdiv(:,:) / ( zht(:,:) + 1. - tmask_i(:,:) ) + + ! 2 - Low frequency baroclinic horizontal divergence (z-tilde case only) + ! -------------------------------------------------- + IF( ln_vvl_ztilde ) THEN + IF( kt > nit000 ) THEN + DO jk = 1, jpkm1 + hdiv_lf(:,:,jk) = hdiv_lf(:,:,jk) - rn_Dt * frq_rst_hdv(:,:) & + & * ( hdiv_lf(:,:,jk) - e3t(:,:,jk,Kmm) * ( hdiv(:,:,jk) - zhdiv(:,:) ) ) + END DO + ENDIF + ENDIF + + ! II - after z_tilde increments of vertical scale factors + ! ======================================================= + tilde_e3t_a(:,:,:) = 0._wp ! tilde_e3t_a used to store tendency terms + + ! 1 - High frequency divergence term + ! ---------------------------------- + IF( ln_vvl_ztilde ) THEN ! z_tilde case + DO jk = 1, jpkm1 + tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - ( e3t(:,:,jk,Kmm) * ( hdiv(:,:,jk) - zhdiv(:,:) ) - hdiv_lf(:,:,jk) ) + END DO + ELSE ! layer case + DO jk = 1, jpkm1 + tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - e3t(:,:,jk,Kmm) * ( hdiv(:,:,jk) - zhdiv(:,:) ) * tmask(:,:,jk) + END DO + ENDIF + + ! 2 - Restoring term (z-tilde case only) + ! ------------------ + IF( ln_vvl_ztilde ) THEN + DO jk = 1, jpk + tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - frq_rst_e3t(:,:) * tilde_e3t_b(:,:,jk) + END DO + ENDIF + + ! 3 - Thickness diffusion term + ! ---------------------------- + zwu(:,:) = 0._wp + zwv(:,:) = 0._wp + DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) ! a - first derivative: diffusive fluxes + un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * e2_e1u(ji,jj) & + & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj ,jk) ) + vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * e1_e2v(ji,jj) & + & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji ,jj+1,jk) ) + zwu(ji,jj) = zwu(ji,jj) + un_td(ji,jj,jk) + zwv(ji,jj) = zwv(ji,jj) + vn_td(ji,jj,jk) + END_3D + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) ! b - correction for last oceanic u-v points + un_td(ji,jj,mbku(ji,jj)) = un_td(ji,jj,mbku(ji,jj)) - zwu(ji,jj) + vn_td(ji,jj,mbkv(ji,jj)) = vn_td(ji,jj,mbkv(ji,jj)) - zwv(ji,jj) + END_2D + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! c - second derivative: divergence of diffusive fluxes + tilde_e3t_a(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) + ( un_td(ji-1,jj ,jk) - un_td(ji,jj,jk) & + & + vn_td(ji ,jj-1,jk) - vn_td(ji,jj,jk) & + & ) * r1_e1e2t(ji,jj) + END_3D + ! ! d - thickness diffusion transport: boundary conditions + ! (stored for tracer advction and continuity equation) + IF( nn_hls == 1 ) CALL lbc_lnk( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) + ! 4 - Time stepping of baroclinic scale factors + ! --------------------------------------------- + CALL lbc_lnk( 'domvvl', tilde_e3t_a(:,:,:), 'T', 1._wp ) + tilde_e3t_a(:,:,:) = tilde_e3t_b(:,:,:) + rDt * tmask(:,:,:) * tilde_e3t_a(:,:,:) + + ! Maximum deformation control + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ALLOCATE( ze3t(jpi,jpj,jpk), llmsk(jpi,jpj,jpk) ) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + ze3t(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) / e3t_0(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) + END_3D + ! + llmsk( 1:nn_hls,:,:) = .FALSE. ! exclude halos from the checked region + llmsk(Nie0+1: jpi,:,:) = .FALSE. + llmsk(:, 1:nn_hls,:) = .FALSE. + llmsk(:,Nje0+1: jpj,:) = .FALSE. + ! + llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + z_tmax = MAXVAL( ze3t(:,:,:), mask = llmsk ) ; CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + z_tmin = MINVAL( ze3t(:,:,:), mask = llmsk ) ; CALL mpp_min( 'domvvl', z_tmin ) ! min over the global domain + ! - ML - test: for the moment, stop simulation for too large e3_t variations + IF( ( z_tmax > rn_zdef_max ) .OR. ( z_tmin < - rn_zdef_max ) ) THEN + CALL mpp_maxloc( 'domvvl', ze3t, llmsk, z_tmax, ijk_max ) + CALL mpp_minloc( 'domvvl', ze3t, llmsk, z_tmin, ijk_min ) + IF (lwp) THEN + WRITE(numout, *) 'MAX( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmax + WRITE(numout, *) 'at i, j, k=', ijk_max + WRITE(numout, *) 'MIN( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmin + WRITE(numout, *) 'at i, j, k=', ijk_min + CALL ctl_stop( 'STOP', 'MAX( ABS( tilde_e3t_a(:,:,: ) ) / e3t_0(:,:,:) ) too high') + ENDIF + ENDIF + DEALLOCATE( ze3t, llmsk ) + ! - ML - end test + ! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below + tilde_e3t_a(:,:,:) = MIN( tilde_e3t_a(:,:,:), rn_zdef_max * e3t_0(:,:,:) ) + tilde_e3t_a(:,:,:) = MAX( tilde_e3t_a(:,:,:), - rn_zdef_max * e3t_0(:,:,:) ) + + ! + ! "tilda" change in the after scale factor + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + DO jk = 1, jpkm1 + dtilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - tilde_e3t_b(:,:,jk) + END DO + ! III - Barotropic repartition of the sea surface height over the baroclinic profile + ! ================================================================================== + ! add ( ssh increment + "baroclinicity error" ) proportionly to e3t(n) + ! - ML - baroclinicity error should be better treated in the future + ! i.e. locally and not spread over the water column. + ! (keep in mind that the idea is to reduce Eulerian velocity as much as possible) + zht(:,:) = 0. + DO jk = 1, jpkm1 + zht(:,:) = zht(:,:) + tilde_e3t_a(:,:,jk) * tmask(:,:,jk) + END DO + z_scale(:,:) = - zht(:,:) / ( ht_0(:,:) + ssh(:,:,Kmm) + 1. - ssmask(:,:) ) + DO jk = 1, jpkm1 + dtilde_e3t_a(:,:,jk) = dtilde_e3t_a(:,:,jk) + e3t(:,:,jk,Kmm) * z_scale(:,:) * tmask(:,:,jk) + END DO + + ENDIF + + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde or layer coordinate ! + ! ! ---baroclinic part--------- ! + DO jk = 1, jpkm1 + e3t(:,:,jk,Kaa) = e3t(:,:,jk,Kaa) + dtilde_e3t_a(:,:,jk) * tmask(:,:,jk) + END DO + ENDIF + + IF( ln_vvl_dbg .AND. .NOT. ll_do_bclinic ) THEN ! - ML - test: control prints for debuging + ! + IF( lwp ) WRITE(numout, *) 'kt =', kt + IF ( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN + z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( zht(:,:) ) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(SUM(tilde_e3t_a))) =', z_tmax + END IF + ! + zht(:,:) = 0.0_wp + DO jk = 1, jpkm1 + zht(:,:) = zht(:,:) + e3t(:,:,jk,Kmm) * tmask(:,:,jk) + END DO + z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + ssh(:,:,Kmm) - zht(:,:) ) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+sshn-SUM(e3t(:,:,:,Kmm)))) =', z_tmax + ! + zht(:,:) = 0.0_wp + DO jk = 1, jpkm1 + zht(:,:) = zht(:,:) + e3t(:,:,jk,Kaa) * tmask(:,:,jk) + END DO + z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + ssh(:,:,Kaa) - zht(:,:) ) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+ssha-SUM(e3t(:,:,:,Kaa)))) =', z_tmax + ! + zht(:,:) = 0.0_wp + DO jk = 1, jpkm1 + zht(:,:) = zht(:,:) + e3t(:,:,jk,Kbb) * tmask(:,:,jk) + END DO + z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + ssh(:,:,Kbb) - zht(:,:) ) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+sshb-SUM(e3t(:,:,:,Kbb)))) =', z_tmax + ! + z_tmax = MAXVAL( tmask(:,:,1) * ABS( ssh(:,:,Kbb) ) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ssh(:,:,Kbb)))) =', z_tmax + ! + z_tmax = MAXVAL( tmask(:,:,1) * ABS( ssh(:,:,Kmm) ) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ssh(:,:,Kmm)))) =', z_tmax + ! + z_tmax = MAXVAL( tmask(:,:,1) * ABS( ssh(:,:,Kaa) ) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ssh(:,:,Kaa)))) =', z_tmax + END IF + +#if defined key_agrif + ! *********************************** ! + ! After scale factors at w- points ! + ! *********************************** ! + ! At some point, "after" depths at T-points may be required + ! for AGRIF vertical remap. To prevent from saving an + ! additional array, re-compute depths from e3w when needed + CALL dom_vvl_interpol( e3t(:,:,:,Kaa), e3w(:,:,:,Kaa), 'W' ) +#endif + ! *********************************** ! + ! After scale factors at u- v- points ! + ! *********************************** ! + + CALL dom_vvl_interpol( e3t(:,:,:,Kaa), e3u(:,:,:,Kaa), 'U' ) + CALL dom_vvl_interpol( e3t(:,:,:,Kaa), e3v(:,:,:,Kaa), 'V' ) + + ! *********************************** ! + ! After depths at u- v points ! + ! *********************************** ! + + hu(:,:,Kaa) = e3u(:,:,1,Kaa) * umask(:,:,1) + hv(:,:,Kaa) = e3v(:,:,1,Kaa) * vmask(:,:,1) + DO jk = 2, jpkm1 + hu(:,:,Kaa) = hu(:,:,Kaa) + e3u(:,:,jk,Kaa) * umask(:,:,jk) + hv(:,:,Kaa) = hv(:,:,Kaa) + e3v(:,:,jk,Kaa) * vmask(:,:,jk) + END DO + ! ! Inverse of the local depth +!!gm BUG ? don't understand the use of umask_i here ..... + r1_hu(:,:,Kaa) = ssumask(:,:) / ( hu(:,:,Kaa) + 1._wp - ssumask(:,:) ) + r1_hv(:,:,Kaa) = ssvmask(:,:) / ( hv(:,:,Kaa) + 1._wp - ssvmask(:,:) ) + ! + IF( ln_timing ) CALL timing_stop('dom_vvl_sf_nxt') + ! + END SUBROUTINE dom_vvl_sf_nxt + + + SUBROUTINE dom_vvl_sf_update( kt, Kbb, Kmm, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_vvl_sf_update *** + !! + !! ** Purpose : for z tilde case: compute time filter and swap of scale factors + !! compute all depths and related variables for next time step + !! write outputs and restart file + !! + !! ** Method : - swap of e3t with trick for volume/tracer conservation (ONLY FOR Z TILDE CASE) + !! - reconstruct scale factor at other grid points (interpolate) + !! - recompute depths and water height fields + !! + !! ** Action : - tilde_e3t_(b/n) ready for next time step + !! - Recompute: + !! e3(u/v)_b + !! e3w(:,:,:,Kmm) + !! e3(u/v)w_b + !! e3(u/v)w_n + !! gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w + !! h(u/v) and h(u/v)r + !! + !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. + !! Leclair, M., and G. Madec, 2011, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! time step + INTEGER, INTENT( in ) :: Kbb, Kmm, Kaa ! time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcoef ! local scalar + !!---------------------------------------------------------------------- + ! + IF( ln_linssh ) RETURN ! No calculation in linear free surface + ! + IF( ln_timing ) CALL timing_start('dom_vvl_sf_update') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dom_vvl_sf_update : - interpolate scale factors and compute depths for next time step' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~' + ENDIF + ! + ! Time filter and swap of scale factors + ! ===================================== + ! - ML - e3(t/u/v)_b are allready computed in dynnxt. + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN + IF( l_1st_euler ) THEN + tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) + ELSE + tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & + & + rn_atfp * ( tilde_e3t_b(:,:,:) - 2.0_wp * tilde_e3t_n(:,:,:) + tilde_e3t_a(:,:,:) ) + ENDIF + tilde_e3t_n(:,:,:) = tilde_e3t_a(:,:,:) + ENDIF + + ! Compute all missing vertical scale factor and depths + ! ==================================================== + ! Horizontal scale factor interpolations + ! -------------------------------------- + ! - ML - e3u(:,:,:,Kbb) and e3v(:,:,:,Kbb) are already computed in dynnxt + ! - JC - hu(:,:,:,Kbb), hv(:,:,:,:,Kbb), hur_b, hvr_b also + + CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) + + ! Vertical scale factor interpolations + CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w(:,:,:,Kmm), 'W' ) + CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) + CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) + CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3w(:,:,:,Kbb), 'W' ) + CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) + CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) + + ! t- and w- points depth (set the isf depth as it is in the initial step) + gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm) + gdepw(:,:,1,Kmm) = 0.0_wp + gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm) + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpk ) + ! zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt + ! 1 for jk = mikt + zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) + gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm) + gdept(ji,jj,jk,Kmm) = zcoef * ( gdepw(ji,jj,jk ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm) ) & + & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm) ) + gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) + END_3D + + ! Local depth and Inverse of the local depth of the water + ! ------------------------------------------------------- + ! + ht(:,:) = e3t(:,:,1,Kmm) * tmask(:,:,1) + DO jk = 2, jpkm1 + ht(:,:) = ht(:,:) + e3t(:,:,jk,Kmm) * tmask(:,:,jk) + END DO + + ! write restart file + ! ================== + IF( lrst_oce ) CALL dom_vvl_rst( kt, Kbb, Kmm, 'WRITE' ) + ! + IF( ln_timing ) CALL timing_stop('dom_vvl_sf_update') + ! + END SUBROUTINE dom_vvl_sf_update + + + SUBROUTINE dom_vvl_interpol( pe3_in, pe3_out, pout ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_vvl__interpol *** + !! + !! ** Purpose : interpolate scale factors from one grid point to another + !! + !! ** Method : e3_out = e3_0 + interpolation(e3_in - e3_0) + !! - horizontal interpolation: grid cell surface averaging + !! - vertical interpolation: simple averaging + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3_in ! input e3 to be interpolated + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3_out ! output interpolated e3 + CHARACTER(LEN=*) , INTENT(in ) :: pout ! grid point of out scale factors + ! ! = 'U', 'V', 'W, 'F', 'UW' or 'VW' + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iku, ikum1, ikv, ikvm1, ikf, ikfm1 + REAL(wp) :: zlnwd ! =1./0. when ln_wd_il = T/F + REAL(wp), DIMENSION(jpi,jpj) :: zssh ! work array to retrieve ssh (nn_vvl_interp > 1) + !!---------------------------------------------------------------------- + ! + IF(ln_wd_il) THEN + zlnwd = 1.0_wp + ELSE + zlnwd = 0.0_wp + END IF + ! + SELECT CASE ( pout ) !== type of interpolation ==! + ! + CASE( 'U' ) !* from T- to U-point : hor. surface weighted mean + SELECT CASE ( nn_vvl_interp ) + CASE ( 0 ) + ! + DO_3D( 1, 0, 1, 0, 1, jpk ) + pe3_out(ji,jj,jk) = 0.5_wp * ( umask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2u(ji,jj) & + & * ( e1e2t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & + & + e1e2t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) ) + END_3D + ! + CASE ( 1 ) + ! + DO_3D( 1, 0, 1, 0, 1, jpk ) + pe3_out(ji,jj,jk) = 0.5_wp * ( umask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2u(ji,jj) & + & * ( e1e2t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & + & + e1e2t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) ) + END_3D + ! + ! Bottom correction: + DO_2D( 1, 0, 1, 0 ) + iku = mbku(ji ,jj) + ikum1 = iku - 1 + pe3_out(ji,jj,iku) = ( umask(ji,jj,iku) * (1.0_wp - zlnwd) + zlnwd ) & + & * ( 0.5_wp * r1_e1e2u(ji,jj) & + & * ( e1e2t(ji ,jj) * ( SUM(tmask(ji ,jj,:)*(pe3_in(ji ,jj,:) - e3t_0(ji ,jj,:))) ) & + & + e1e2t(ji+1,jj) * ( SUM(tmask(ji+1,jj,:)*(pe3_in(ji+1,jj,:) - e3t_0(ji+1,jj,:))) ) ) & + & - SUM(pe3_out(ji,jj,1:ikum1))) + END_2D + ! + CASE ( 2 ) + zssh(:,:) = SUM(tmask(:,:,:)*(pe3_in(:,:,:)-e3t_0(:,:,:)), DIM=3) + ! + DO_3D( 1, 0, 1, 0, 1, jpk ) + pe3_out(ji,jj,jk) = 0.5_wp * ( umask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2u(ji,jj) & + & * ( e1e2t(ji ,jj) * zssh(ji ,jj) + e1e2t(ji+1,jj) * zssh(ji+1,jj)) & + & * e3u_0(ji,jj,jk) / ( hu_0(ji,jj) + 1._wp - ssumask(ji,jj) ) + END_3D + ! + END SELECT + ! + CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'U', 1._wp ) + pe3_out(:,:,:) = pe3_out(:,:,:) + e3u_0(:,:,:) + ! + CASE( 'V' ) !* from T- to V-point : hor. surface weighted mean + SELECT CASE ( nn_vvl_interp ) + CASE ( 0 ) + ! + DO_3D( 1, 0, 1, 0, 1, jpk ) + pe3_out(ji,jj,jk) = 0.5_wp * ( vmask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2v(ji,jj) & + & * ( e1e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) & + & + e1e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) ) + END_3D + ! + CASE ( 1 ) + ! + DO_3D( 1, 0, 1, 0, 1, jpk ) + pe3_out(ji,jj,jk) = 0.5_wp * ( vmask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2v(ji,jj) & + & * ( e1e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) & + & + e1e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) ) + END_3D + ! + ! Bottom correction: + DO_2D( 1, 0, 1, 0 ) + ikv = mbkv(ji ,jj) + ikvm1 = ikv - 1 + pe3_out(ji,jj,ikv) = ( vmask(ji,jj,ikv) * (1.0_wp - zlnwd) + zlnwd ) & + & * ( 0.5_wp * r1_e1e2v(ji,jj) & + & * ( e1e2t(ji,jj ) * ( SUM(tmask(ji,jj ,:)*(pe3_in(ji,jj ,:) - e3t_0(ji,jj ,:))) ) & + & + e1e2t(ji,jj+1) * ( SUM(tmask(ji,jj+1,:)*(pe3_in(ji,jj+1,:) - e3t_0(ji,jj+1,:))) ) ) & + & - SUM(pe3_out(ji,jj,1:ikvm1))) + END_2D + ! + CASE ( 2 ) + zssh(:,:) = SUM(tmask(:,:,:)*(pe3_in(:,:,:)-e3t_0(:,:,:)), DIM=3) + ! + DO_3D( 1, 0, 1, 0, 1, jpk ) + pe3_out(ji,jj,jk) = 0.5_wp * ( vmask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2v(ji,jj) & + & * ( e1e2t(ji ,jj) * zssh(ji ,jj) + e1e2t(ji,jj+1) * zssh(ji,jj+1)) & + & * e3v_0(ji,jj,jk) / ( hv_0(ji,jj) + 1._wp - ssvmask(ji,jj) ) + END_3D + ! + END SELECT + ! + CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'V', 1._wp ) + pe3_out(:,:,:) = pe3_out(:,:,:) + e3v_0(:,:,:) + ! + CASE( 'F' ) !* from U-point to F-point : hor. surface weighted mean + SELECT CASE ( nn_vvl_interp ) + CASE ( 0 ) + ! + DO_3D( 0, 0, 0, 0, 1, jpk ) + pe3_out(ji,jj,jk) = 0.5_wp * ( umask(ji,jj,jk) * umask(ji,jj+1,jk) * (1.0_wp - zlnwd) + zlnwd ) & + & * r1_e1e2f(ji,jj) & + & * ( e1e2u(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3u_0(ji,jj ,jk) ) & + & + e1e2u(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3u_0(ji,jj+1,jk) ) ) + END_3D + ! + CASE ( 1 ) + ! + DO_3D( 0, 0, 0, 0, 1, jpk ) + pe3_out(ji,jj,jk) = 0.5_wp * ( umask(ji,jj,jk) * umask(ji,jj+1,jk) * (1.0_wp - zlnwd) + zlnwd ) & + & * r1_e1e2f(ji,jj) & + & * ( e1e2u(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3u_0(ji,jj ,jk) ) & + & + e1e2u(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3u_0(ji,jj+1,jk) ) ) + END_3D + ! + ! Bottom correction: + DO_2D( 0, 0, 0, 0 ) + ikf = MIN(mbku(ji ,jj),mbku(ji,jj+1)) + ikfm1 = ikf - 1 + pe3_out(ji,jj,ikf) = ( umask(ji,jj,ikf) * umask(ji,jj+1,ikf) * (1.0_wp - zlnwd) + zlnwd ) & + & * ( 0.5_wp * r1_e1e2f(ji,jj) & + & * ( e1e2u(ji,jj ) * ( SUM(umask(ji,jj ,:)*(pe3_in(ji,jj ,:) - e3u_0(ji,jj ,:))) ) & + & + e1e2u(ji,jj+1) * ( SUM(umask(ji,jj+1,:)*(pe3_in(ji,jj+1,:) - e3u_0(ji,jj+1,:))) ) ) & + & - SUM(pe3_out(ji,jj,1:ikfm1))) + END_2D + ! + CASE ( 2 ) + zssh(:,:) = SUM(umask(:,:,:)*(pe3_in(:,:,:)-e3u_0(:,:,:)), DIM=3) + ! + DO_3D( 0, 0, 0, 0, 1, jpk ) + pe3_out(ji,jj,jk) = ( umask(ji,jj,jk)* umask(ji,jj+1,jk) * (1.0_wp - zlnwd) + zlnwd ) & + & * 0.5_wp * r1_e1e2f(ji,jj) & + & * (e1e2u(ji ,jj) * zssh(ji ,jj) + e1e2u(ji,jj+1) * zssh(ji,jj+1)) & + & * e3f_0(ji,jj,jk) / ( hf_0(ji,jj) + 1._wp - ssumask(ji,jj)*ssumask(ji,jj+1) ) + END_3D + ! + END SELECT + ! + CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'F', 1._wp ) + pe3_out(:,:,:) = pe3_out(:,:,:) + e3f_0(:,:,:) + ! + CASE( 'W' ) !* from T- to W-point : vertical simple mean + ! + pe3_out(:,:,1) = e3w_0(:,:,1) + pe3_in(:,:,1) - e3t_0(:,:,1) + ! - ML - The use of mask in this formulea enables the special treatment of the last w-point without indirect adressing +!!gm BUG? use here wmask in case of ISF ? to be checked + DO jk = 2, jpk + pe3_out(:,:,jk) = e3w_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( tmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) ) & + & * ( pe3_in(:,:,jk-1) - e3t_0(:,:,jk-1) ) & + & + 0.5_wp * ( tmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) & + & * ( pe3_in(:,:,jk ) - e3t_0(:,:,jk ) ) + END DO + ! + CASE( 'UW' ) !* from U- to UW-point : vertical simple mean + ! + pe3_out(:,:,1) = e3uw_0(:,:,1) + pe3_in(:,:,1) - e3u_0(:,:,1) + ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing +!!gm BUG? use here wumask in case of ISF ? to be checked + DO jk = 2, jpk + pe3_out(:,:,jk) = e3uw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( umask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) ) & + & * ( pe3_in(:,:,jk-1) - e3u_0(:,:,jk-1) ) & + & + 0.5_wp * ( umask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) & + & * ( pe3_in(:,:,jk ) - e3u_0(:,:,jk ) ) + END DO + ! + CASE( 'VW' ) !* from V- to VW-point : vertical simple mean + ! + pe3_out(:,:,1) = e3vw_0(:,:,1) + pe3_in(:,:,1) - e3v_0(:,:,1) + ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing +!!gm BUG? use here wvmask in case of ISF ? to be checked + DO jk = 2, jpk + pe3_out(:,:,jk) = e3vw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( vmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) ) & + & * ( pe3_in(:,:,jk-1) - e3v_0(:,:,jk-1) ) & + & + 0.5_wp * ( vmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) & + & * ( pe3_in(:,:,jk ) - e3v_0(:,:,jk ) ) + END DO + END SELECT + ! + END SUBROUTINE dom_vvl_interpol + + + SUBROUTINE dom_vvl_rst( kt, Kbb, Kmm, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_vvl_rst *** + !! + !! ** Purpose : Read or write VVL file in restart file + !! + !! ** Method : * restart comes from a linear ssh simulation : + !! an attempt to read e3t_n stops simulation + !! * restart comes from a z-star, z-tilde, or layer : + !! read e3t_n and e3t_b + !! * restart comes from a z-star : + !! set tilde_e3t_n, tilde_e3t_n, and hdiv_lf to 0 + !! * restart comes from layer : + !! read tilde_e3t_n and tilde_e3t_b + !! set hdiv_lf to 0 + !! * restart comes from a z-tilde: + !! read tilde_e3t_n, tilde_e3t_b, and hdiv_lf + !! + !! NB: if l_1st_euler = T (ln_1st_euler or ssh_b not found) + !! Kbb fields set to Kmm ones + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: Kbb, Kmm ! ocean time level indices + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: id2, id3, id4, id5 ! local integers + !!---------------------------------------------------------------------- + ! + ! !=====================! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read / initialise ! + ! !=====================! + ! + IF( ln_rstart ) THEN !== Read the restart file ==! + ! + CALL rst_read_open !* open the restart file if necessary + ! ! --------- ! + ! ! all cases ! + ! ! --------- ! + ! + id2 = iom_varid( numror, 'e3t_n' , ldstop = .FALSE. ) !* check presence + id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. ) + id4 = iom_varid( numror, 'tilde_e3t_n', ldstop = .FALSE. ) + id5 = iom_varid( numror, 'hdiv_lf' , ldstop = .FALSE. ) + ! + ! !* scale factors + ! hot restart case with zstar coordinate: + IF ( id2 > 0 ) THEN + IF(lwp) WRITE(numout,*) ' Kmm scale factor read in the restart file' + CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) + WHERE ( tmask(:,:,:) == 0.0_wp ) + e3t(:,:,:,Kmm) = e3t_0(:,:,:) + END WHERE + ELSE + DO jk = 1, jpk + e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kmm) * r1_ht_0(:,:) * tmask(:,:,jk) ) + END DO + ENDIF + + IF( l_1st_euler ) THEN ! euler + IF(lwp) WRITE(numout,*) ' Euler first time step : e3t(Kbb) = e3t(Kmm)' + e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) + ELSE ! leap frog + IF(lwp) WRITE(numout,*) ' Kbb scale factor read in the restart file' + CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) + WHERE ( tmask(:,:,:) == 0.0_wp ) + e3t(:,:,:,Kbb) = e3t_0(:,:,:) + END WHERE + ENDIF + ! ! ------------ ! + IF( ln_vvl_zstar ) THEN ! z_star case ! + ! ! ------------ ! + IF( MIN( id3, id4 ) > 0 ) THEN + CALL ctl_stop( 'dom_vvl_rst: z_star cannot restart from a z_tilde or layer run' ) + ENDIF + ! ! ------------------------ ! + ELSE ! z_tilde and layer cases ! + ! ! ------------------------ ! + ! + IF( id4 > 0 ) THEN !* scale factor increments + IF(lwp) WRITE(numout,*) ' Kmm scale factor increments read in the restart file' + CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) + IF( l_1st_euler ) THEN ! euler + IF(lwp) WRITE(numout,*) ' Euler first time step : tilde_e3t(Kbb) = tilde_e3t(Kmm)' + tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) + ELSE ! leap frog + IF(lwp) WRITE(numout,*) ' Kbb scale factor increments read in the restart file' + CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) + ENDIF + ELSE + tilde_e3t_b(:,:,:) = 0.0_wp + tilde_e3t_n(:,:,:) = 0.0_wp + ENDIF + ! ! ------------ ! + IF( ln_vvl_ztilde ) THEN ! z_tilde case ! + ! ! ------------ ! + IF( id5 > 0 ) THEN ! required array exists + CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) + ELSE ! array is missing + hdiv_lf(:,:,:) = 0.0_wp + ENDIF + ENDIF + ENDIF + ! + ELSE !== Initialize at "rest" with ssh ==! + ! + DO jk = 1, jpk + e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kmm) * r1_ht_0(:,:) * tmask(:,:,jk) ) + END DO + e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) + ! + IF( ln_vvl_ztilde .OR. ln_vvl_layer) THEN + tilde_e3t_b(:,:,:) = 0._wp + tilde_e3t_n(:,:,:) = 0._wp + IF( ln_vvl_ztilde ) hdiv_lf(:,:,:) = 0._wp + ENDIF + ENDIF + ! !=======================! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file ! + ! !=======================! + ! + IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' + ! ! --------- ! + ! ! all cases ! + ! ! --------- ! + CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) ) + CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) ) + ! ! ----------------------- ! + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases ! + ! ! ----------------------- ! + CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:)) + CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:)) + END IF + ! ! -------------! + IF( ln_vvl_ztilde ) THEN ! z_tilde case ! + ! ! ------------ ! + CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:)) + ENDIF + ! + ENDIF + ! + END SUBROUTINE dom_vvl_rst + + + SUBROUTINE dom_vvl_ctl + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_vvl_ctl *** + !! + !! ** Purpose : Control the consistency between namelist options + !! for vertical coordinate + !!---------------------------------------------------------------------- + INTEGER :: ioptio, ios + !! + NAMELIST/nam_vvl/ ln_vvl_zstar, ln_vvl_ztilde, ln_vvl_layer, ln_vvl_ztilde_as_zstar, & + & ln_vvl_zstar_at_eqtor , rn_ahe3 , rn_rst_e3t , & + & rn_lf_cutoff , rn_zdef_max , ln_vvl_dbg , & ! not yet implemented: ln_vvl_kepe + & nn_vvl_interp + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_vvl in reference namelist' ) + READ ( numnam_cfg, nam_vvl, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_vvl in configuration namelist' ) + IF(lwm) WRITE ( numond, nam_vvl ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) + WRITE(numout,*) 'dom_vvl_ctl : choice/control of the variable vertical coordinate' + WRITE(numout,*) '~~~~~~~~~~~' + WRITE(numout,*) ' Namelist nam_vvl : chose a vertical coordinate' + WRITE(numout,*) ' zstar ln_vvl_zstar = ', ln_vvl_zstar + WRITE(numout,*) ' ztilde ln_vvl_ztilde = ', ln_vvl_ztilde + WRITE(numout,*) ' layer ln_vvl_layer = ', ln_vvl_layer + WRITE(numout,*) ' ztilde as zstar ln_vvl_ztilde_as_zstar = ', ln_vvl_ztilde_as_zstar + WRITE(numout,*) ' ztilde near the equator ln_vvl_zstar_at_eqtor = ', ln_vvl_zstar_at_eqtor + WRITE(numout,*) ' !' + WRITE(numout,*) ' thickness diffusion coefficient rn_ahe3 = ', rn_ahe3 + WRITE(numout,*) ' maximum e3t deformation fractional change rn_zdef_max = ', rn_zdef_max + IF( ln_vvl_ztilde_as_zstar ) THEN + WRITE(numout,*) ' ztilde running in zstar emulation mode (ln_vvl_ztilde_as_zstar=T) ' + WRITE(numout,*) ' ignoring namelist timescale parameters and using:' + WRITE(numout,*) ' hard-wired : z-tilde to zstar restoration timescale (days)' + WRITE(numout,*) ' rn_rst_e3t = 0.e0' + WRITE(numout,*) ' hard-wired : z-tilde cutoff frequency of low-pass filter (days)' + WRITE(numout,*) ' rn_lf_cutoff = 1.0/rn_Dt' + ELSE + WRITE(numout,*) ' z-tilde to zstar restoration timescale (days) rn_rst_e3t = ', rn_rst_e3t + WRITE(numout,*) ' z-tilde cutoff frequency of low-pass filter (days) rn_lf_cutoff = ', rn_lf_cutoff + ENDIF + WRITE(numout,*) ' debug prints flag ln_vvl_dbg = ', ln_vvl_dbg + WRITE(numout,*) ' Method to compute scale factors anomaly at U/V/F points nn_vvl_interp = ', nn_vvl_interp + ENDIF + ! + ioptio = 0 ! Parameter control + IF( ln_vvl_ztilde_as_zstar ) ln_vvl_ztilde = .true. + IF( ln_vvl_zstar ) ioptio = ioptio + 1 + IF( ln_vvl_ztilde ) ioptio = ioptio + 1 + IF( ln_vvl_layer ) ioptio = ioptio + 1 + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE vertical coordinate in namelist nam_vvl' ) + ! + IF( .NOT. ln_vvl_zstar .AND. (nn_vvl_interp==2 ) ) CALL ctl_stop( 'nn_vvl_interp must be < 2 if ln_vvl_zstar=F' ) + ! + IF(lwp) THEN ! Print the choice + WRITE(numout,*) + IF( ln_vvl_zstar ) WRITE(numout,*) ' ==>>> zstar vertical coordinate is used' + IF( ln_vvl_ztilde ) WRITE(numout,*) ' ==>>> ztilde vertical coordinate is used' + IF( ln_vvl_layer ) WRITE(numout,*) ' ==>>> layer vertical coordinate is used' + IF( ln_vvl_ztilde_as_zstar ) WRITE(numout,*) ' ==>>> to emulate a zstar coordinate' + ENDIF + ! +#if defined key_agrif + IF( (.NOT.Agrif_Root()).AND.(.NOT.ln_vvl_zstar) ) CALL ctl_stop( 'AGRIF is implemented with zstar coordinate only' ) +#endif + ! + END SUBROUTINE dom_vvl_ctl + +#endif + + !!====================================================================== +END MODULE domvvl \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domwri.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domwri.F90 new file mode 100644 index 0000000..b545924 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domwri.F90 @@ -0,0 +1,243 @@ +MODULE domwri + !!====================================================================== + !! *** MODULE domwri *** + !! Ocean initialization : write the ocean domain mesh file(s) + !!====================================================================== + !! History : OPA ! 1997-02 (G. Madec) Original code + !! 8.1 ! 1999-11 (M. Imbard) NetCDF FORMAT with IOIPSL + !! NEMO 1.0 ! 2002-08 (G. Madec) F90 and several file + !! 3.0 ! 2008-01 (S. Masson) add dom_uniq + !! 4.0 ! 2016-01 (G. Madec) simplified mesh_mask.nc file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_wri : create and write mesh and mask file(s) + !! dom_stiff : diagnose maximum grid stiffness/hydrostatic consistency (s-coordinate) + !!---------------------------------------------------------------------- + ! + USE dom_oce ! ocean space and time domain + USE domutl ! + USE phycst , ONLY : rsmall + USE wet_dry, ONLY : ll_wd ! Wetting and drying + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lbclnk ! lateral boundary conditions - mpp exchanges + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_wri ! routine called by inidom.F90 + PUBLIC dom_stiff ! routine called by inidom.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domwri.F90 15033 2021-06-21 10:24:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_wri + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_wri *** + !! + !! ** Purpose : Create the NetCDF file(s) which contain(s) all the + !! ocean domain informations (mesh and mask arrays). This (these) + !! file(s) is (are) used for visualisation (SAXO software) and + !! diagnostic computation. + !! + !! ** Method : create a file with all domain related arrays + !! + !! ** output file : meshmask.nc : domain size, horizontal grid-point position, + !! masks, depth and vertical scale factors + !!---------------------------------------------------------------------- + INTEGER :: inum ! temprary units for 'mesh_mask.nc' file + CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: zprt, zprw ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepu, zdepv ! 3D workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dom_wri : create NetCDF mesh and mask information file(s)' + IF(lwp) WRITE(numout,*) '~~~~~~~' + + clnam = 'mesh_mask' ! filename (mesh and mask informations) + + ! ! ============================ + ! ! create 'mesh_mask.nc' file + ! ! ============================ + CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) + ! ! Configuration specificities + CALL iom_putatt( inum, 'CfgName', TRIM(cn_cfg) ) + CALL iom_putatt( inum, 'CfgIndex', nn_cfg ) + ! ! lateral boundary of the global domain + CALL iom_putatt( inum, 'Iperio', COUNT( (/l_Iperio/) ) ) + CALL iom_putatt( inum, 'Jperio', COUNT( (/l_Jperio/) ) ) + CALL iom_putatt( inum, 'NFold', COUNT( (/l_NFold /) ) ) + CALL iom_putatt( inum, 'NFtype', c_NFtype ) + ! ! type of vertical coordinate + IF(ln_zco) CALL iom_putatt( inum, 'VertCoord', 'zco' ) + IF(ln_zps) CALL iom_putatt( inum, 'VertCoord', 'zps' ) + IF(ln_sco) CALL iom_putatt( inum, 'VertCoord', 'sco' ) + ! ! ocean cavities under iceshelves + CALL iom_putatt( inum, 'IsfCav', COUNT( (/ln_isfcav/) ) ) + ! ! masks + CALL iom_rstput( 0, 0, inum, 'tmask', tmask, ktype = jp_i1 ) ! ! land-sea mask + CALL iom_rstput( 0, 0, inum, 'umask', umask, ktype = jp_i1 ) + CALL iom_rstput( 0, 0, inum, 'vmask', vmask, ktype = jp_i1 ) + CALL iom_rstput( 0, 0, inum, 'fmask', fmask, ktype = jp_i1 ) + + CALL dom_uniq( zprw, 'T' ) + DO_2D( 1, 1, 1, 1 ) + zprt(ji,jj) = ssmask(ji,jj) * zprw(ji,jj) ! ! unique point mask + END_2D + CALL iom_rstput( 0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1 ) + CALL dom_uniq( zprw, 'U' ) + DO_2D( 1, 1, 1, 1 ) + zprt(ji,jj) = ssumask(ji,jj) * zprw(ji,jj) ! ! unique point mask + END_2D + CALL iom_rstput( 0, 0, inum, 'umaskutil', zprt, ktype = jp_i1 ) + CALL dom_uniq( zprw, 'V' ) + DO_2D( 1, 1, 1, 1 ) + zprt(ji,jj) = ssvmask(ji,jj) * zprw(ji,jj) ! ! unique point mask + END_2D + CALL iom_rstput( 0, 0, inum, 'vmaskutil', zprt, ktype = jp_i1 ) +!!gm ssfmask has been removed ==>> find another solution to defined fmaskutil +!! Here we just remove the output of fmaskutil. +! CALL dom_uniq( zprw, 'F' ) +! DO jj = 1, jpj +! DO ji = 1, jpi +! zprt(ji,jj) = ssfmask(ji,jj) * zprw(ji,jj) ! ! unique point mask +! END DO +! END DO +! CALL iom_rstput( 0, 0, inum, 'fmaskutil', zprt, ktype = jp_i1 ) +!!gm + + ! ! horizontal mesh (inum3) + CALL iom_rstput( 0, 0, inum, 'glamt', glamt, ktype = jp_r8 ) ! ! latitude + CALL iom_rstput( 0, 0, inum, 'glamu', glamu, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'glamv', glamv, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'glamf', glamf, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum, 'gphit', gphit, ktype = jp_r8 ) ! ! longitude + CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'gphif', gphif, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum, 'e1t', e1t, ktype = jp_r8 ) ! ! e1 scale factors + CALL iom_rstput( 0, 0, inum, 'e1u', e1u, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e1v', e1v, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e1f', e1f, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum, 'e2t', e2t, ktype = jp_r8 ) ! ! e2 scale factors + CALL iom_rstput( 0, 0, inum, 'e2u', e2u, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e2v', e2v, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e2f', e2f, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum, 'ff_f', ff_f, ktype = jp_r8 ) ! ! coriolis factor + CALL iom_rstput( 0, 0, inum, 'ff_t', ff_t, ktype = jp_r8 ) + + ! note that mbkt is set to 1 over land ==> use surface tmask + zprt(:,:) = REAL( mbkt(:,:) , wp ) + CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points + zprt(:,:) = REAL( mikt(:,:) , wp ) + CALL iom_rstput( 0, 0, inum, 'misf', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points + ! ! vertical mesh + CALL iom_rstput( 0, 0, inum, 'e3t_1d', e3t_1d, ktype = jp_r8 ) ! ! scale factors + CALL iom_rstput( 0, 0, inum, 'e3w_1d', e3w_1d, ktype = jp_r8 ) + + CALL iom_rstput( 0, 0, inum, 'e3t_0' , e3t_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3u_0' , e3u_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3v_0' , e3v_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3f_0' , e3f_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3w_0' , e3w_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3uw_0', e3uw_0, ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'e3vw_0', e3vw_0, ktype = jp_r8 ) + ! + CALL iom_rstput( 0, 0, inum, 'gdept_1d' , gdept_1d , ktype = jp_r8 ) ! stretched system + CALL iom_rstput( 0, 0, inum, 'gdepw_1d' , gdepw_1d , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'gdept_0' , gdept_0 , ktype = jp_r8 ) + CALL iom_rstput( 0, 0, inum, 'gdepw_0' , gdepw_0 , ktype = jp_r8 ) + ! + IF( ln_sco ) THEN ! s-coordinate stiffness + CALL dom_stiff( zprt ) + CALL iom_rstput( 0, 0, inum, 'stiffness', zprt ) ! Max. grid stiffness ratio + ENDIF + ! + IF( ll_wd ) CALL iom_rstput( 0, 0, inum, 'ht_0' , ht_0 , ktype = jp_r8 ) + + ! ! ============================ + CALL iom_close( inum ) ! close the files + ! ! ============================ + END SUBROUTINE dom_wri + + + SUBROUTINE dom_stiff( px1 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_stiff *** + !! + !! ** Purpose : Diagnose maximum grid stiffness/hydrostatic consistency + !! + !! ** Method : Compute Haney (1991) hydrostatic condition ratio + !! Save the maximum in the vertical direction + !! (this number is only relevant in s-coordinates) + !! + !! Haney, 1991, J. Phys. Oceanogr., 21, 610-619. + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), INTENT(out), OPTIONAL :: px1 ! stiffness + ! + INTEGER :: ji, jj, jk + REAL(wp) :: zrxmax + REAL(wp), DIMENSION(4) :: zr1 + REAL(wp), DIMENSION(jpi,jpj) :: zx1 + !!---------------------------------------------------------------------- + zx1(:,:) = 0._wp + zrxmax = 0._wp + zr1(:) = 0._wp + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + !!gm remark: dk(gdepw) = e3t ===>>> possible simplification of the following calculation.... + !! especially since it is gde3w which is used to compute the pressure gradient + !! furthermore, I think gdept_0 should be used below instead of w point in the numerator + !! so that the ratio is computed at the same point (i.e. uw and vw) .... + zr1(1) = ABS( ( gdepw_0(ji ,jj,jk )-gdepw_0(ji-1,jj,jk ) & + & +gdepw_0(ji ,jj,jk+1)-gdepw_0(ji-1,jj,jk+1) ) & + & / ( gdepw_0(ji ,jj,jk )+gdepw_0(ji-1,jj,jk ) & + & -gdepw_0(ji ,jj,jk+1)-gdepw_0(ji-1,jj,jk+1) + rsmall ) ) * umask(ji-1,jj,jk) + zr1(2) = ABS( ( gdepw_0(ji+1,jj,jk )-gdepw_0(ji ,jj,jk ) & + & +gdepw_0(ji+1,jj,jk+1)-gdepw_0(ji ,jj,jk+1) ) & + & / ( gdepw_0(ji+1,jj,jk )+gdepw_0(ji ,jj,jk ) & + & -gdepw_0(ji+1,jj,jk+1)-gdepw_0(ji ,jj,jk+1) + rsmall ) ) * umask(ji ,jj,jk) + zr1(3) = ABS( ( gdepw_0(ji,jj+1,jk )-gdepw_0(ji,jj ,jk ) & + & +gdepw_0(ji,jj+1,jk+1)-gdepw_0(ji,jj ,jk+1) ) & + & / ( gdepw_0(ji,jj+1,jk )+gdepw_0(ji,jj ,jk ) & + & -gdepw_0(ji,jj+1,jk+1)-gdepw_0(ji,jj ,jk+1) + rsmall ) ) * vmask(ji,jj ,jk) + zr1(4) = ABS( ( gdepw_0(ji,jj ,jk )-gdepw_0(ji,jj-1,jk ) & + & +gdepw_0(ji,jj ,jk+1)-gdepw_0(ji,jj-1,jk+1) ) & + & / ( gdepw_0(ji,jj ,jk )+gdepw_0(ji,jj-1,jk ) & + & -gdepw_0(ji,jj ,jk+1)-gdepw_0(ji,jj-1,jk+1) + rsmall ) ) * vmask(ji,jj-1,jk) + zrxmax = MAXVAL( zr1(1:4) ) + zx1(ji,jj) = MAX( zx1(ji,jj) , zrxmax ) + END_3D + CALL lbc_lnk( 'domwri', zx1, 'T', 1.0_wp ) + ! + IF( PRESENT( px1 ) ) px1 = zx1 + ! + zrxmax = MAXVAL( zx1 ) + ! + CALL mpp_max( 'domwri', zrxmax ) ! max over the global domain + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_stiff : maximum grid stiffness ratio: ', zrxmax + WRITE(numout,*) '~~~~~~~~~' + ENDIF + ! + END SUBROUTINE dom_stiff + + !!====================================================================== +END MODULE domwri \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domzgr.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domzgr.F90 new file mode 100644 index 0000000..9d4d21d --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domzgr.F90 @@ -0,0 +1,448 @@ +MODULE domzgr + !!============================================================================== + !! *** MODULE domzgr *** + !! Ocean domain : definition of the vertical coordinate system + !!============================================================================== + !! History : OPA ! 1995-12 (G. Madec) Original code : s vertical coordinate + !! ! 1997-07 (G. Madec) lbc_lnk call + !! ! 1997-04 (J.-O. Beismann) + !! 8.5 ! 2002-09 (A. Bozec, G. Madec) F90: Free form and module + !! - ! 2002-09 (A. de Miranda) rigid-lid + islands + !! NEMO 1.0 ! 2003-08 (G. Madec) F90: Free form and module + !! - ! 2005-10 (A. Beckmann) modifications for hybrid s-ccordinates & new stretching function + !! 2.0 ! 2006-04 (R. Benshila, G. Madec) add zgr_zco + !! 3.0 ! 2008-06 (G. Madec) insertion of domzgr_zps.h90 & conding style + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !! 3.3 ! 2010-11 (G. Madec) add mbk. arrays associated to the deepest ocean level + !! 3.4 ! 2012-08 (J. Siddorn) added Siddorn and Furner stretching function + !! 3.4 ! 2012-12 (R. Bourdalle-Badie and G. Reffray) modify C1D case + !! 3.6 ! 2014-11 (P. Mathiot and C. Harris) add ice shelf capabilitye + !! 3.? ! 2015-11 (H. Liu) Modifications for Wetting/Drying + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_zgr : read or set the ocean vertical coordinate system + !! zgr_read : read the vertical information in the domain configuration file + !! zgr_top_bot : ocean top and bottom level for t-, u, and v-points with 1 as minimum value + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce ! ocean domain + USE usrdef_zgr ! user defined vertical coordinate system + USE closea ! closed seas + USE depth_e3 ! depth <=> e3 + USE wet_dry, ONLY: ll_wd, ssh_ref ! Wetting and drying + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_zgr ! called by dom_init.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: domzgr.F90 15556 2021-11-29 15:23:06Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_zgr( k_top, k_bot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_zgr *** + !! + !! ** Purpose : set the depth of model levels and the resulting + !! vertical scale factors. + !! + !! ** Method : - reference 1D vertical coordinate (gdep._1d, e3._1d) + !! - read/set ocean depth and ocean levels (bathy, mbathy) + !! - vertical coordinate (gdep., e3.) depending on the + !! coordinate chosen : + !! ln_zco=T z-coordinate + !! ln_zps=T z-coordinate with partial steps + !! ln_zco=T s-coordinate + !! + !! ** Action : define gdep., e3., mbathy and bathy + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(:,:), INTENT(out) :: k_top, k_bot ! ocean first and last level indices + ! + INTEGER :: ji,jj,jk ! dummy loop index + INTEGER :: ikt, ikb ! top/bot index + INTEGER :: ioptio, ibat, ios ! local integer + INTEGER :: is_mbkuvf ! ==0 if mbku, mbkv, mbkf to be computed + REAL(wp) :: zrefdep ! depth of the reference level (~10m) + REAL(wp), DIMENSION(jpi,jpj ) :: zmsk + REAL(wp), DIMENSION(jpi,jpj,2) :: ztopbot + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'dom_zgr : vertical coordinate' + WRITE(numout,*) '~~~~~~~' + ENDIF + + IF( ln_linssh .AND. lwp) WRITE(numout,*) ' linear free surface: the vertical mesh does not change in time' + + + IF( ln_read_cfg ) THEN !== read in mesh_mask.nc file ==! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> Read vertical mesh in ', TRIM( cn_domcfg ), ' file' + ! + CALL zgr_read ( ln_zco , ln_zps , ln_sco, ln_isfcav, & + & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth + & gdept_0 , gdepw_0 , & ! gridpoints depth + & e3t_0 , e3u_0 , e3v_0 , e3f_0 , & ! vertical scale factors + & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors + & k_top , k_bot , & ! 1st & last ocean level + & is_mbkuvf, mbku, mbkv, mbkf ) ! U/V/F points bottom levels + ! + ELSE !== User defined configuration ==! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' User defined vertical mesh (usr_def_zgr)' + is_mbkuvf = 0 + ! + CALL usr_def_zgr( ln_zco , ln_zps , ln_sco, ln_isfcav, & + & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth + & gdept_0 , gdepw_0 , & ! gridpoints depth + & e3t_0 , e3u_0 , e3v_0 , e3f_0 , & ! vertical scale factors + & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors + & k_top , k_bot ) ! 1st & last ocean level + ! + ! make sure that periodicities are properly applied + CALL lbc_lnk( 'dom_zgr', gdept_0, 'T', 1._wp, gdepw_0, 'W', 1._wp, & + & e3u_0, 'U', 1._wp, e3v_0, 'V', 1._wp, e3f_0, 'F', 1._wp, & + & e3w_0, 'W', 1._wp, e3uw_0, 'U', 1._wp, e3vw_0, 'V', 1._wp, & + & kfillmode = jpfillcopy ) ! do not put 0 over closed boundaries + CALL lbc_lnk( 'dom_zgr', e3t_0, 'T', 1._dp, kfillmode = jpfillcopy ) + ztopbot(:,:,1) = REAL(k_top, wp) + ztopbot(:,:,2) = REAL(k_bot, wp) + CALL lbc_lnk( 'dom_zgr', ztopbot, 'T', 1._wp, kfillmode = jpfillcopy ) ! do not put 0 over closed boundaries + k_top(:,:) = NINT(ztopbot(:,:,1)) + k_bot(:,:) = NINT(ztopbot(:,:,2)) + ! + ENDIF + ! + ! the following is mandatory + ! make sure that closed boundaries are correctly defined in k_top that will be used to compute all mask arrays + ! + zmsk(:,:) = 1._wp ! default: no closed boundaries + IF( .NOT. l_Iperio ) THEN ! E-W closed: + zmsk( mi0( 1+nn_hls):mi1( 1+nn_hls),:) = 0._wp ! first column of inner global domain at 0 + zmsk( mi0(jpiglo-nn_hls):mi1(jpiglo-nn_hls),:) = 0._wp ! last column of inner global domain at 0 + ENDIF + IF( .NOT. l_Jperio ) THEN ! S closed: + zmsk(:,mj0( 1+nn_hls):mj1( 1+nn_hls) ) = 0._wp ! first line of inner global domain at 0 + ENDIF + IF( .NOT. ( l_Jperio .OR. l_NFold ) ) THEN ! N closed: + zmsk(:,mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls) ) = 0._wp ! last line of inner global domain at 0 + ENDIF + CALL lbc_lnk( 'usrdef_zgr', zmsk, 'T', 1._wp ) ! set halos + k_top(:,:) = k_top(:,:) * NINT( zmsk(:,:) ) + ! +!!gm to be remove when removing the OLD definition of e3 scale factors so that gde3w disappears + ! Compute gde3w_0 (vertical sum of e3w) + gde3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1) + DO jk = 2, jpk + gde3w_0(:,:,jk) = gde3w_0(:,:,jk-1) + e3w_0(:,:,jk) + END DO + ! + ! Any closed seas (defined by closea_mask > 0 in domain_cfg file) to be filled + ! in at runtime if ln_closea=.false. + IF( ln_closea ) THEN + IF ( ln_maskcs ) THEN + ! mask all the closed sea + CALL clo_msk( k_top, k_bot, mask_opnsea, 'mask_opensea' ) + ELSE IF ( ln_mask_csundef ) THEN + ! defined closed sea are kept + ! mask all the undefined closed sea + CALL clo_msk( k_top, k_bot, mask_csundef, 'mask_csundef' ) + END IF + END IF + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) ' Type of vertical coordinate (read in ', TRIM( cn_domcfg ), ' file or set in userdef_nam) :' + WRITE(numout,*) ' z-coordinate - full steps ln_zco = ', ln_zco + WRITE(numout,*) ' z-coordinate - partial steps ln_zps = ', ln_zps + WRITE(numout,*) ' s- or hybrid z-s-coordinate ln_sco = ', ln_sco + WRITE(numout,*) ' ice shelf cavities ln_isfcav = ', ln_isfcav + ENDIF + + ioptio = 0 ! Check Vertical coordinate options + IF( ln_zco ) ioptio = ioptio + 1 + IF( ln_zps ) ioptio = ioptio + 1 + IF( ln_sco ) ioptio = ioptio + 1 + IF( ioptio /= 1 ) CALL ctl_stop( ' none or several vertical coordinate options used' ) + + + ! ! top/bottom ocean level indices for t-, u- and v-points (f-point also for top) + CALL zgr_top_bot( k_top, k_bot, is_mbkuvf ) ! with a minimum value set to 1 + ! + ! ! ice shelf draft and bathymetry + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ikt = mikt(ji,jj) + ikb = mbkt(ji,jj) + bathy (ji,jj) = gdepw_0(ji,jj,ikb+1) + risfdep(ji,jj) = gdepw_0(ji,jj,ikt ) + END_2D + ! + ! ! deepest/shallowest W level Above/Below ~10m +!!gm BUG in s-coordinate this does not work! + zrefdep = 10._wp - 0.1_wp * MINVAL( e3w_1d ) ! ref. depth with tolerance (10% of minimum layer thickness) + nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m + nla10 = nlb10 - 1 ! deepest W level Above ~10m +!!gm end bug + ! + IF( lwp ) THEN + WRITE(numout,*) ' MIN val k_top ', MINVAL( k_top(:,:) ), ' MAX ', MAXVAL( k_top(:,:) ) + WRITE(numout,*) ' MIN val k_bot ', MINVAL( k_bot(:,:) ), ' MAX ', MAXVAL( k_bot(:,:) ) + WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ), & + & ' w ', MINVAL( gdepw_0(:,:,:) ), '3w ', MINVAL( gde3w_0(:,:,:) ) + WRITE(numout,*) ' MIN val e3 t ', MINVAL( e3t_0(:,:,:) ), ' f ', MINVAL( e3f_0(:,:,:) ), & + & ' u ', MINVAL( e3u_0(:,:,:) ), ' u ', MINVAL( e3v_0(:,:,:) ), & + & ' uw', MINVAL( e3uw_0(:,:,:) ), ' vw', MINVAL( e3vw_0(:,:,:)), & + & ' w ', MINVAL( e3w_0(:,:,:) ) + + WRITE(numout,*) ' MAX val depth t ', MAXVAL( gdept_0(:,:,:) ), & + & ' w ', MAXVAL( gdepw_0(:,:,:) ), '3w ', MAXVAL( gde3w_0(:,:,:) ) + WRITE(numout,*) ' MAX val e3 t ', MAXVAL( e3t_0(:,:,:) ), ' f ', MAXVAL( e3f_0(:,:,:) ), & + & ' u ', MAXVAL( e3u_0(:,:,:) ), ' u ', MAXVAL( e3v_0(:,:,:) ), & + & ' uw', MAXVAL( e3uw_0(:,:,:) ), ' vw', MAXVAL( e3vw_0(:,:,:) ), & + & ' w ', MAXVAL( e3w_0(:,:,:) ) + ENDIF + ! + END SUBROUTINE dom_zgr + + + SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate + & pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate + & pdept , pdepw , & ! 3D t & w-points depth + & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors + & pe3w , pe3uw , pe3vw , & ! - - - + & k_top , k_bot , & ! top & bottom ocean level + & k_mbkuvf , k_bot_u , k_bot_v , k_bot_f ) ! U/V/F points bottom levels + !!--------------------------------------------------------------------- + !! *** ROUTINE zgr_read *** + !! + !! ** Purpose : Read the vertical information in the domain configuration file + !! + !!---------------------------------------------------------------------- + LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags + LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag + REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3u, pe3v, pe3f! vertical scale factors [m] + REAL(dp), DIMENSION(:,:,:), INTENT(out) :: pe3t! vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! - - - + INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top , k_bot ! first & last ocean level + INTEGER , INTENT(out) :: k_mbkuvf ! ==1 if mbku, mbkv, mbkf are in file + INTEGER , DIMENSION(:,:) , INTENT(out) :: k_bot_u , k_bot_v, k_bot_f ! bottom levels at U/V/F points + ! + INTEGER :: ji,jj,jk ! dummy loop index + INTEGER :: inum, iatt + REAL(WP) :: z_zco, z_zps, z_sco, z_cav + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + CHARACTER(len=7) :: catt ! 'zco', 'zps, 'sco' or 'UNKNOWN' + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' zgr_read : read the vertical coordinates in ', TRIM( cn_domcfg ), ' file' + WRITE(numout,*) ' ~~~~~~~~' + ENDIF + ! + CALL iom_open( cn_domcfg, inum ) + ! + ! !* type of vertical coordinate + CALL iom_getatt( inum, 'VertCoord', catt ) ! returns 'UNKNOWN' if not found + ld_zco = catt == 'zco' ! default = .false. + ld_zps = catt == 'zps' ! default = .false. + ld_sco = catt == 'sco' ! default = .false. + ! !* ocean cavities under iceshelves + CALL iom_getatt( inum, 'IsfCav', iatt ) ! returns -999 if not found + ld_isfcav = iatt == 1 ! default = .false. + ! + ! ------- keep compatibility with OLD VERSION... start ------- + IF( catt == 'UNKNOWN' ) THEN + CALL iom_get( inum, 'ln_zco', z_zco ) ; ld_zco = z_zco /= 0._wp + CALL iom_get( inum, 'ln_zps', z_zps ) ; ld_zps = z_zps /= 0._wp + CALL iom_get( inum, 'ln_sco', z_sco ) ; ld_sco = z_sco /= 0._wp + ENDIF + IF( iatt == -999 ) THEN + CALL iom_get( inum, 'ln_isfcav', z_cav ) ; ld_isfcav = z_cav /= 0._wp + ENDIF + ! ------- keep compatibility with OLD VERSION... end ------- + ! + ! !* ocean top and bottom level + CALL iom_get( inum, jpdom_global, 'top_level' , z2d ) ! 1st wet T-points (ISF) + k_top(:,:) = NINT( z2d(:,:) ) + CALL iom_get( inum, jpdom_global, 'bottom_level' , z2d ) ! last wet T-points + k_bot(:,:) = NINT( z2d(:,:) ) + ! + ! !* vertical scale factors + CALL iom_get( inum, jpdom_unknown, 'e3t_1d' , pe3t_1d ) ! 1D reference coordinate + CALL iom_get( inum, jpdom_unknown, 'e3w_1d' , pe3w_1d ) + ! + CALL iom_get( inum, jpdom_global, 'e3t_0' , pe3t , cd_type = 'T', psgn = 1._dp, kfill = jpfillcopy ) ! 3D coordinate + CALL iom_get( inum, jpdom_global, 'e3u_0' , pe3u , cd_type = 'U', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3v_0' , pe3v , cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3f_0' , pe3f , cd_type = 'F', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3w_0' , pe3w , cd_type = 'W', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3uw_0' , pe3uw, cd_type = 'U', psgn = 1._dp, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global, 'e3vw_0' , pe3vw, cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + ! + ! !* depths + ! !- old depth definition (obsolescent feature) + IF( iom_varid( inum, 'gdept_1d', ldstop = .FALSE. ) > 0 .AND. & + & iom_varid( inum, 'gdepw_1d', ldstop = .FALSE. ) > 0 .AND. & + & iom_varid( inum, 'gdept_0' , ldstop = .FALSE. ) > 0 .AND. & + & iom_varid( inum, 'gdepw_0' , ldstop = .FALSE. ) > 0 ) THEN + CALL ctl_warn( 'zgr_read : old definition of depths and scale factors used ', & + & ' depths at t- and w-points read in the domain configuration file') + CALL iom_get( inum, jpdom_unknown, 'gdept_1d', pdept_1d ) + CALL iom_get( inum, jpdom_unknown, 'gdepw_1d', pdepw_1d ) + CALL iom_get( inum, jpdom_global , 'gdept_0' , pdept, kfill = jpfillcopy ) + CALL iom_get( inum, jpdom_global , 'gdepw_0' , pdepw, kfill = jpfillcopy ) + ! + ELSE !- depths computed from e3. scale factors + CALL e3_to_depth( pe3t_1d, pe3w_1d, pdept_1d, pdepw_1d ) ! 1D reference depth + CALL e3_to_depth( pe3t , pe3w , pdept , pdepw ) ! 3D depths +#if defined key_qco && key_isf + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpk ) ! vertical sum at partial cell xxxx other level + IF( jk == k_top(ji,jj) ) THEN ! first ocean point : partial cell + gdept_0(ji,jj,jk) = gdepw_0(ji,jj,jk ) + 0.5_wp * e3w_0(ji,jj,jk) ! = risfdep + 1/2 e3w_0(mikt) + ELSE ! other levels + gdept_0(ji,jj,jk) = gdept_0(ji,jj,jk-1) + e3w_0(ji,jj,jk) + ENDIF + END_3D +#endif + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Reference 1D z-coordinate depth and scale factors:' + WRITE(numout, "(9x,' level gdept_1d gdepw_1d e3t_1d e3w_1d ')" ) + WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, pdept_1d(jk), pdepw_1d(jk), pe3t_1d(jk), pe3w_1d(jk), jk = 1, jpk ) + ENDIF + ENDIF + ! + IF( iom_varid( inum, 'mbku', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) ' mbku, mbkv & mbkf read in ', TRIM(cn_domcfg), ' file' + CALL iom_get( inum, jpdom_global, 'mbku', z2d, cd_type = 'U', psgn = 1._dp, kfill = jpfillcopy ) + k_bot_u(:,:) = NINT( z2d(:,:) ) + CALL iom_get( inum, jpdom_global, 'mbkv', z2d, cd_type = 'V', psgn = 1._dp, kfill = jpfillcopy ) + k_bot_v(:,:) = NINT( z2d(:,:) ) + CALL iom_get( inum, jpdom_global, 'mbkf', z2d, cd_type = 'F', psgn = 1._dp, kfill = jpfillcopy ) + k_bot_f(:,:) = NINT( z2d(:,:) ) + k_mbkuvf = 1 + ELSE + k_mbkuvf = 0 + ENDIF + ! + ! reference depth for negative bathy (wetting and drying only) + IF( ll_wd ) CALL iom_get( inum, 'rn_wd_ref_depth' , ssh_ref ) + ! + CALL iom_close( inum ) + ! + END SUBROUTINE zgr_read + + + SUBROUTINE zgr_top_bot( k_top, k_bot, k_mbkuvf ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_top_bot *** + !! + !! ** Purpose : defines the vertical index of ocean bottom (mbk. arrays) + !! + !! ** Method : computes from k_top and k_bot with a minimum value of 1 over land + !! + !! ** Action : mikt, miku, mikv : vertical indices of the shallowest + !! ocean level at t-, u- & v-points + !! (min value = 1) + !! ** Action : mbkt, mbku, mbkv : vertical indices of the deeptest + !! mbkf ocean level at t-, u-, v- & f-points + !! (min value = 1 over land) + !!---------------------------------------------------------------------- + INTEGER , DIMENSION(:,:), INTENT(in) :: k_top, k_bot ! top & bottom ocean level indices + INTEGER , INTENT(in) :: k_mbkuvf ! flag to recompute mbku, mbkv, mbkf + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' zgr_top_bot : ocean top and bottom k-index of T-, U-, V- and W-levels ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~' + ! + mikt(:,:) = MAX( k_top(:,:) , 1 ) ! top ocean k-index of T-level (=1 over land) + ! + mbkt(:,:) = MAX( k_bot(:,:) , 1 ) ! bottom ocean k-index of T-level (=1 over land) + + ! ! N.B. top k-index of W-level = mikt + ! ! bottom k-index of W-level = mbkt+1 + DO_2D( 0, 0, 0, 0 ) + miku(ji,jj) = MAX( mikt(ji+1,jj ) , mikt(ji,jj) ) + mikv(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj) ) + mikf(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj), mikt(ji+1,jj ), mikt(ji+1,jj+1) ) + END_2D + + IF ( k_mbkuvf==0 ) THEN + IF(lwp) WRITE(numout,*) ' mbku, mbkv, mbkf computed from mbkt' + DO_2D( 0, 0, 0, 0 ) + mbku(ji,jj) = MIN( mbkt(ji+1,jj ) , mbkt(ji,jj) ) + mbkv(ji,jj) = MIN( mbkt(ji ,jj+1) , mbkt(ji,jj) ) + mbkf(ji,jj) = MIN( mbkt(ji ,jj+1) , mbkt(ji,jj), mbkt(ji+1,jj ), mbkt(ji+1,jj+1) ) + END_2D + ELSE + IF(lwp) WRITE(numout,*) ' mbku, mbkv, mbkf read from file' + ! Use mbku, mbkv, mbkf from file + ! Ensure these are lower than expected bottom level deduced from mbkt + DO_2D( 0, 0, 0, 0 ) + mbku(ji,jj) = MIN( mbku(ji,jj), mbkt(ji+1,jj ) , mbkt(ji,jj) ) + mbkv(ji,jj) = MIN( mbkv(ji,jj), mbkt(ji ,jj+1) , mbkt(ji,jj) ) + mbkf(ji,jj) = MIN( mbkf(ji,jj), mbkt(ji ,jj+1) , mbkt(ji,jj), mbkt(ji+1,jj ), mbkt(ji+1,jj+1) ) + END_2D + ENDIF + ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( miku(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) + miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mikv(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) + mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mikf(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) + mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) + ! + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mbku(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp ) + mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mbkv(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp ) + mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + + DO_2D( 0, 0, 0, 0 ) + zk(ji,jj) = REAL( mbkf(ji,jj), wp ) + END_2D + CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp ) + mbkf(:,:) = MAX( NINT( zk(:,:) ), 1 ) + ! + END SUBROUTINE zgr_top_bot + + !!====================================================================== +END MODULE domzgr diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domzgr_substitute.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domzgr_substitute.h90 new file mode 100644 index 0000000..a709e64 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/domzgr_substitute.h90 @@ -0,0 +1,53 @@ +!!---------------------------------------------------------------------- +!! *** domzgr_substitute.h90 *** +!!---------------------------------------------------------------------- +!! ** purpose : substitute fsdep. and fse.., the vert. depth and scale +!! factors depending on the vertical coord. used, using CPP macro. +!!---------------------------------------------------------------------- +!! History : 4.2 ! 2020-02 (S. Techene, G. Madec) star coordinate +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.2 , NEMO Consortium (2020) +!! $Id$ +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +#if defined key_qco +# define e3t(i,j,k,t) (e3t_0(i,j,k)*(1._wp+r3t(i,j,t)*tmask(i,j,k))) +# define e3u(i,j,k,t) (e3u_0(i,j,k)*(1._wp+r3u(i,j,t)*umask(i,j,k))) +# define e3v(i,j,k,t) (e3v_0(i,j,k)*(1._wp+r3v(i,j,t)*vmask(i,j,k))) +# define e3f(i,j,k) (e3f_0(i,j,k)*(1._wp+r3f(i,j)*fe3mask(i,j,k))) +# define e3f_vor(i,j,k) (e3f_0vor(i,j,k)*(1._wp+r3f(i,j)*fe3mask(i,j,k))) +# define e3w(i,j,k,t) (e3w_0(i,j,k)*(1._wp+r3t(i,j,t))) +# define e3uw(i,j,k,t) (e3uw_0(i,j,k)*(1._wp+r3u(i,j,t))) +# define e3vw(i,j,k,t) (e3vw_0(i,j,k)*(1._wp+r3v(i,j,t))) +# define ht(i,j) (ht_0(i,j)*(1._wp+r3t(i,j,Kmm))) +# define hu(i,j,t) (hu_0(i,j)*(1._wp+r3u(i,j,t))) +# define hv(i,j,t) (hv_0(i,j)*(1._wp+r3v(i,j,t))) +# define r1_hu(i,j,t) (r1_hu_0(i,j)/(1._wp+r3u(i,j,t))) +# define r1_hv(i,j,t) (r1_hv_0(i,j)/(1._wp+r3v(i,j,t))) +# if defined key_isf +# define gdept(i,j,k,t) ((gdept_0(i,j,k)-risfdep(i,j))*(1._wp+r3t(i,j,t))+risfdep(i,j)) +# define gdepw(i,j,k,t) ((gdepw_0(i,j,k)-risfdep(i,j))*(1._wp+r3t(i,j,t))+risfdep(i,j)) +# else +# define gdept(i,j,k,t) (gdept_0(i,j,k)*(1._wp+r3t(i,j,t))) +# define gdepw(i,j,k,t) (gdepw_0(i,j,k)*(1._wp+r3t(i,j,t))) +# endif +# define gde3w(i,j,k) (gdept(i,j,k,Kmm)-ssh(i,j,Kmm)) +#elif defined key_linssh +# define e3t(i,j,k,t) e3t_0(i,j,k) +# define e3u(i,j,k,t) e3u_0(i,j,k) +# define e3v(i,j,k,t) e3v_0(i,j,k) +# define e3f(i,j,k) e3f_0(i,j,k) +# define e3f_vor(i,j,k) e3f_0vor(i,j,k) +# define e3w(i,j,k,t) e3w_0(i,j,k) +# define e3uw(i,j,k,t) e3uw_0(i,j,k) +# define e3vw(i,j,k,t) e3vw_0(i,j,k) +# define ht(i,j) ht_0(i,j) +# define hu(i,j,t) hu_0(i,j) +# define hv(i,j,t) hv_0(i,j) +# define r1_hu(i,j,t) r1_hu_0(i,j) +# define r1_hv(i,j,t) r1_hv_0(i,j) +# define gdept(i,j,k,t) gdept_0(i,j,k) +# define gdepw(i,j,k,t) gdepw_0(i,j,k) +# define gde3w(i,j,k) gdept_0(i,j,k) +#endif +!!---------------------------------------------------------------------- \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/dtatsd.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/dtatsd.F90 new file mode 100644 index 0000000..f04ed0a --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/dtatsd.F90 @@ -0,0 +1,278 @@ +MODULE dtatsd + !!====================================================================== + !! *** MODULE dtatsd *** + !! Ocean data : read ocean Temperature & Salinity Data from gridded data + !!====================================================================== + !! History : OPA ! 1991-03 () Original code + !! - ! 1992-07 (M. Imbard) + !! 8.0 ! 1999-10 (M.A. Foujols, M. Imbard) NetCDF FORMAT + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.3 ! 2010-10 (C. Bricaud, S. Masson) use of fldread + !! 3.4 ! 2010-11 (G. Madec, C. Ethe) Merge of dtatem and dtasal + remove CPP keys + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dta_tsd : read and time interpolated ocean Temperature & Salinity Data + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE phycst ! physical constants + USE dom_oce ! ocean space and time domain + USE domtile + USE fldread ! read input fields + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC dta_tsd_init ! called by opa.F90 + PUBLIC dta_tsd ! called by istate.F90 and tradmp.90 + + ! !!* namtsd namelist : Temperature & Salinity Data * + LOGICAL , PUBLIC :: ln_tsd_init !: T & S data flag + LOGICAL , PUBLIC :: ln_tsd_dmp !: internal damping toward input data flag + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tsd ! structure of input SST (file informations, fields read) + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dtatsd.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dta_tsd_init( ld_tradmp ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dta_tsd_init *** + !! + !! ** Purpose : initialisation of T & S input data + !! + !! ** Method : - Read namtsd namelist + !! - allocates T & S data structure + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in), OPTIONAL :: ld_tradmp ! force the initialization when tradp is used + ! + INTEGER :: ios, ierr0, ierr1, ierr2, ierr3 ! local integers + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files + TYPE(FLD_N), DIMENSION( jpts) :: slf_i ! array of namelist informations on the fields to read + TYPE(FLD_N) :: sn_tem, sn_sal + !! + NAMELIST/namtsd/ ln_tsd_init, ln_tsd_dmp, cn_dir, sn_tem, sn_sal + !!---------------------------------------------------------------------- + ! + ! Initialisation + ierr0 = 0 ; ierr1 = 0 ; ierr2 = 0 ; ierr3 = 0 + ! + READ ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtsd in reference namelist' ) + READ ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtsd in configuration namelist' ) + IF(lwm) WRITE ( numond, namtsd ) + + IF( PRESENT( ld_tradmp ) ) ln_tsd_dmp = .TRUE. ! forces the initialization when tradmp is used + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dta_tsd_init : Temperature & Salinity data ' + WRITE(numout,*) '~~~~~~~~~~~~ ' + WRITE(numout,*) ' Namelist namtsd' + WRITE(numout,*) ' Initialisation of ocean T & S with T &S input data ln_tsd_init = ', ln_tsd_init + WRITE(numout,*) ' damping of ocean T & S toward T &S input data ln_tsd_dmp = ', ln_tsd_dmp + WRITE(numout,*) + IF( .NOT.ln_tsd_init .AND. .NOT.ln_tsd_dmp ) THEN + WRITE(numout,*) + WRITE(numout,*) ' ===>> T & S data not used' + ENDIF + ENDIF + ! + IF( ln_rstart .AND. ln_tsd_init ) THEN + CALL ctl_warn( 'dta_tsd_init: ocean restart and T & S data intialisation, ', & + & 'we keep the restart T & S values and set ln_tsd_init to FALSE' ) + ln_tsd_init = .FALSE. + ENDIF + ! + ! ! allocate the arrays (if necessary) + IF( ln_tsd_init .OR. ln_tsd_dmp ) THEN + ! + ALLOCATE( sf_tsd(jpts), STAT=ierr0 ) + IF( ierr0 > 0 ) THEN + CALL ctl_stop( 'dta_tsd_init: unable to allocate sf_tsd structure' ) ; RETURN + ENDIF + ! + ALLOCATE( sf_tsd(jp_tem)%fnow(jpi,jpj,jpk) , STAT=ierr0 ) + IF( sn_tem%ln_tint ) ALLOCATE( sf_tsd(jp_tem)%fdta(jpi,jpj,jpk,2) , STAT=ierr1 ) + ALLOCATE( sf_tsd(jp_sal)%fnow(jpi,jpj,jpk) , STAT=ierr2 ) + IF( sn_sal%ln_tint ) ALLOCATE( sf_tsd(jp_sal)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 ) + ! + IF( ierr0 + ierr1 + ierr2 + ierr3 > 0 ) THEN + CALL ctl_stop( 'dta_tsd : unable to allocate T & S data arrays' ) ; RETURN + ENDIF + ! ! fill sf_tsd with sn_tem & sn_sal and control print + slf_i(jp_tem) = sn_tem ; slf_i(jp_sal) = sn_sal + CALL fld_fill( sf_tsd, slf_i, cn_dir, 'dta_tsd', 'Temperature & Salinity data', 'namtsd', no_print ) + ! + ENDIF + ! + END SUBROUTINE dta_tsd_init + + + SUBROUTINE dta_tsd( kt, ptsd ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dta_tsd *** + !! + !! ** Purpose : provides T and S data at kt + !! + !! ** Method : - call fldread routine + !! - ORCA_R2: add some hand made alteration to read data + !! - s- or mixed z-s coordinate: vertical interpolation on model mesh + !! - ln_tsd_dmp=F: deallocates the T-S data structure + !! as T-S data are no are used + !! + !! ** Action : ptsd T-S data on medl mesh and interpolated at time-step kt + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step + REAL(dp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT( out) :: ptsd ! T & S data + ! + INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies + INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers + INTEGER, DIMENSION(jpts), SAVE :: irec_b, irec_n + REAL(dp):: zl, zi ! local scalars + REAL(dp), DIMENSION(jpk) :: ztp, zsp ! 1D workspace + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only for the full domain + IF( ln_tile ) CALL dom_tile_stop( ldhold=.TRUE. ) ! Use full domain + CALL fld_read( kt, 1, sf_tsd ) !== read T & S data at kt time step ==! + ! + ! +!!gm This should be removed from the code ===>>>> T & S files has to be changed + ! + ! !== ORCA_R2 configuration and T & S damping ==! + IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN + IF( nn_cfg == 2 .AND. ln_tsd_dmp ) THEN ! some hand made alterations + irec_n(jp_tem) = sf_tsd(jp_tem)%nrec(2,sf_tsd(jp_tem)%naa) ! Determine if there is new data (ln_tint = F) + irec_n(jp_sal) = sf_tsd(jp_sal)%nrec(2,sf_tsd(jp_sal)%naa) ! If not, then do not apply the increments + IF( kt == nit000 ) irec_b(:) = -1 + ! + ij0 = 101 + nn_hls ; ij1 = 109 + nn_hls ! Reduced T & S in the Alboran Sea + ii0 = 141 + nn_hls - 1 ; ii1 = 155 + nn_hls - 1 + IF( sf_tsd(jp_tem)%ln_tint .OR. irec_n(jp_tem) /= irec_b(jp_tem) ) THEN + DO jj = mj0(ij0), mj1(ij1) + DO ji = mi0(ii0), mi1(ii1) + sf_tsd(jp_tem)%fnow(ji,jj,13:13) = sf_tsd(jp_tem)%fnow(ji,jj,13:13) - 0.20_wp + sf_tsd(jp_tem)%fnow(ji,jj,14:15) = sf_tsd(jp_tem)%fnow(ji,jj,14:15) - 0.35_wp + sf_tsd(jp_tem)%fnow(ji,jj,16:25) = sf_tsd(jp_tem)%fnow(ji,jj,16:25) - 0.40_wp + END DO + END DO + irec_b(jp_tem) = irec_n(jp_tem) + ENDIF + ! + IF( sf_tsd(jp_sal)%ln_tint .OR. irec_n(jp_sal) /= irec_b(jp_sal) ) THEN + DO jj = mj0(ij0), mj1(ij1) + DO ji = mi0(ii0), mi1(ii1) + sf_tsd(jp_sal)%fnow(ji,jj,13:13) = sf_tsd(jp_sal)%fnow(ji,jj,13:13) - 0.15_wp + sf_tsd(jp_sal)%fnow(ji,jj,14:15) = sf_tsd(jp_sal)%fnow(ji,jj,14:15) - 0.25_wp + sf_tsd(jp_sal)%fnow(ji,jj,16:17) = sf_tsd(jp_sal)%fnow(ji,jj,16:17) - 0.30_wp + sf_tsd(jp_sal)%fnow(ji,jj,18:25) = sf_tsd(jp_sal)%fnow(ji,jj,18:25) - 0.35_wp + END DO + END DO + irec_b(jp_sal) = irec_n(jp_sal) + ENDIF + ! + ij0 = 87 + nn_hls ; ij1 = 96 + nn_hls ! Reduced temperature in Red Sea + ii0 = 148 + nn_hls - 1 ; ii1 = 160 + nn_hls - 1 + sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 4:10 ) = 7.0_wp + sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 11:13 ) = 6.5_wp + sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 14:20 ) = 6.0_wp + ENDIF + ENDIF +!!gm end + IF( ln_tile ) CALL dom_tile_start( ldhold=.TRUE. ) ! Revert to tile domain + ENDIF + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) + ptsd(ji,jj,jk,jp_tem) = sf_tsd(jp_tem)%fnow(ji,jj,jk) ! NO mask + ptsd(ji,jj,jk,jp_sal) = sf_tsd(jp_sal)%fnow(ji,jj,jk) + END_3D + ! +! JC I think it's more convenient to consider the general sco case as the rule +! IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 .AND. lwp )THEN + WRITE(numout,*) + WRITE(numout,*) 'dta_tsd: interpolates T & S data onto the s- or mixed s-z-coordinate mesh' + ENDIF + ENDIF + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! vertical interpolation of T & S + DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points + zl = gdept_0(ji,jj,jk) + IF( zl < gdept_1d(1 ) ) THEN ! above the first level of data + ztp(jk) = ptsd(ji,jj,1 ,jp_tem) + zsp(jk) = ptsd(ji,jj,1 ,jp_sal) + ELSEIF( zl > gdept_1d(jpk) ) THEN ! below the last level of data + ztp(jk) = ptsd(ji,jj,jpkm1,jp_tem) + zsp(jk) = ptsd(ji,jj,jpkm1,jp_sal) + ELSE ! inbetween : vertical interpolation between jkk & jkk+1 + DO jkk = 1, jpkm1 ! when gdept(jkk) < zl < gdept(jkk+1) + IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN + zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) + ztp(jk) = ptsd(ji,jj,jkk,jp_tem) + ( ptsd(ji,jj,jkk+1,jp_tem) - ptsd(ji,jj,jkk,jp_tem) ) * zi + zsp(jk) = ptsd(ji,jj,jkk,jp_sal) + ( ptsd(ji,jj,jkk+1,jp_sal) - ptsd(ji,jj,jkk,jp_sal) ) * zi + ENDIF + END DO + ENDIF + END DO + DO jk = 1, jpkm1 + ptsd(ji,jj,jk,jp_tem) = ztp(jk) * tmask(ji,jj,jk) ! mask required for mixed zps-s-coord + ptsd(ji,jj,jk,jp_sal) = zsp(jk) * tmask(ji,jj,jk) + END DO + ptsd(ji,jj,jpk,jp_tem) = 0._wp + ptsd(ji,jj,jpk,jp_sal) = 0._wp + END_2D + ! +! ELSE !== z- or zps- coordinate ==! +! ! +! DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) +! ptsd(ji,jj,jk,jp_tem) = ptsd(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) ! Mask +! ptsd(ji,jj,jk,jp_sal) = ptsd(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) +! END_3D +! ! +! IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level +! DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) +! ik = mbkt(ji,jj) +! IF( ik > 1 ) THEN +! zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) +! ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik-1,jp_tem) +! ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik-1,jp_sal) +! ENDIF +! ik = mikt(ji,jj) +! IF( ik > 1 ) THEN +! zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) +! ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik+1,jp_tem) +! ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik+1,jp_sal) +! END IF +! END_2D +! ENDIF +! ! +! ENDIF + ! + IF( .NOT.ln_tsd_dmp ) THEN !== deallocate T & S structure ==! + ! (data used only for initialisation) + IF(lwp) WRITE(numout,*) 'dta_tsd: deallocte T & S arrays as they are only use to initialize the run' + DEALLOCATE( sf_tsd(jp_tem)%fnow ) ! T arrays in the structure + IF( sf_tsd(jp_tem)%ln_tint ) DEALLOCATE( sf_tsd(jp_tem)%fdta ) + DEALLOCATE( sf_tsd(jp_sal)%fnow ) ! S arrays in the structure + IF( sf_tsd(jp_sal)%ln_tint ) DEALLOCATE( sf_tsd(jp_sal)%fdta ) + DEALLOCATE( sf_tsd ) ! the structure itself + ENDIF + ! + END SUBROUTINE dta_tsd + + !!====================================================================== +END MODULE dtatsd \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/istate.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/istate.F90 new file mode 100644 index 0000000..f9d2163 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/istate.F90 @@ -0,0 +1,171 @@ +MODULE istate + !!====================================================================== + !! *** MODULE istate *** + !! Ocean state : initial state setting + !!===================================================================== + !! History : OPA ! 1989-12 (P. Andrich) Original code + !! 5.0 ! 1991-11 (G. Madec) rewritting + !! 6.0 ! 1996-01 (G. Madec) terrain following coordinates + !! 8.0 ! 2001-09 (M. Levy, M. Ben Jelloul) istate_eel + !! 8.0 ! 2001-09 (M. Levy, M. Ben Jelloul) istate_uvg + !! NEMO 1.0 ! 2003-08 (G. Madec, C. Talandier) F90: Free form, modules + EEL R5 + !! - ! 2004-05 (A. Koch-Larrouy) istate_gyre + !! 2.0 ! 2006-07 (S. Masson) distributed restart using iom + !! 3.3 ! 2010-10 (C. Ethe) merge TRC-TRA + !! 3.4 ! 2011-04 (G. Madec) Merge of dtatem and dtasal & suppression of tb,tn/sb,sn + !! 3.7 ! 2016-04 (S. Flavoni) introduce user defined initial state + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! istate_init : initial state setting + !! istate_uvg : initial velocity in geostropic balance + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE daymod ! calendar + USE dtatsd ! data temperature and salinity (dta_tsd routine) + USE dtauvd ! data: U & V current (dta_uvd routine) + USE domvvl ! varying vertical mesh + USE wet_dry ! wetting and drying (needed for wad_istate) + USE usrdef_istate ! User defined initial state + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lib_mpp ! MPP library + USE lbclnk ! lateal boundary condition / mpp exchanges + USE restart ! restart + +#if defined key_agrif + USE agrif_oce ! initial state interpolation + USE agrif_oce_interp +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC istate_init ! routine called by nemogcm.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: istate.F90 15052 2021-06-24 14:39:14Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE istate_init( Kbb, Kmm, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE istate_init *** + !! + !! ** Purpose : Initialization of the dynamics and tracer fields. + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: Kbb, Kmm, Kaa ! ocean time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgdept ! 3D table for qco substitute +!!gm see comment further down + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace +!!gm end + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'istate_init : Initialization of the dynamics and tracers' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + + CALL dta_tsd_init ! Initialisation of T & S input data + IF( ln_c1d) CALL dta_uvd_init ! Initialisation of U & V input data (c1d only) + + ts (:,:,:,:,Kaa) = 0._wp ; rn2 (:,:,: ) = 0._wp ! set one for all to 0 at levels 1 and jpk + IF ( ALLOCATED( rhd ) ) THEN ! SWE, for example, will not have allocated these + rhd (:,:,: ) = 0._wp ; rhop (:,:,: ) = 0._wp ! set one for all to 0 at level jpk + rn2b (:,:,: ) = 0._wp ! set one for all to 0 at level jpk + rab_b(:,:,:,: ) = 0._wp ; rab_n(:,:,:,:) = 0._wp ! set one for all to 0 at level jpk + ENDIF +#if defined key_agrif + uu (:,:,: ,Kaa) = 0._wp ! used in agrif_oce_sponge at initialization + vv (:,:,: ,Kaa) = 0._wp ! used in agrif_oce_sponge at initialization +#endif + +#if defined key_agrif + IF ( .NOT.Agrif_root() .AND. ln_init_chfrpar ) THEN + numror = 0 ! define numror = 0 -> no restart file to read + ln_1st_euler = .true. ! Set time-step indicator at nit000 (euler forward) + CALL day_init + CALL agrif_istate_oce( Kbb, Kmm, Kaa ) ! Interp from parent + ! + ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) + uu (:,:,: ,Kmm) = uu (:,:,: ,Kbb) + vv (:,:,: ,Kmm) = vv (:,:,: ,Kbb) + ELSE +#endif + IF( ln_rstart ) THEN ! Restart from a file + ! ! ------------------- + CALL rst_read( Kbb, Kmm ) ! Read the restart file + CALL day_init ! model calendar (using both namelist and restart infos) + ! + ELSE ! Start from rest + ! ! --------------- + numror = 0 ! define numror = 0 -> no restart file to read + l_1st_euler = .true. ! Set time-step indicator at nit000 (euler forward) + CALL day_init ! model calendar (using both namelist and restart infos) + ! ! Initialization of ocean to zero + ! + IF( ln_tsd_init ) THEN + CALL dta_tsd( nit000, ts(:,:,:,:,Kbb) ) ! read 3D T and S data at nit000 + ENDIF + ! + IF( ln_uvd_init .AND. ln_c1d ) THEN + CALL dta_uvd( nit000, Kbb, uu(:,:,:,Kbb), vv(:,:,:,Kbb) ) ! read 3D U and V data at nit000 + ELSE + uu (:,:,:,Kbb) = 0._wp ! set the ocean at rest + vv (:,:,:,Kbb) = 0._wp + ENDIF + ! + ! + IF( .NOT. ln_tsd_init .AND. .NOT. ln_uvd_init ) THEN + DO jk = 1, jpk + zgdept(:,:,jk) = gdept(:,:,jk,Kbb) + END DO + CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb) ) + ! make sure that periodicities are properly applied + CALL lbc_lnk( 'istate', ts(:,:,:,jp_tem,Kbb), 'T', 1._dp, ts(:,:,:,jp_sal,Kbb), 'T', 1._dp, & + & uu(:,:,:, Kbb), 'U', -1._dp, vv(:,:,:, Kbb), 'V', -1._dp ) + ENDIF + ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones + uu (:,:,:,Kmm) = uu (:,:,:,Kbb) + vv (:,:,:,Kmm) = vv (:,:,:,Kbb) + + ENDIF +#if defined key_agrif + ENDIF +#endif + ! + ! Initialize "now" and "before" barotropic velocities: + ! Do it whatever the free surface method, these arrays being eventually used + ! + uu_b(:,:,Kmm) = 0._wp ; vv_b(:,:,Kmm) = 0._wp + uu_b(:,:,Kbb) = 0._wp ; vv_b(:,:,Kbb) = 0._wp + ! +!!gm the use of umsak & vmask is not necessary below as uu(:,:,:,Kmm), vv(:,:,:,Kmm), uu(:,:,:,Kbb), vv(:,:,:,Kbb) are always masked + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + uu_b(ji,jj,Kmm) = uu_b(ji,jj,Kmm) + e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) * umask(ji,jj,jk) + vv_b(ji,jj,Kmm) = vv_b(ji,jj,Kmm) + e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) * vmask(ji,jj,jk) + ! + uu_b(ji,jj,Kbb) = uu_b(ji,jj,Kbb) + e3u(ji,jj,jk,Kbb) * uu(ji,jj,jk,Kbb) * umask(ji,jj,jk) + vv_b(ji,jj,Kbb) = vv_b(ji,jj,Kbb) + e3v(ji,jj,jk,Kbb) * vv(ji,jj,jk,Kbb) * vmask(ji,jj,jk) + END_3D + ! + uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm) + vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * r1_hv(:,:,Kmm) + ! + uu_b(:,:,Kbb) = uu_b(:,:,Kbb) * r1_hu(:,:,Kbb) + vv_b(:,:,Kbb) = vv_b(:,:,Kbb) * r1_hv(:,:,Kbb) + ! + END SUBROUTINE istate_init + + !!====================================================================== +END MODULE istate diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/phycst.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/phycst.F90 new file mode 100644 index 0000000..27ebf4e --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DOM/phycst.F90 @@ -0,0 +1,141 @@ +MODULE phycst + !!====================================================================== + !! *** MODULE phycst *** + !! Definition of of both ocean and ice parameters used in the code + !!===================================================================== + !! History : OPA ! 1990-10 (C. Levy - G. Madec) Original code + !! 8.1 ! 1991-11 (G. Madec, M. Imbard) cosmetic changes + !! NEMO 1.0 ! 2002-08 (G. Madec, C. Ethe) F90, add ice constants + !! - ! 2006-08 (G. Madec) style + !! 3.2 ! 2006-08 (S. Masson, G. Madec) suppress useless variables + style + !! 3.4 ! 2011-11 (C. Harris) minor changes for CICE constants + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! phy_cst : define and print physical constant and domain parameters + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC phy_cst ! routine called by inipar.F90 + + REAL(wp), PUBLIC :: rpi = 3.141592653589793_wp !: pi + REAL(wp), PUBLIC :: rad = 3.141592653589793_wp / 180._wp !: conversion from degre into radian + REAL(wp), PUBLIC :: rsmall = 0.5 * EPSILON( 1.e0 ) !: smallest real computer value + + REAL(wp), PUBLIC :: rday = 24.*60.*60. !: day [s] + REAL(wp), PUBLIC :: rsiyea !: sideral year [s] + REAL(wp), PUBLIC :: rsiday !: sideral day [s] + REAL(wp), PUBLIC :: raamo = 12._wp !: number of months in one year + REAL(wp), PUBLIC :: rjjhh = 24._wp !: number of hours in one day + REAL(wp), PUBLIC :: rhhmm = 60._wp !: number of minutes in one hour + REAL(wp), PUBLIC :: rmmss = 60._wp !: number of seconds in one minute + REAL(wp), PUBLIC :: omega !: earth rotation parameter [s-1] + REAL(wp), PUBLIC :: ra = 6371229._wp !: earth radius [m] + REAL(wp), PUBLIC :: grav = 9.80665_wp !: gravity [m/s2] + REAL(wp), PUBLIC :: rt0 = 273.15_wp !: freezing point of fresh water [Kelvin] + + REAL(wp), PUBLIC :: rho0 !: volumic mass of reference [kg/m3] + REAL(wp), PUBLIC :: r1_rho0 !: = 1. / rho0 [m3/kg] + REAL(wp), PUBLIC :: rcp !: ocean specific heat [J/Kelvin] + REAL(wp), PUBLIC :: r1_rcp !: = 1. / rcp [Kelvin/J] + REAL(wp), PUBLIC :: rho0_rcp !: = rho0 * rcp + REAL(wp), PUBLIC :: r1_rho0_rcp !: = 1. / ( rho0 * rcp ) + + REAL(wp), PUBLIC :: emic = 0.97_wp !: emissivity of snow or ice (not used?) + + REAL(wp), PUBLIC :: sice = 6.0_wp !: salinity of ice (for pisces) [psu] + REAL(wp), PUBLIC :: soce = 34.7_wp !: salinity of sea (for pisces and isf) [psu] + REAL(wp), PUBLIC :: rLevap = 2.5e+6_wp !: latent heat of evaporation (water) + REAL(wp), PUBLIC :: vkarmn = 0.4_wp !: von Karman constant + REAL(wp), PUBLIC :: vkarmn2 = 0.4_wp*0.4_wp !: square of von Karman constant + REAL(wp), PUBLIC :: stefan = 5.67e-8_wp !: Stefan-Boltzmann constant + + REAL(wp), PUBLIC :: rhos = 330._wp !: volumic mass of snow [kg/m3] + REAL(wp), PUBLIC :: rhoi = 917._wp !: volumic mass of sea ice [kg/m3] + REAL(wp), PUBLIC :: rhow = 1000._wp !: volumic mass of freshwater in melt ponds [kg/m3] + REAL(wp), PUBLIC :: rcnd_i = 2.034396_wp !: thermal conductivity of fresh ice [W/m/K] + REAL(wp), PUBLIC :: rcpi = 2067.0_wp !: specific heat of fresh ice [J/kg/K] + REAL(wp), PUBLIC :: rLsub = 2.834e+6_wp !: pure ice latent heat of sublimation [J/kg] + REAL(wp), PUBLIC :: rLfus = 0.334e+6_wp !: latent heat of fusion of fresh ice [J/kg] + REAL(wp), PUBLIC :: rTmlt = 0.054_wp !: decrease of seawater meltpoint with salinity + + REAL(wp), PUBLIC :: r1_rhoi !: 1 / rhoi + REAL(wp), PUBLIC :: r1_rhos !: 1 / rhos + REAL(wp), PUBLIC :: r1_rcpi !: 1 / rcpi + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: phycst.F90 14072 2020-12-04 07:48:38Z laurent $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE phy_cst + !!---------------------------------------------------------------------- + !! *** ROUTINE phy_cst *** + !! + !! ** Purpose : set and print the constants + !!---------------------------------------------------------------------- + + rsiyea = 365.25_wp * rday * 2._wp * rpi / 6.283076_wp + rsiday = rday / ( 1._wp + rday / rsiyea ) +#if defined key_cice + omega = 7.292116e-05 +#else + omega = 2._wp * rpi / rsiday +#endif + + r1_rhoi = 1._wp / rhoi + r1_rhos = 1._wp / rhos + r1_rcpi = 1._wp / rcpi + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'phy_cst : initialization of ocean parameters and constants' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) ' mathematical constant rpi = ', rpi + WRITE(numout,*) ' day rday = ', rday, ' s' + WRITE(numout,*) ' sideral year rsiyea = ', rsiyea, ' s' + WRITE(numout,*) ' sideral day rsiday = ', rsiday, ' s' + WRITE(numout,*) ' omega omega = ', omega, ' s^-1' + WRITE(numout,*) + WRITE(numout,*) ' nb of months per year raamo = ', raamo, ' months' + WRITE(numout,*) ' nb of hours per day rjjhh = ', rjjhh, ' hours' + WRITE(numout,*) ' nb of minutes per hour rhhmm = ', rhhmm, ' mn' + WRITE(numout,*) ' nb of seconds per minute rmmss = ', rmmss, ' s' + WRITE(numout,*) + WRITE(numout,*) ' earth radius ra = ', ra , ' m' + WRITE(numout,*) ' gravity grav = ', grav , ' m/s^2' + WRITE(numout,*) + WRITE(numout,*) ' freezing point of water rt0 = ', rt0 , ' K' + WRITE(numout,*) + WRITE(numout,*) ' reference density and heat capacity now defined in eosbn2.f90' + WRITE(numout,*) + WRITE(numout,*) ' thermal conductivity of pure ice = ', rcnd_i , ' J/s/m/K' + WRITE(numout,*) ' thermal conductivity of snow is defined in a namelist ' + WRITE(numout,*) ' fresh ice specific heat = ', rcpi , ' J/kg/K' + WRITE(numout,*) ' latent heat of fusion of fresh ice / snow = ', rLfus , ' J/kg' + WRITE(numout,*) ' latent heat of subl. of fresh ice / snow = ', rLsub , ' J/kg' + WRITE(numout,*) ' density of sea ice = ', rhoi , ' kg/m^3' + WRITE(numout,*) ' density of snow = ', rhos , ' kg/m^3' + WRITE(numout,*) ' density of freshwater (in melt ponds) = ', rhow , ' kg/m^3' + WRITE(numout,*) ' salinity of ice (for pisces) = ', sice , ' psu' + WRITE(numout,*) ' salinity of sea (for pisces and isf) = ', soce , ' psu' + WRITE(numout,*) ' latent heat of evaporation (water) = ', rLevap , ' J/m^3' + WRITE(numout,*) ' von Karman constant = ', vkarmn + WRITE(numout,*) ' Stefan-Boltzmann constant = ', stefan , ' J/s/m^2/K^4' + WRITE(numout,*) + WRITE(numout,*) ' conversion: degre ==> radian rad = ', rad + WRITE(numout,*) + WRITE(numout,*) ' smallest real computer value rsmall = ', rsmall + ENDIF + + END SUBROUTINE phy_cst + + !!====================================================================== +END MODULE phycst \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/divhor.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/divhor.F90 new file mode 100644 index 0000000..f485276 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/divhor.F90 @@ -0,0 +1,108 @@ +MODULE divhor + !!============================================================================== + !! *** MODULE divhor *** + !! Ocean diagnostic variable : now horizontal divergence + !!============================================================================== + !! History : 1.0 ! 2002-09 (G. Madec, E. Durand) Free form, F90 + !! - ! 2005-01 (J. Chanut) Unstructured open boundaries + !! - ! 2003-08 (G. Madec) merged of cur and div, free form, F90 + !! - ! 2005-01 (J. Chanut, A. Sellar) unstructured open boundaries + !! 3.3 ! 2010-09 (D.Storkey and E.O'Dea) bug fixes for BDY module + !! - ! 2010-10 (R. Furner, G. Madec) runoff and cla added directly here + !! 3.7 ! 2014-01 (G. Madec) suppression of velocity curl from in-core memory + !! - ! 2014-12 (G. Madec) suppression of cross land advection option + !! - ! 2015-10 (G. Madec) add velocity and rnf flag in argument of div_hor + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! div_hor : Compute the horizontal divergence field + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce, ONLY : ln_rnf ! river runoff + USE sbcrnf , ONLY : sbc_rnf_div ! river runoff + USE isf_oce, ONLY : ln_isf ! ice shelf + USE isfhdiv, ONLY : isf_hdiv ! ice shelf +#if defined key_asminc + USE asminc ! Assimilation increment +#endif + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC div_hor ! routine called by step.F90 and istate.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: divhor.F90 15150 2021-07-27 10:38:24Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE div_hor( kt, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE div_hor *** + !! + !! ** Purpose : compute the horizontal divergence at now time-step + !! + !! ** Method : the now divergence is computed as : + !! hdiv = 1/(e1e2t*e3t) ( di[e2u*e3u un] + dj[e1v*e3v vn] ) + !! and correct with runoff inflow (div_rnf) and cross land flow (div_cla) + !! + !! ** Action : - update hdiv, the now horizontal divergence + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('div_hor') + ! + IF( kt == nit000 ) THEN + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'div_hor : horizontal velocity divergence ' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) + hdiv(ji,jj,jk) = 0._wp ! initialize hdiv for the halos at the first time step + END_3D + ENDIF + ! + DO_3D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls, 1, jpkm1 ) !== Horizontal divergence ==! + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + hdiv(ji,jj,jk) = ( ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * uu(ji ,jj,jk,Kmm) & + & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * uu(ji-1,jj,jk,Kmm) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * vv(ji,jj ,jk,Kmm) & + & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vv(ji,jj-1,jk,Kmm) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + ! + IF( ln_rnf ) CALL sbc_rnf_div( hdiv, Kmm ) !== runoffs ==! (update hdiv field) + ! +#if defined key_asminc + IF( ln_sshinc .AND. ln_asmiau ) CALL ssh_asm_div( kt, Kbb, Kmm, hdiv ) !== SSH assimilation ==! (update hdiv field) + ! +#endif + IF( ln_isf ) CALL isf_hdiv( kt, Kmm, hdiv ) !== ice shelf ==! (update hdiv field) + ! + IF( nn_hls==1 ) CALL lbc_lnk( 'divhor', hdiv, 'T', 1.0_wp ) ! (no sign change) + ! ! needed for ww in sshwzv + IF( ln_timing ) CALL timing_stop('div_hor') + ! + END SUBROUTINE div_hor + + !!====================================================================== +END MODULE divhor \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynadv.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynadv.F90 new file mode 100644 index 0000000..c689a20 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynadv.F90 @@ -0,0 +1,148 @@ +MODULE dynadv + !!============================================================================== + !! *** MODULE dynadv *** + !! Ocean active tracers: advection scheme control + !!============================================================================== + !! History : 1.0 ! 2006-11 (G. Madec) Original code + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.6 ! 2015-05 (N. Ducousso, G. Madec) add Hollingsworth scheme as an option + !! 4.0 ! 2017-07 (G. Madec) add a linear dynamics option + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_adv : compute the momentum advection trend + !! dyn_adv_init : control the different options of advection scheme + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE dynadv_cen2 ! centred flux form advection (dyn_adv_cen2 routine) + USE dynadv_ubs ! UBS flux form advection (dyn_adv_ubs routine) + USE dynkeg ! kinetic energy gradient (dyn_keg routine) + USE dynzad ! vertical advection (dyn_zad routine) + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_adv ! routine called by step module + PUBLIC dyn_adv_init ! routine called by opa module + + ! !!* namdyn_adv namelist * + LOGICAL, PUBLIC :: ln_dynadv_OFF !: linear dynamics (no momentum advection) + LOGICAL, PUBLIC :: ln_dynadv_vec !: vector form + INTEGER, PUBLIC :: nn_dynkeg !: scheme of grad(KE): =0 C2 ; =1 Hollingsworth + LOGICAL, PUBLIC :: ln_dynadv_cen2 !: flux form - 2nd order centered scheme flag + LOGICAL, PUBLIC :: ln_dynadv_ubs !: flux form - 3rd order UBS scheme flag + + INTEGER, PUBLIC :: n_dynadv !: choice of the formulation and scheme for momentum advection + ! ! associated indices: + INTEGER, PUBLIC, PARAMETER :: np_LIN_dyn = 0 ! no advection: linear dynamics + INTEGER, PUBLIC, PARAMETER :: np_VEC_c2 = 1 ! vector form : 2nd order centered scheme + INTEGER, PUBLIC, PARAMETER :: np_FLX_c2 = 2 ! flux form : 2nd order centered scheme + INTEGER, PUBLIC, PARAMETER :: np_FLX_ubs = 3 ! flux form : 3rd order Upstream Biased Scheme + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynadv.F90 14053 2020-12-03 13:48:38Z techene $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_adv( kt, Kbb, Kmm, puu, pvv, Krhs ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_adv *** + !! + !! ** Purpose : compute the ocean momentum advection trend. + !! + !! ** Method : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the advection term following n_dynadv + !! + !! NB: in flux form advection (ln_dynadv_cen2 or ln_dynadv_ubs=T) + !! a metric term is add to the coriolis term while in vector form + !! it is the relative vorticity which is added to coriolis term + !! (see dynvor module). + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'dyn_adv' ) + ! + SELECT CASE( n_dynadv ) !== compute advection trend and add it to general trend ==! + CASE( np_VEC_c2 ) + CALL dyn_keg ( kt, nn_dynkeg, Kmm, puu, pvv, Krhs ) ! vector form : horizontal gradient of kinetic energy + CALL dyn_zad ( kt, Kmm, puu, pvv, Krhs ) ! vector form : vertical advection + CASE( np_FLX_c2 ) + CALL dyn_adv_cen2( kt, Kmm, puu, pvv, Krhs ) ! 2nd order centered scheme + CASE( np_FLX_ubs ) + CALL dyn_adv_ubs ( kt, Kbb, Kmm, puu, pvv, Krhs ) ! 3rd order UBS scheme (UP3) + END SELECT + ! + IF( ln_timing ) CALL timing_stop( 'dyn_adv' ) + ! + END SUBROUTINE dyn_adv + + + SUBROUTINE dyn_adv_init + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_adv_init *** + !! + !! ** Purpose : Control the consistency between namelist options for + !! momentum advection formulation & scheme and set n_dynadv + !!---------------------------------------------------------------------- + INTEGER :: ioptio, ios ! Local integer + ! + NAMELIST/namdyn_adv/ ln_dynadv_OFF, ln_dynadv_vec, nn_dynkeg, ln_dynadv_cen2, ln_dynadv_ubs + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_adv_init : choice/control of the momentum advection scheme' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + READ ( numnam_ref, namdyn_adv, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_adv in reference namelist' ) + READ ( numnam_cfg, namdyn_adv, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist' ) + IF(lwm) WRITE ( numond, namdyn_adv ) + + IF(lwp) THEN ! Namelist print + WRITE(numout,*) ' Namelist namdyn_adv : chose a advection formulation & scheme for momentum' + WRITE(numout,*) ' linear dynamics : no momentum advection ln_dynadv_OFF = ', ln_dynadv_OFF + WRITE(numout,*) ' Vector form: 2nd order centered scheme ln_dynadv_vec = ', ln_dynadv_vec + WRITE(numout,*) ' with Hollingsworth scheme (=1) or not (=0) nn_dynkeg = ', nn_dynkeg + WRITE(numout,*) ' flux form: 2nd order centred scheme ln_dynadv_cen2 = ', ln_dynadv_cen2 + WRITE(numout,*) ' 3rd order UBS scheme ln_dynadv_ubs = ', ln_dynadv_ubs + ENDIF + + ioptio = 0 ! parameter control and set n_dynadv + IF( ln_dynadv_OFF ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_LIN_dyn ; ENDIF + IF( ln_dynadv_vec ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_VEC_c2 ; ENDIF + IF( ln_dynadv_cen2 ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_FLX_c2 ; ENDIF + IF( ln_dynadv_ubs ) THEN ; ioptio = ioptio + 1 ; n_dynadv = np_FLX_ubs ; ENDIF + + IF( ioptio /= 1 ) CALL ctl_stop( 'choose ONE and only ONE advection scheme' ) + IF( nn_dynkeg /= nkeg_C2 .AND. nn_dynkeg /= nkeg_HW ) CALL ctl_stop( 'KEG scheme wrong value of nn_dynkeg' ) +#if defined key_qcoTest_FluxForm + IF( ln_dynadv_vec ) THEN CALL ctl_stop( 'STOP', 'key_qcoTest_FluxForm requires flux form advection' ) +#endif + + IF(lwp) THEN ! Print the choice + WRITE(numout,*) + SELECT CASE( n_dynadv ) + CASE( np_LIN_dyn ) ; WRITE(numout,*) ' ==>>> linear dynamics : no momentum advection used' + CASE( np_VEC_c2 ) ; WRITE(numout,*) ' ==>>> vector form : keg + zad + vor is used' + IF( nn_dynkeg == nkeg_C2 ) WRITE(numout,*) ' with Centered standard keg scheme' + IF( nn_dynkeg == nkeg_HW ) WRITE(numout,*) ' with Hollingsworth keg scheme' + CASE( np_FLX_c2 ) ; WRITE(numout,*) ' ==>>> flux form : 2nd order scheme is used' + CASE( np_FLX_ubs ) ; WRITE(numout,*) ' ==>>> flux form : UBS scheme is used' + END SELECT + ENDIF + ! + END SUBROUTINE dyn_adv_init + + !!====================================================================== +END MODULE dynadv \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynadv_cen2.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynadv_cen2.F90 new file mode 100644 index 0000000..7ded9a4 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynadv_cen2.F90 @@ -0,0 +1,144 @@ +MODULE dynadv_cen2 + !!====================================================================== + !! *** MODULE dynadv *** + !! Ocean dynamics: Update the momentum trend with the flux form advection + !! using a 2nd order centred scheme + !!====================================================================== + !! History : 2.0 ! 2006-08 (G. Madec, S. Theetten) Original code + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_adv_cen2 : flux form momentum advection (ln_dynadv_cen2=T) using a 2nd order centred scheme + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE prtctl ! Print control + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_adv_cen2 ! routine called by step.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynadv_cen2.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_adv_cen2( kt, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_adv_cen2 *** + !! + !! ** Purpose : Compute the now momentum advection trend in flux form + !! and the general trend of the momentum equation. + !! + !! ** Method : Trend evaluated using now fields (centered in time) + !! + !! ** Action : (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) updated with the now vorticity term trend + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zfu_f, zfu + REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zfu_t, zfu_uw + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zfv_f, zfv, zfw + REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zfv_t, zfv_vw + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_adv_cen2 : 2nd order flux form momentum advection' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ENDIF + ! + IF( l_trddyn ) THEN ! trends: store the input trends + zfu_uw(:,:,:) = puu(:,:,:,Krhs) + zfv_vw(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + ! + ! !== Horizontal advection ==! + ! + DO jk = 1, jpkm1 ! horizontal transport + DO_2D( 1, 1, 1, 1 ) + zfu(ji,jj,jk) = 0.25_wp * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * puu(ji,jj,jk,Kmm) + zfv(ji,jj,jk) = 0.25_wp * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * pvv(ji,jj,jk,Kmm) + END_2D + DO_2D( 1, 0, 1, 0 ) ! horizontal momentum fluxes (at T- and F-point) + zfu_t(ji+1,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj ,jk,Kmm) ) + zfv_f(ji ,jj ,jk) = ( zfv(ji,jj,jk) + zfv(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) ) + zfu_f(ji ,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) ) + zfv_t(ji ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji ,jj+1,jk,Kmm) ) + END_2D + DO_2D( 0, 0, 0, 0 ) ! divergence of horizontal momentum fluxes + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_t(ji+1,jj,jk) - zfu_t(ji,jj ,jk) & + & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) * r1_e1e2u(ji,jj) & + & / e3u(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfu_f(ji,jj ,jk) - zfu_f(ji-1,jj,jk) & + & + zfv_t(ji,jj+1,jk) - zfv_t(ji ,jj,jk) ) * r1_e1e2v(ji,jj) & + & / e3v(ji,jj,jk,Kmm) + END_2D + END DO + ! + IF( l_trddyn ) THEN ! trends: send trend to trddyn for diagnostic + zfu_uw(:,:,:) = puu(:,:,:,Krhs) - zfu_uw(:,:,:) + zfv_vw(:,:,:) = pvv(:,:,:,Krhs) - zfv_vw(:,:,:) + CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt, Kmm ) + zfu_t(:,:,:) = puu(:,:,:,Krhs) + zfv_t(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + ! + ! !== Vertical advection ==! + ! + DO_2D( 0, 0, 0, 0 ) ! surface/bottom advective fluxes set to zero + zfu_uw(ji,jj,jpk) = 0._wp ; zfv_vw(ji,jj,jpk) = 0._wp + zfu_uw(ji,jj, 1 ) = 0._wp ; zfv_vw(ji,jj, 1 ) = 0._wp + END_2D + IF( ln_linssh ) THEN ! linear free surface: advection through the surface + DO_2D( 0, 0, 0, 0 ) + zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji+1,jj) * ww(ji+1,jj,1) ) * puu(ji,jj,1,Kmm) + zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji,jj+1) * ww(ji,jj+1,1) ) * pvv(ji,jj,1,Kmm) + END_2D + ENDIF + DO jk = 2, jpkm1 ! interior advective fluxes + DO_2D( 0, 1, 0, 1 ) ! 1/4 * Vertical transport + zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) + END_2D + DO_2D( 0, 0, 0, 0 ) + zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji+1,jj ,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji,jj,jk-1,Kmm) ) + zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji ,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk-1,Kmm) ) + END_2D + END DO + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! divergence of vertical momentum flux divergence + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) & + & / e3u(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) & + & / e3v(ji,jj,jk,Kmm) + END_3D + ! + IF( l_trddyn ) THEN ! trends: send trend to trddyn for diagnostic + zfu_t(:,:,:) = puu(:,:,:,Krhs) - zfu_t(:,:,:) + zfv_t(:,:,:) = pvv(:,:,:,Krhs) - zfv_t(:,:,:) + CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt, Kmm ) + ENDIF + ! ! Control print + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' cen2 adv - Ua: ', mask1=umask, & + & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + + END SUBROUTINE dyn_adv_cen2 + + !!============================================================================== +END MODULE dynadv_cen2 \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynadv_ubs.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynadv_ubs.F90 new file mode 100644 index 0000000..671929d --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynadv_ubs.F90 @@ -0,0 +1,257 @@ +MODULE dynadv_ubs + !!====================================================================== + !! *** MODULE dynadv_ubs *** + !! Ocean dynamics: Update the momentum trend with the flux form advection + !! trend using a 3rd order upstream biased scheme + !!====================================================================== + !! History : 2.0 ! 2006-08 (R. Benshila, L. Debreu) Original code + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_adv_ubs : flux form momentum advection using (ln_dynadv=T) + !! an 3rd order Upstream Biased Scheme or Quick scheme + !! combined with 2nd or 4th order finite differences + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + REAL(wp), PARAMETER :: gamma1 = 1._wp/3._wp ! =1/4 quick ; =1/3 3rd order UBS + REAL(wp), PARAMETER :: gamma2 = 1._wp/32._wp ! =0 2nd order ; =1/32 4th order centred + + PUBLIC dyn_adv_ubs ! routine called by step.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynadv_ubs.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_adv_ubs( kt, Kbb, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_adv_ubs *** + !! + !! ** Purpose : Compute the now momentum advection trend in flux form + !! and the general trend of the momentum equation. + !! + !! ** Method : The scheme is the one implemeted in ROMS. It depends + !! on two parameter gamma1 and gamma2. The former control the + !! upstream baised part of the scheme and the later the centred + !! part: gamma1 = 0 pure centered (no diffusive part) + !! = 1/4 Quick scheme + !! = 1/3 3rd order Upstream biased scheme + !! gamma2 = 0 2nd order finite differencing + !! = 1/32 4th order finite differencing + !! For stability reasons, the first term of the fluxes which cor- + !! responds to a second order centered scheme is evaluated using + !! the now velocity (centered in time) while the second term which + !! is the diffusive part of the scheme, is evaluated using the + !! before velocity (forward in time). + !! Default value (hard coded in the begining of the module) are + !! gamma1=1/3 and gamma2=1/32. + !! + !! ** Action : - (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) updated with the 3D advective momentum trends + !! + !! Reference : Shchepetkin & McWilliams, 2005, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zui, zvj, zfuj, zfvi, zl_u, zl_v ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zfu_f, zfu + REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zfu_t, zfu_uw + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zfv_f, zfv, zfw + REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zfv_t, zfv_vw + REAL(wp), DIMENSION(A2D(nn_hls),jpk,2) :: zlu_uu, zlu_uv + REAL(wp), DIMENSION(A2D(nn_hls),jpk,2) :: zlv_vv, zlv_vu + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_adv_ubs : UBS flux form momentum advection' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ENDIF + ! + zfu_t(:,:,:) = 0._wp + zfv_t(:,:,:) = 0._wp + zfu_f(:,:,:) = 0._wp + zfv_f(:,:,:) = 0._wp + ! + zlu_uu(:,:,:,:) = 0._wp + zlv_vv(:,:,:,:) = 0._wp + zlu_uv(:,:,:,:) = 0._wp + zlv_vu(:,:,:,:) = 0._wp + ! + IF( l_trddyn ) THEN ! trends: store the input trends + zfu_uw(:,:,:) = puu(:,:,:,Krhs) + zfv_vw(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + ! ! =========================== ! + DO jk = 1, jpkm1 ! Laplacian of the velocity ! + ! ! =========================== ! + ! ! horizontal volume fluxes + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zfu(ji,jj,jk) = e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * puu(ji,jj,jk,Kmm) + zfv(ji,jj,jk) = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * pvv(ji,jj,jk,Kmm) + END_2D + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! laplacian + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zlu_uu(ji,jj,jk,1) = ( ( puu (ji+1,jj ,jk,Kbb) - puu (ji ,jj ,jk,Kbb) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( puu (ji-1,jj ,jk,Kbb) - puu (ji ,jj ,jk,Kbb) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * umask(ji ,jj ,jk) + zlv_vv(ji,jj,jk,1) = ( ( pvv (ji ,jj+1,jk,Kbb) - pvv (ji ,jj ,jk,Kbb) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( pvv (ji ,jj-1,jk,Kbb) - pvv (ji ,jj ,jk,Kbb) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * vmask(ji ,jj ,jk) + zlu_uv(ji,jj,jk,1) = ( puu (ji ,jj+1,jk,Kbb) - puu (ji ,jj ,jk,Kbb) ) * fmask(ji ,jj ,jk) & + & - ( puu (ji ,jj ,jk,Kbb) - puu (ji ,jj-1,jk,Kbb) ) * fmask(ji ,jj-1,jk) + zlv_vu(ji,jj,jk,1) = ( pvv (ji+1,jj ,jk,Kbb) - pvv (ji ,jj ,jk,Kbb) ) * fmask(ji ,jj ,jk) & + & - ( pvv (ji ,jj ,jk,Kbb) - pvv (ji-1,jj ,jk,Kbb) ) * fmask(ji-1,jj ,jk) + ! + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zlu_uu(ji,jj,jk,2) = ( ( zfu(ji+1,jj ,jk) - zfu(ji ,jj ,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( zfu(ji-1,jj ,jk) - zfu(ji ,jj ,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * umask(ji ,jj ,jk) + zlv_vv(ji,jj,jk,2) = ( ( zfv(ji ,jj+1,jk) - zfv(ji ,jj ,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( zfv(ji ,jj-1,jk) - zfv(ji ,jj ,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * vmask(ji ,jj ,jk) + zlu_uv(ji,jj,jk,2) = ( zfu(ji ,jj+1,jk) - zfu(ji ,jj ,jk) ) * fmask(ji ,jj ,jk) & + & - ( zfu(ji ,jj ,jk) - zfu(ji ,jj-1,jk) ) * fmask(ji ,jj-1,jk) + zlv_vu(ji,jj,jk,2) = ( zfv(ji+1,jj ,jk) - zfv(ji ,jj ,jk) ) * fmask(ji ,jj ,jk) & + & - ( zfv(ji ,jj ,jk) - zfv(ji-1,jj ,jk) ) * fmask(ji-1,jj ,jk) + END_2D + END DO + IF( nn_hls == 1 ) CALL lbc_lnk( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', -1.0_wp , zlu_uv(:,:,:,1), 'U', -1.0_wp, & + & zlu_uu(:,:,:,2), 'U', -1.0_wp , zlu_uv(:,:,:,2), 'U', -1.0_wp, & + & zlv_vv(:,:,:,1), 'V', -1.0_wp , zlv_vu(:,:,:,1), 'V', -1.0_wp, & + & zlv_vv(:,:,:,2), 'V', -1.0_wp , zlv_vu(:,:,:,2), 'V', -1.0_wp ) + ! + ! ! ====================== ! + ! ! Horizontal advection ! + DO jk = 1, jpkm1 ! ====================== ! + ! ! horizontal volume fluxes + DO_2D( 1, 1, 1, 1 ) + zfu(ji,jj,jk) = 0.25_wp * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * puu(ji,jj,jk,Kmm) + zfv(ji,jj,jk) = 0.25_wp * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * pvv(ji,jj,jk,Kmm) + END_2D + ! + DO_2D( 1, 0, 1, 0 ) ! horizontal momentum fluxes at T- and F-point + zui = ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj ,jk,Kmm) ) + zvj = ( pvv(ji,jj,jk,Kmm) + pvv(ji ,jj+1,jk,Kmm) ) + ! + IF( zui > 0 ) THEN ; zl_u = zlu_uu(ji ,jj,jk,1) + ELSE ; zl_u = zlu_uu(ji+1,jj,jk,1) + ENDIF + IF( zvj > 0 ) THEN ; zl_v = zlv_vv(ji,jj ,jk,1) + ELSE ; zl_v = zlv_vv(ji,jj+1,jk,1) + ENDIF + ! + zfu_t(ji+1,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj ,jk) & + & - gamma2 * ( zlu_uu(ji,jj,jk,2) + zlu_uu(ji+1,jj ,jk,2) ) ) & + & * ( zui - gamma1 * zl_u) + zfv_t(ji ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji ,jj+1,jk) & + & - gamma2 * ( zlv_vv(ji,jj,jk,2) + zlv_vv(ji ,jj+1,jk,2) ) ) & + & * ( zvj - gamma1 * zl_v) + ! + zfuj = ( zfu(ji,jj,jk) + zfu(ji ,jj+1,jk) ) + zfvi = ( zfv(ji,jj,jk) + zfv(ji+1,jj ,jk) ) + IF( zfuj > 0 ) THEN ; zl_v = zlv_vu( ji ,jj ,jk,1) + ELSE ; zl_v = zlv_vu( ji+1,jj,jk,1) + ENDIF + IF( zfvi > 0 ) THEN ; zl_u = zlu_uv( ji,jj ,jk,1) + ELSE ; zl_u = zlu_uv( ji,jj+1,jk,1) + ENDIF + ! + zfv_f(ji ,jj ,jk) = ( zfvi - gamma2 * ( zlv_vu(ji,jj,jk,2) + zlv_vu(ji+1,jj ,jk,2) ) ) & + & * ( puu(ji,jj,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) - gamma1 * zl_u ) + zfu_f(ji ,jj ,jk) = ( zfuj - gamma2 * ( zlu_uv(ji,jj,jk,2) + zlu_uv(ji ,jj+1,jk,2) ) ) & + & * ( pvv(ji,jj,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) - gamma1 * zl_v ) + END_2D + DO_2D( 0, 0, 0, 0 ) ! divergence of horizontal momentum fluxes + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_t(ji+1,jj,jk) - zfu_t(ji,jj ,jk) & + & + zfv_f(ji ,jj,jk) - zfv_f(ji,jj-1,jk) ) * r1_e1e2u(ji,jj) & + & / e3u(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfu_f(ji,jj ,jk) - zfu_f(ji-1,jj,jk) & + & + zfv_t(ji,jj+1,jk) - zfv_t(ji ,jj,jk) ) * r1_e1e2v(ji,jj) & + & / e3v(ji,jj,jk,Kmm) + END_2D + END DO + IF( l_trddyn ) THEN ! trends: send trends to trddyn for diagnostic + zfu_uw(:,:,:) = puu(:,:,:,Krhs) - zfu_uw(:,:,:) + zfv_vw(:,:,:) = pvv(:,:,:,Krhs) - zfv_vw(:,:,:) + CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt, Kmm ) + zfu_t(:,:,:) = puu(:,:,:,Krhs) + zfv_t(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + ! ! ==================== ! + ! ! Vertical advection ! + ! ! ==================== ! + DO_2D( 0, 0, 0, 0 ) ! surface/bottom advective fluxes set to zero + zfu_uw(ji,jj,jpk) = 0._wp + zfv_vw(ji,jj,jpk) = 0._wp + zfu_uw(ji,jj, 1 ) = 0._wp + zfv_vw(ji,jj, 1 ) = 0._wp + END_2D + IF( ln_linssh ) THEN ! constant volume : advection through the surface + DO_2D( 0, 0, 0, 0 ) + zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji+1,jj) * ww(ji+1,jj,1) ) * puu(ji,jj,1,Kmm) + zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji,jj+1) * ww(ji,jj+1,1) ) * pvv(ji,jj,1,Kmm) + END_2D + ENDIF + DO jk = 2, jpkm1 ! interior fluxes + DO_2D( 0, 1, 0, 1 ) + zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) + END_2D + DO_2D( 0, 0, 0, 0 ) + zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji,jj,jk-1,Kmm) ) + zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk-1,Kmm) ) + END_2D + END DO + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! divergence of vertical momentum flux divergence + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) & + & / e3u(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) & + & / e3v(ji,jj,jk,Kmm) + END_3D + ! + IF( l_trddyn ) THEN ! save the vertical advection trend for diagnostic + zfu_t(:,:,:) = puu(:,:,:,Krhs) - zfu_t(:,:,:) + zfv_t(:,:,:) = pvv(:,:,:,Krhs) - zfv_t(:,:,:) + CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt, Kmm ) + ENDIF + ! ! Control print + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ubs2 adv - Ua: ', mask1=umask, & + & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + END SUBROUTINE dyn_adv_ubs + + !!============================================================================== +END MODULE dynadv_ubs \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynatf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynatf.F90 new file mode 100644 index 0000000..e2424be --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynatf.F90 @@ -0,0 +1,369 @@ +MODULE dynatf + !!========================================================================= + !! *** MODULE dynatf *** + !! Ocean dynamics: time filtering + !!========================================================================= + !! History : OPA ! 1987-02 (P. Andrich, D. L Hostis) Original code + !! ! 1990-10 (C. Levy, G. Madec) + !! 7.0 ! 1993-03 (M. Guyon) symetrical conditions + !! 8.0 ! 1997-02 (G. Madec & M. Imbard) opa, release 8.0 + !! 8.2 ! 1997-04 (A. Weaver) Euler forward step + !! - ! 1997-06 (G. Madec) lateral boudary cond., lbc routine + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! - ! 2002-10 (C. Talandier, A-M. Treguier) Open boundary cond. + !! 2.0 ! 2005-11 (V. Garnier) Surface pressure gradient organization + !! 2.3 ! 2007-07 (D. Storkey) Calls to BDY routines. + !! 3.2 ! 2009-06 (G. Madec, R.Benshila) re-introduce the vvl option + !! 3.3 ! 2010-09 (D. Storkey, E.O'Dea) Bug fix for BDY module + !! 3.3 ! 2011-03 (P. Oddo) Bug fix for time-splitting+(BDY-OBC) and not VVL + !! 3.5 ! 2013-07 (J. Chanut) Compliant with time splitting changes + !! 3.6 ! 2014-04 (G. Madec) add the diagnostic of the time filter trends + !! 3.7 ! 2015-11 (J. Chanut) Free surface simplification + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) Rename dynnxt.F90 -> dynatf.F90. Now just does time filtering. + !!------------------------------------------------------------------------- + + !!---------------------------------------------------------------------------------------------- + !! dyn_atf : apply Asselin time filtering to "now" velocities and vertical scale factors + !!---------------------------------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbcrnf ! river runoffs + USE phycst ! physical constants + USE dynadv ! dynamics: vector invariant versus flux form + USE dynspg_ts ! surface pressure gradient: split-explicit scheme + USE domvvl ! variable volume + USE bdy_oce , ONLY : ln_bdy + USE bdydta ! ocean open boundary conditions + USE bdydyn ! ocean open boundary conditions + USE bdyvol ! ocean open boundary condition (bdy_vol routines) + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + USE trdken ! trend manager: kinetic energy + USE isf_oce , ONLY: ln_isf ! ice shelf + USE isfdynatf , ONLY: isf_dynatf ! ice shelf volume filter correction subroutine + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lbclnk ! lateral boundary condition (or mpp link) + USE lib_mpp ! MPP library + USE prtctl ! Print control + USE timing ! Timing + USE zdfdrg , ONLY : ln_drgice_imp, rCdU_top +#if defined key_agrif + USE agrif_oce_interp +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_atf ! routine called by step.F90 + +#if defined key_qco || defined key_linssh + !!---------------------------------------------------------------------- + !! 'key_qco' Quasi-Eulerian vertical coordinate + !! OR EMPTY MODULE + !! 'key_linssh' Fix in time vertical coordinate + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_atf( kt, Kbb, Kmm, Kaa, puu, pvv, pe3t, pe3u, pe3v ) + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! before and after time level indices + REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities to be time filtered + REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: pe3t, pe3u, pe3v ! scale factors to be time filtered + + WRITE(*,*) 'dyn_atf: You should not have seen this print! error?', kt + END SUBROUTINE dyn_atf + +#else + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynatf.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_atf ( kt, Kbb, Kmm, Kaa, puu, pvv, pe3t, pe3u, pe3v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_atf *** + !! + !! ** Purpose : Finalize after horizontal velocity. Apply the boundary + !! condition on the after velocity and apply the Asselin time + !! filter to the now fields. + !! + !! ** Method : * Ensure after velocities transport matches time splitting + !! estimate (ln_dynspg_ts=T) + !! + !! * Apply lateral boundary conditions on after velocity + !! at the local domain boundaries through lbc_lnk call, + !! at the one-way open boundaries (ln_bdy=T), + !! at the AGRIF zoom boundaries (lk_agrif=T) + !! + !! * Apply the Asselin time filter to the now fields + !! arrays to start the next time step: + !! (puu(Kmm),pvv(Kmm)) = (puu(Kmm),pvv(Kmm)) + !! + rn_atfp [ (puu(Kbb),pvv(Kbb)) + (puu(Kaa),pvv(Kaa)) - 2 (puu(Kmm),pvv(Kmm)) ] + !! Note that with flux form advection and non linear free surface, + !! the time filter is applied on thickness weighted velocity. + !! As a result, dyn_atf MUST be called after tra_atf. + !! + !! ** Action : puu(Kmm),pvv(Kmm) filtered now horizontal velocity + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! before and after time level indices + REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities to be time filtered + REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: pe3t, pe3u, pe3v ! scale factors to be time filtered + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zue3a, zue3n, zue3b, zcoef ! local scalars + REAL(wp) :: zve3a, zve3n, zve3b ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve, zwfld + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zutau, zvtau + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze3t_f, ze3u_f, ze3v_f, zua, zva + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_atf') + IF( ln_dynspg_ts ) ALLOCATE( zue(jpi,jpj) , zve(jpi,jpj) ) + IF( l_trddyn ) ALLOCATE( zua(jpi,jpj,jpk) , zva(jpi,jpj,jpk) ) + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_atf : Asselin time filtering' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + + IF ( ln_dynspg_ts ) THEN + ! Ensure below that barotropic velocities match time splitting estimate + ! Compute actual transport and replace it with ts estimate at "after" time step + zue(:,:) = pe3u(:,:,1,Kaa) * puu(:,:,1,Kaa) * umask(:,:,1) + zve(:,:) = pe3v(:,:,1,Kaa) * pvv(:,:,1,Kaa) * vmask(:,:,1) + DO jk = 2, jpkm1 + zue(:,:) = zue(:,:) + pe3u(:,:,jk,Kaa) * puu(:,:,jk,Kaa) * umask(:,:,jk) + zve(:,:) = zve(:,:) + pe3v(:,:,jk,Kaa) * pvv(:,:,jk,Kaa) * vmask(:,:,jk) + END DO + DO jk = 1, jpkm1 + puu(:,:,jk,Kaa) = ( puu(:,:,jk,Kaa) - zue(:,:) * r1_hu(:,:,Kaa) + uu_b(:,:,Kaa) ) * umask(:,:,jk) + pvv(:,:,jk,Kaa) = ( pvv(:,:,jk,Kaa) - zve(:,:) * r1_hv(:,:,Kaa) + vv_b(:,:,Kaa) ) * vmask(:,:,jk) + END DO + ! + IF( .NOT.ln_bt_fw ) THEN + ! Remove advective velocity from "now velocities" + ! prior to asselin filtering + ! In the forward case, this is done below after asselin filtering + ! so that asselin contribution is removed at the same time + DO jk = 1, jpkm1 + puu(:,:,jk,Kmm) = ( puu(:,:,jk,Kmm) - un_adv(:,:)*r1_hu(:,:,Kmm) + uu_b(:,:,Kmm) )*umask(:,:,jk) + pvv(:,:,jk,Kmm) = ( pvv(:,:,jk,Kmm) - vn_adv(:,:)*r1_hv(:,:,Kmm) + vv_b(:,:,Kmm) )*vmask(:,:,jk) + END DO + ENDIF + ENDIF + + ! Update after velocity on domain lateral boundaries + ! -------------------------------------------------- +# if defined key_agrif + CALL Agrif_dyn( kt ) !* AGRIF zoom boundaries +# endif + ! + CALL lbc_lnk( 'dynatf', puu(:,:,:,Kaa), 'U', -1.0_wp, pvv(:,:,:,Kaa), 'V', -1.0_wp ) !* local domain boundaries + ! + ! !* BDY open boundaries + IF( ln_bdy .AND. ln_dynspg_exp ) CALL bdy_dyn( kt, Kbb, puu, pvv, Kaa ) + IF( ln_bdy .AND. ln_dynspg_ts ) CALL bdy_dyn( kt, Kbb, puu, pvv, Kaa, dyn3d_only=.true. ) + +!!$ Do we need a call to bdy_vol here?? + ! + IF( l_trddyn ) THEN ! prepare the atf trend computation + some diagnostics + ! + ! ! Kinetic energy and Conversion + IF( ln_KE_trd ) CALL trd_dyn( puu(:,:,:,Kaa), pvv(:,:,:,Kaa), jpdyn_ken, kt, Kmm ) + ! + IF( ln_dyn_trd ) THEN ! 3D output: total momentum trends + zua(:,:,:) = ( puu(:,:,:,Kaa) - puu(:,:,:,Kbb) ) * r1_Dt + zva(:,:,:) = ( pvv(:,:,:,Kaa) - pvv(:,:,:,Kbb) ) * r1_Dt + CALL iom_put( "utrd_tot", zua ) ! total momentum trends, except the asselin time filter + CALL iom_put( "vtrd_tot", zva ) + ENDIF + ! + zua(:,:,:) = puu(:,:,:,Kmm) ! save the now velocity before the asselin filter + zva(:,:,:) = pvv(:,:,:,Kmm) ! (caution: there will be a shift by 1 timestep in the + ! ! computation of the asselin filter trends) + ENDIF + + ! Time filter and swap of dynamics arrays + ! ------------------------------------------ + + IF( .NOT. l_1st_euler ) THEN !* Leap-Frog : Asselin time filter + ! ! =============! + IF( ln_linssh ) THEN ! Fixed volume ! + ! ! =============! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + puu(ji,jj,jk,Kmm) = puu(ji,jj,jk,Kmm) + rn_atfp * ( puu(ji,jj,jk,Kbb) - 2._wp * puu(ji,jj,jk,Kmm) + puu(ji,jj,jk,Kaa) ) + pvv(ji,jj,jk,Kmm) = pvv(ji,jj,jk,Kmm) + rn_atfp * ( pvv(ji,jj,jk,Kbb) - 2._wp * pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Kaa) ) + END_3D + ! ! ================! + ELSE ! Variable volume ! + ! ! ================! + ! Time-filtered scale factor at t-points + ! ---------------------------------------------------- + ALLOCATE( ze3t_f(jpi,jpj,jpk), zwfld(jpi,jpj) ) + DO jk = 1, jpkm1 + ze3t_f(:,:,jk) = pe3t(:,:,jk,Kmm) + rn_atfp * ( pe3t(:,:,jk,Kbb) - 2._wp * pe3t(:,:,jk,Kmm) + pe3t(:,:,jk,Kaa) ) + END DO + ! Add volume filter correction: compatibility with tracer advection scheme + ! => time filter + conservation correction + zcoef = rn_atfp * rn_Dt * r1_rho0 + zwfld(:,:) = emp_b(:,:) - emp(:,:) + IF ( ln_rnf ) zwfld(:,:) = zwfld(:,:) - ( rnf_b(:,:) - rnf(:,:) ) + + DO jk = 1, jpkm1 + ze3t_f(:,:,jk) = ze3t_f(:,:,jk) - zcoef * zwfld(:,:) * tmask(:,:,jk) & + & * pe3t(:,:,jk,Kmm) / ( ht(:,:) + 1._wp - ssmask(:,:) ) + END DO + ! + ! ice shelf melting (deal separately as it can be in depth) + ! PM: we could probably define a generic subroutine to do the in depth correction + ! to manage rnf, isf and possibly in the futur icb, tide water glacier (...) + ! ...(kt, coef, ktop, kbot, hz, fwf_b, fwf) + IF ( ln_isf ) CALL isf_dynatf( kt, Kmm, ze3t_f, rn_atfp * rn_Dt ) + ! + pe3t(:,:,1:jpkm1,Kmm) = ze3t_f(:,:,1:jpkm1) ! filtered scale factor at T-points + ! + IF( ln_dynadv_vec ) THEN ! Asselin filter applied on velocity + ! Before filtered scale factor at (u/v)-points + CALL dom_vvl_interpol( pe3t(:,:,:,Kmm), pe3u(:,:,:,Kmm), 'U' ) + CALL dom_vvl_interpol( pe3t(:,:,:,Kmm), pe3v(:,:,:,Kmm), 'V' ) + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + puu(ji,jj,jk,Kmm) = puu(ji,jj,jk,Kmm) + rn_atfp * ( puu(ji,jj,jk,Kbb) - 2._wp * puu(ji,jj,jk,Kmm) + puu(ji,jj,jk,Kaa) ) + pvv(ji,jj,jk,Kmm) = pvv(ji,jj,jk,Kmm) + rn_atfp * ( pvv(ji,jj,jk,Kbb) - 2._wp * pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Kaa) ) + END_3D + ! + ELSE ! Asselin filter applied on thickness weighted velocity + ! + ALLOCATE( ze3u_f(jpi,jpj,jpk) , ze3v_f(jpi,jpj,jpk) ) + ! Now filtered scale factor at (u/v)-points stored in ze3u_f, ze3v_f + CALL dom_vvl_interpol( pe3t(:,:,:,Kmm), ze3u_f, 'U' ) + CALL dom_vvl_interpol( pe3t(:,:,:,Kmm), ze3v_f, 'V' ) + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + zue3a = pe3u(ji,jj,jk,Kaa) * puu(ji,jj,jk,Kaa) + zve3a = pe3v(ji,jj,jk,Kaa) * pvv(ji,jj,jk,Kaa) + zue3n = pe3u(ji,jj,jk,Kmm) * puu(ji,jj,jk,Kmm) + zve3n = pe3v(ji,jj,jk,Kmm) * pvv(ji,jj,jk,Kmm) + zue3b = pe3u(ji,jj,jk,Kbb) * puu(ji,jj,jk,Kbb) + zve3b = pe3v(ji,jj,jk,Kbb) * pvv(ji,jj,jk,Kbb) + ! + puu(ji,jj,jk,Kmm) = ( zue3n + rn_atfp * ( zue3b - 2._wp * zue3n + zue3a ) ) / ze3u_f(ji,jj,jk) + pvv(ji,jj,jk,Kmm) = ( zve3n + rn_atfp * ( zve3b - 2._wp * zve3n + zve3a ) ) / ze3v_f(ji,jj,jk) + END_3D + pe3u(:,:,1:jpkm1,Kmm) = ze3u_f(:,:,1:jpkm1) + pe3v(:,:,1:jpkm1,Kmm) = ze3v_f(:,:,1:jpkm1) + ! + DEALLOCATE( ze3u_f , ze3v_f ) + ENDIF + ! + DEALLOCATE( ze3t_f, zwfld ) + ENDIF + ! + IF( ln_dynspg_ts .AND. ln_bt_fw ) THEN + ! Revert filtered "now" velocities to time split estimate + ! Doing it here also means that asselin filter contribution is removed + zue(:,:) = pe3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1) + zve(:,:) = pe3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1) + DO jk = 2, jpkm1 + zue(:,:) = zue(:,:) + pe3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk) + zve(:,:) = zve(:,:) + pe3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) + END DO + DO jk = 1, jpkm1 + puu(:,:,jk,Kmm) = puu(:,:,jk,Kmm) - (zue(:,:) * r1_hu(:,:,Kmm) - uu_b(:,:,Kmm)) * umask(:,:,jk) + pvv(:,:,jk,Kmm) = pvv(:,:,jk,Kmm) - (zve(:,:) * r1_hv(:,:,Kmm) - vv_b(:,:,Kmm)) * vmask(:,:,jk) + END DO + ENDIF + ! + ENDIF ! .NOT. l_1st_euler + ! + ! This is needed for dyn_ldf_blp to be restartable + IF( nn_hls == 2 ) CALL lbc_lnk( 'dynatf', puu(:,:,:,Kmm), 'U', -1.0_wp, pvv(:,:,:,Kmm), 'V', -1.0_wp ) + ! Set "now" and "before" barotropic velocities for next time step: + ! JC: Would be more clever to swap variables than to make a full vertical + ! integration + ! + IF(.NOT.ln_linssh ) THEN + hu(:,:,Kmm) = pe3u(:,:,1,Kmm ) * umask(:,:,1) + hv(:,:,Kmm) = pe3v(:,:,1,Kmm ) * vmask(:,:,1) + DO jk = 2, jpkm1 + hu(:,:,Kmm) = hu(:,:,Kmm) + pe3u(:,:,jk,Kmm ) * umask(:,:,jk) + hv(:,:,Kmm) = hv(:,:,Kmm) + pe3v(:,:,jk,Kmm ) * vmask(:,:,jk) + END DO + r1_hu(:,:,Kmm) = ssumask(:,:) / ( hu(:,:,Kmm) + 1._wp - ssumask(:,:) ) + r1_hv(:,:,Kmm) = ssvmask(:,:) / ( hv(:,:,Kmm) + 1._wp - ssvmask(:,:) ) + ENDIF + ! + uu_b(:,:,Kaa) = pe3u(:,:,1,Kaa) * puu(:,:,1,Kaa) * umask(:,:,1) + uu_b(:,:,Kmm) = pe3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1) + vv_b(:,:,Kaa) = pe3v(:,:,1,Kaa) * pvv(:,:,1,Kaa) * vmask(:,:,1) + vv_b(:,:,Kmm) = pe3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1) + DO jk = 2, jpkm1 + uu_b(:,:,Kaa) = uu_b(:,:,Kaa) + pe3u(:,:,jk,Kaa) * puu(:,:,jk,Kaa) * umask(:,:,jk) + uu_b(:,:,Kmm) = uu_b(:,:,Kmm) + pe3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk) + vv_b(:,:,Kaa) = vv_b(:,:,Kaa) + pe3v(:,:,jk,Kaa) * pvv(:,:,jk,Kaa) * vmask(:,:,jk) + vv_b(:,:,Kmm) = vv_b(:,:,Kmm) + pe3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) + END DO + uu_b(:,:,Kaa) = uu_b(:,:,Kaa) * r1_hu(:,:,Kaa) + vv_b(:,:,Kaa) = vv_b(:,:,Kaa) * r1_hv(:,:,Kaa) + uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm) + vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * r1_hv(:,:,Kmm) + ! + IF( .NOT.ln_dynspg_ts ) THEN ! output the barotropic currents + CALL iom_put( "ubar", uu_b(:,:,Kmm) ) + CALL iom_put( "vbar", vv_b(:,:,Kmm) ) + ENDIF + IF( l_trddyn ) THEN ! 3D output: asselin filter trends on momentum + zua(:,:,:) = ( puu(:,:,:,Kmm) - zua(:,:,:) ) * r1_Dt + zva(:,:,:) = ( pvv(:,:,:,Kmm) - zva(:,:,:) ) * r1_Dt + CALL trd_dyn( zua, zva, jpdyn_atf, kt, Kmm ) + ENDIF + ! + IF ( iom_use("utau") ) THEN + IF ( ln_drgice_imp.OR.ln_isfcav ) THEN + ALLOCATE(zutau(jpi,jpj)) + DO_2D( 0, 0, 0, 0 ) + jk = miku(ji,jj) + zutau(ji,jj) = utau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * puu(ji,jj,jk,Kaa) + END_2D + CALL iom_put( "utau", zutau(:,:) ) + DEALLOCATE(zutau) + ELSE + CALL iom_put( "utau", utau(:,:) ) + ENDIF + ENDIF + ! + IF ( iom_use("vtau") ) THEN + IF ( ln_drgice_imp.OR.ln_isfcav ) THEN + ALLOCATE(zvtau(jpi,jpj)) + DO_2D( 0, 0, 0, 0 ) + jk = mikv(ji,jj) + zvtau(ji,jj) = vtau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * pvv(ji,jj,jk,Kaa) + END_2D + CALL iom_put( "vtau", zvtau(:,:) ) + DEALLOCATE(zvtau) + ELSE + CALL iom_put( "vtau", vtau(:,:) ) + ENDIF + ENDIF + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=REAL(puu(:,:,:,Kaa),dp), clinfo1=' nxt - puu(:,:,:,Kaa): ', mask1=umask, & + & tab3d_2=REAL(pvv(:,:,:,Kaa),dp), clinfo2=' pvv(:,:,:,Kaa): ' , mask2=vmask ) + ! + IF( ln_dynspg_ts ) DEALLOCATE( zue, zve ) + IF( l_trddyn ) DEALLOCATE( zua, zva ) + IF( ln_timing ) CALL timing_stop('dyn_atf') + ! + END SUBROUTINE dyn_atf + +#endif + + !!========================================================================= +END MODULE dynatf diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynatf_qco.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynatf_qco.F90 new file mode 100644 index 0000000..fd858f2 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynatf_qco.F90 @@ -0,0 +1,284 @@ +MODULE dynatf_qco + !!========================================================================= + !! *** MODULE dynatf_qco *** + !! Ocean dynamics: time filtering + !!========================================================================= + !! History : OPA ! 1987-02 (P. Andrich, D. L Hostis) Original code + !! ! 1990-10 (C. Levy, G. Madec) + !! 7.0 ! 1993-03 (M. Guyon) symetrical conditions + !! 8.0 ! 1997-02 (G. Madec & M. Imbard) opa, release 8.0 + !! 8.2 ! 1997-04 (A. Weaver) Euler forward step + !! - ! 1997-06 (G. Madec) lateral boudary cond., lbc routine + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! - ! 2002-10 (C. Talandier, A-M. Treguier) Open boundary cond. + !! 2.0 ! 2005-11 (V. Garnier) Surface pressure gradient organization + !! 2.3 ! 2007-07 (D. Storkey) Calls to BDY routines. + !! 3.2 ! 2009-06 (G. Madec, R.Benshila) re-introduce the vvl option + !! 3.3 ! 2010-09 D. Storkey, E.O'Dea) Bug fix for BDY module + !! 3.3 ! 2011-03 (P. Oddo) Bug fix for time-splitting+(BDY-OBC) and not VVL + !! 3.5 ! 2013-07 (J. Chanut) Compliant with time splitting changes + !! 3.6 ! 2014-04 (G. Madec) add the diagnostic of the time filter trends + !! 3.7 ! 2015-11 (J. Chanut) Free surface simplification + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) Rename dynnxt.F90 -> dynatfLF.F90. Now just does time filtering. + !!------------------------------------------------------------------------- + + !!---------------------------------------------------------------------------------------------- + !! dyn_atf_qco : apply Asselin time filtering to "now" velocities and vertical scale factors + !!---------------------------------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbcrnf ! river runoffs + USE phycst ! physical constants + USE dynadv ! dynamics: vector invariant versus flux form + USE dynspg_ts ! surface pressure gradient: split-explicit scheme + USE domvvl ! variable volume + USE bdy_oce , ONLY: ln_bdy + USE bdydta ! ocean open boundary conditions + USE bdydyn ! ocean open boundary conditions + USE bdyvol ! ocean open boundary condition (bdy_vol routines) + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + USE trdken ! trend manager: kinetic energy + USE isf_oce , ONLY: ln_isf ! ice shelf + USE isfdynatf , ONLY: isf_dynatf ! ice shelf volume filter correction subroutine + USE zdfdrg , ONLY: ln_drgice_imp, rCdU_top + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lbclnk ! lateral boundary condition (or mpp link) + USE lib_mpp ! MPP library + USE prtctl ! Print control + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_atf_qco ! routine called by step.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynatf_qco.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_atf_qco( kt, Kbb, Kmm, Kaa, puu, pvv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_atf_qco *** + !! + !! ** Purpose : Finalize after horizontal velocity. Apply the boundary + !! condition on the after velocity and apply the Asselin time + !! filter to the now fields. + !! + !! ** Method : * Ensure after velocities transport matches time splitting + !! estimate (ln_dynspg_ts=T) + !! + !! * Apply lateral boundary conditions on after velocity + !! at the local domain boundaries through lbc_lnk call, + !! at the one-way open boundaries (ln_bdy=T), + !! at the AGRIF zoom boundaries (lk_agrif=T) + !! + !! * Apply the Asselin time filter to the now fields + !! arrays to start the next time step: + !! (puu(Kmm),pvv(Kmm)) = (puu(Kmm),pvv(Kmm)) + !! + atfp [ (puu(Kbb),pvv(Kbb)) + (puu(Kaa),pvv(Kaa)) - 2 (puu(Kmm),pvv(Kmm)) ] + !! Note that with flux form advection and non linear free surface, + !! the time filter is applied on thickness weighted velocity. + !! As a result, dyn_atf_lf MUST be called after tra_atf. + !! + !! ** Action : puu(Kmm),pvv(Kmm) filtered now horizontal velocity + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! before and after time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities to be time filtered + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zue3a, zue3n, zue3b, zcoef ! local scalars + REAL(wp) :: zve3a, zve3n, zve3b ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: zua, zva + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zutau, zvtau + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_atf_qco') + IF( ln_dynspg_ts ) ALLOCATE( zue(jpi,jpj) , zve(jpi,jpj) ) + IF( l_trddyn ) ALLOCATE( zua(jpi,jpj,jpk) , zva(jpi,jpj,jpk) ) + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_atf_qco : Asselin time filtering' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + ! + IF( l_trddyn ) THEN ! prepare the atf trend computation + some diagnostics + ! + ! ! Kinetic energy and Conversion + IF( ln_KE_trd ) CALL trd_dyn( puu(:,:,:,Kaa), pvv(:,:,:,Kaa), jpdyn_ken, kt, Kmm ) + ! + IF( ln_dyn_trd ) THEN ! 3D output: total momentum trends + zua(:,:,:) = ( puu(:,:,:,Kaa) - puu(:,:,:,Kbb) ) * r1_Dt + zva(:,:,:) = ( pvv(:,:,:,Kaa) - pvv(:,:,:,Kbb) ) * r1_Dt + CALL iom_put( "utrd_tot", zua ) ! total momentum trends, except the asselin time filter + CALL iom_put( "vtrd_tot", zva ) + ENDIF + ! + zua(:,:,:) = puu(:,:,:,Kmm) ! save the now velocity before the asselin filter + zva(:,:,:) = pvv(:,:,:,Kmm) ! (caution: there will be a shift by 1 timestep in the + ! ! computation of the asselin filter trends) + ENDIF + + ! Time filter and swap of dynamics arrays + ! ------------------------------------------ + + IF( .NOT. l_1st_euler ) THEN !* Leap-Frog : Asselin time filter + ! ! =============! + IF( ln_linssh ) THEN ! Fixed volume ! + ! ! =============! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + puu(ji,jj,jk,Kmm) = puu(ji,jj,jk,Kmm) + rn_atfp * ( puu(ji,jj,jk,Kbb) - 2._wp * puu(ji,jj,jk,Kmm) + puu(ji,jj,jk,Kaa) ) + pvv(ji,jj,jk,Kmm) = pvv(ji,jj,jk,Kmm) + rn_atfp * ( pvv(ji,jj,jk,Kbb) - 2._wp * pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Kaa) ) + END_3D + ! ! ================! + ELSE ! Variable volume ! + ! ! ================! + ! + IF( ln_dynadv_vec ) THEN ! Asselin filter applied on velocity + ! Before filtered scale factor at (u/v)-points + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + puu(ji,jj,jk,Kmm) = puu(ji,jj,jk,Kmm) + rn_atfp * ( puu(ji,jj,jk,Kbb) - 2._wp * puu(ji,jj,jk,Kmm) + puu(ji,jj,jk,Kaa) ) + pvv(ji,jj,jk,Kmm) = pvv(ji,jj,jk,Kmm) + rn_atfp * ( pvv(ji,jj,jk,Kbb) - 2._wp * pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Kaa) ) + END_3D + ! + ELSE ! Asselin filter applied on thickness weighted velocity + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + zue3a = ( 1._wp + r3u(ji,jj,Kaa) * umask(ji,jj,jk) ) * puu(ji,jj,jk,Kaa) + zve3a = ( 1._wp + r3v(ji,jj,Kaa) * vmask(ji,jj,jk) ) * pvv(ji,jj,jk,Kaa) + zue3n = ( 1._wp + r3u(ji,jj,Kmm) * umask(ji,jj,jk) ) * puu(ji,jj,jk,Kmm) + zve3n = ( 1._wp + r3v(ji,jj,Kmm) * vmask(ji,jj,jk) ) * pvv(ji,jj,jk,Kmm) + zue3b = ( 1._wp + r3u(ji,jj,Kbb) * umask(ji,jj,jk) ) * puu(ji,jj,jk,Kbb) + zve3b = ( 1._wp + r3v(ji,jj,Kbb) * vmask(ji,jj,jk) ) * pvv(ji,jj,jk,Kbb) + ! ! filtered scale factor at U-,V-points + puu(ji,jj,jk,Kmm) = ( zue3n + rn_atfp * ( zue3b - 2._wp * zue3n + zue3a ) ) / ( 1._wp + r3u_f(ji,jj)*umask(ji,jj,jk) ) + pvv(ji,jj,jk,Kmm) = ( zve3n + rn_atfp * ( zve3b - 2._wp * zve3n + zve3a ) ) / ( 1._wp + r3v_f(ji,jj)*vmask(ji,jj,jk) ) + END_3D + ! + ENDIF + ! + ENDIF + ! + IF( ln_dynspg_ts .AND. ln_bt_fw ) THEN + ! Revert filtered "now" velocities to time split estimate + ! Doing it here also means that asselin filter contribution is removed + ! zue(:,:) = pe3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1) + ! zve(:,:) = pe3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1) + ! DO jk = 2, jpkm1 + ! zue(:,:) = zue(:,:) + pe3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk) + ! zve(:,:) = zve(:,:) + pe3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) + ! END DO + zue(:,:) = e3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1) + zve(:,:) = e3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1) + DO jk = 2, jpkm1 + zue(:,:) = zue(:,:) + e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk) + zve(:,:) = zve(:,:) + e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) + END DO + DO jk = 1, jpkm1 + puu(:,:,jk,Kmm) = puu(:,:,jk,Kmm) - (zue(:,:) * r1_hu(:,:,Kmm) - uu_b(:,:,Kmm)) * umask(:,:,jk) + pvv(:,:,jk,Kmm) = pvv(:,:,jk,Kmm) - (zve(:,:) * r1_hv(:,:,Kmm) - vv_b(:,:,Kmm)) * vmask(:,:,jk) + END DO + ENDIF + ! + ENDIF ! .NOT. l_1st_euler + ! + ! This is needed for dyn_ldf_blp to be restartable + IF( nn_hls == 2 ) CALL lbc_lnk( 'dynatfqco', puu(:,:,:,Kmm), 'U', -1.0_dp, pvv(:,:,:,Kmm), 'V', -1.0_dp ) + + ! Set "now" and "before" barotropic velocities for next time step: + ! JC: Would be more clever to swap variables than to make a full vertical + ! integration + ! CAUTION : calculation need to be done in the same way than see GM +#if defined key_linssh + uu_b(:,:,Kaa) = e3u(:,:,1,Kaa) * puu(:,:,1,Kaa) * umask(:,:,1) + uu_b(:,:,Kmm) = e3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1) + vv_b(:,:,Kaa) = e3v(:,:,1,Kaa) * pvv(:,:,1,Kaa) * vmask(:,:,1) + vv_b(:,:,Kmm) = e3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1) + DO jk = 2, jpkm1 + uu_b(:,:,Kaa) = uu_b(:,:,Kaa) + e3u(:,:,jk,Kaa) * puu(:,:,jk,Kaa) * umask(:,:,jk) + uu_b(:,:,Kmm) = uu_b(:,:,Kmm) + e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk) + vv_b(:,:,Kaa) = vv_b(:,:,Kaa) + e3v(:,:,jk,Kaa) * pvv(:,:,jk,Kaa) * vmask(:,:,jk) + vv_b(:,:,Kmm) = vv_b(:,:,Kmm) + e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) + END DO + uu_b(:,:,Kaa) = uu_b(:,:,Kaa) * r1_hu(:,:,Kaa) + vv_b(:,:,Kaa) = vv_b(:,:,Kaa) * r1_hv(:,:,Kaa) + uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm) + vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * r1_hv(:,:,Kmm) +#else + uu_b(:,:,Kaa) = e3u(:,:,1,Kaa) * puu(:,:,1,Kaa) * umask(:,:,1) + uu_b(:,:,Kmm) = (e3u_0(:,:,1) * ( 1._wp + r3u_f(:,:) * umask(:,:,1) )) * puu(:,:,1,Kmm) * umask(:,:,1) + vv_b(:,:,Kaa) = e3v(:,:,1,Kaa) * pvv(:,:,1,Kaa) * vmask(:,:,1) + vv_b(:,:,Kmm) = (e3v_0(:,:,1) * ( 1._wp + r3v_f(:,:) * vmask(:,:,1))) * pvv(:,:,1,Kmm) * vmask(:,:,1) + DO jk = 2, jpkm1 + uu_b(:,:,Kaa) = uu_b(:,:,Kaa) + e3u(:,:,jk,Kaa) * puu(:,:,jk,Kaa) * umask(:,:,jk) + uu_b(:,:,Kmm) = uu_b(:,:,Kmm) + (e3u_0(:,:,jk) * ( 1._wp + r3u_f(:,:) * umask(:,:,jk) )) * puu(:,:,jk,Kmm) * umask(:,:,jk) + vv_b(:,:,Kaa) = vv_b(:,:,Kaa) + e3v(:,:,jk,Kaa) * pvv(:,:,jk,Kaa) * vmask(:,:,jk) + vv_b(:,:,Kmm) = vv_b(:,:,Kmm) + (e3v_0(:,:,jk) * ( 1._wp + r3v_f(:,:) * vmask(:,:,jk) )) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) + END DO + uu_b(:,:,Kaa) = uu_b(:,:,Kaa) * r1_hu(:,:,Kaa) + vv_b(:,:,Kaa) = vv_b(:,:,Kaa) * r1_hv(:,:,Kaa) + uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * (r1_hu_0(:,:)/( 1._wp + r3u_f(:,:) )) + vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * (r1_hv_0(:,:)/( 1._wp + r3v_f(:,:) )) +#endif + ! + IF( .NOT.ln_dynspg_ts ) THEN ! output the barotropic currents + CALL iom_put( "ubar", uu_b(:,:,Kmm) ) + CALL iom_put( "vbar", vv_b(:,:,Kmm) ) + ENDIF + IF( l_trddyn ) THEN ! 3D output: asselin filter trends on momentum + zua(:,:,:) = ( puu(:,:,:,Kmm) - zua(:,:,:) ) * r1_Dt + zva(:,:,:) = ( pvv(:,:,:,Kmm) - zva(:,:,:) ) * r1_Dt + CALL trd_dyn( zua, zva, jpdyn_atf, kt, Kmm ) + ENDIF + ! + IF ( iom_use("utau") ) THEN + IF ( ln_drgice_imp.OR.ln_isfcav ) THEN + ALLOCATE(zutau(jpi,jpj)) + DO_2D( 0, 0, 0, 0 ) + jk = miku(ji,jj) + zutau(ji,jj) = utau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * puu(ji,jj,jk,Kaa) + END_2D + CALL iom_put( "utau", zutau(:,:) ) + DEALLOCATE(zutau) + ELSE + CALL iom_put( "utau", utau(:,:) ) + ENDIF + ENDIF + ! + IF ( iom_use("vtau") ) THEN + IF ( ln_drgice_imp.OR.ln_isfcav ) THEN + ALLOCATE(zvtau(jpi,jpj)) + DO_2D( 0, 0, 0, 0 ) + jk = mikv(ji,jj) + zvtau(ji,jj) = vtau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * pvv(ji,jj,jk,Kaa) + END_2D + CALL iom_put( "vtau", zvtau(:,:) ) + DEALLOCATE(zvtau) + ELSE + CALL iom_put( "vtau", vtau(:,:) ) + ENDIF + ENDIF + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Kaa), clinfo1=' nxt - puu(:,:,:,Kaa): ', mask1=umask, & + & tab3d_2=pvv(:,:,:,Kaa), clinfo2=' pvv(:,:,:,Kaa): ' , mask2=vmask ) + ! + IF( ln_dynspg_ts ) DEALLOCATE( zue, zve ) + IF( l_trddyn ) DEALLOCATE( zua, zva ) + IF( ln_timing ) CALL timing_stop('dyn_atf_qco') + ! + END SUBROUTINE dyn_atf_qco + + !!========================================================================= +END MODULE dynatf_qco diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynhpg.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynhpg.F90 new file mode 100644 index 0000000..45e7e6f --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynhpg.F90 @@ -0,0 +1,1435 @@ +MODULE dynhpg + !!====================================================================== + !! *** MODULE dynhpg *** + !! Ocean dynamics: hydrostatic pressure gradient trend + !!====================================================================== + !! History : OPA ! 1987-09 (P. Andrich, M.-A. Foujols) hpg_zco: Original code + !! 5.0 ! 1991-11 (G. Madec) + !! 7.0 ! 1996-01 (G. Madec) hpg_sco: Original code for s-coordinates + !! 8.0 ! 1997-05 (G. Madec) split dynber into dynkeg and dynhpg + !! 8.5 ! 2002-07 (G. Madec) F90: Free form and module + !! 8.5 ! 2002-08 (A. Bozec) hpg_zps: Original code + !! NEMO 1.0 ! 2005-10 (A. Beckmann, B.W. An) various s-coordinate options + !! ! Original code for hpg_ctl, hpg_hel hpg_wdj, hpg_djc, hpg_rot + !! - ! 2005-11 (G. Madec) style & small optimisation + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.4 ! 2011-11 (H. Liu) hpg_prj: Original code for s-coordinates + !! ! (A. Coward) suppression of hel, wdj and rot options + !! 3.6 ! 2014-11 (P. Mathiot) hpg_isf: original code for ice shelf cavity + !! 4.2 ! 2020-12 (M. Bell, A. Young) hpg_djc: revised djc scheme + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_hpg : update the momentum trend with the now horizontal + !! gradient of the hydrostatic pressure + !! dyn_hpg_init : initialisation and control of options + !! hpg_zco : z-coordinate scheme + !! hpg_zps : z-coordinate plus partial steps (interpolation) + !! hpg_sco : s-coordinate (standard jacobian formulation) + !! hpg_isf : s-coordinate (sco formulation) adapted to ice shelf + !! hpg_djc : s-coordinate (Density Jacobian with Cubic polynomial) + !! hpg_prj : s-coordinate (Pressure Jacobian with Cubic polynomial) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE isf_oce , ONLY : risfload ! ice shelf (risfload variable) + USE isfload , ONLY : isf_load ! ice shelf (isf_load routine ) + USE sbc_oce ! surface variable (only for the flag with ice shelf) + USE dom_oce ! ocean space and time domain + USE wet_dry ! wetting and drying + USE phycst ! physical constants + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + USE zpshde ! partial step: hor. derivative (zps_hde routine) + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE lbclnk ! lateral boundary condition + USE lib_mpp ! MPP library + USE eosbn2 ! compute density + USE timing ! Timing + USE iom + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_hpg ! routine called by step module + PUBLIC dyn_hpg_init ! routine called by opa module + + ! !!* Namelist namdyn_hpg : hydrostatic pressure gradient + LOGICAL, PUBLIC :: ln_hpg_zco !: z-coordinate - full steps + LOGICAL, PUBLIC :: ln_hpg_zps !: z-coordinate - partial steps (interpolation) + LOGICAL, PUBLIC :: ln_hpg_sco !: s-coordinate (standard jacobian formulation) + LOGICAL, PUBLIC :: ln_hpg_djc !: s-coordinate (Density Jacobian with Cubic polynomial) + LOGICAL, PUBLIC :: ln_hpg_prj !: s-coordinate (Pressure Jacobian scheme) + LOGICAL, PUBLIC :: ln_hpg_isf !: s-coordinate similar to sco modify for isf + + ! !! Flag to control the type of hydrostatic pressure gradient + INTEGER, PARAMETER :: np_ERROR =-10 ! error in specification of lateral diffusion + INTEGER, PARAMETER :: np_zco = 0 ! z-coordinate - full steps + INTEGER, PARAMETER :: np_zps = 1 ! z-coordinate - partial steps (interpolation) + INTEGER, PARAMETER :: np_sco = 2 ! s-coordinate (standard jacobian formulation) + INTEGER, PARAMETER :: np_djc = 3 ! s-coordinate (Density Jacobian with Cubic polynomial) + INTEGER, PARAMETER :: np_prj = 4 ! s-coordinate (Pressure Jacobian scheme) + INTEGER, PARAMETER :: np_isf = 5 ! s-coordinate similar to sco modify for isf + ! + INTEGER, PUBLIC :: nhpg !: type of pressure gradient scheme used ! (deduced from ln_hpg_... flags) (PUBLIC for TAM) + ! + LOGICAL :: ln_hpg_djc_vnh, ln_hpg_djc_vnv ! flag to specify hpg_djc boundary condition type + REAL(wp), PUBLIC :: aco_bc_hor, bco_bc_hor, aco_bc_vrt, bco_bc_vrt !: coefficients for hpg_djc hor and vert boundary conditions + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynhpg.F90 15529 2021-11-23 15:00:19Z techene $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_hpg( kt, Kmm, puu, pvv, Krhs ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_hpg *** + !! + !! ** Method : Call the hydrostatic pressure gradient routine + !! using the scheme defined in the namelist + !! + !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend + !! - send trends to trd_dyn for futher diagnostics (l_trddyn=T) + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_hpg') + ! + IF( l_trddyn ) THEN ! Temporary saving of puu(:,:,:,Krhs) and pvv(:,:,:,Krhs) trends (l_trddyn) + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = puu(:,:,:,Krhs) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + ! + SELECT CASE ( nhpg ) ! Hydrostatic pressure gradient computation + CASE ( np_zco ) ; CALL hpg_zco ( kt, Kmm, puu, pvv, Krhs ) ! z-coordinate + CASE ( np_zps ) ; CALL hpg_zps ( kt, Kmm, puu, pvv, Krhs ) ! z-coordinate plus partial steps (interpolation) + CASE ( np_sco ) ; CALL hpg_sco ( kt, Kmm, puu, pvv, Krhs ) ! s-coordinate (standard jacobian formulation) + CASE ( np_djc ) ; CALL hpg_djc ( kt, Kmm, puu, pvv, Krhs ) ! s-coordinate (Density Jacobian with Cubic polynomial) + CASE ( np_prj ) ; CALL hpg_prj ( kt, Kmm, puu, pvv, Krhs ) ! s-coordinate (Pressure Jacobian scheme) + CASE ( np_isf ) ; CALL hpg_isf ( kt, Kmm, puu, pvv, Krhs ) ! s-coordinate similar to sco modify for ice shelf + END SELECT + ! + IF( l_trddyn ) THEN ! save the hydrostatic pressure gradient trends for momentum trend diagnostics + ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_hpg, kt, Kmm ) + DEALLOCATE( ztrdu , ztrdv ) + ENDIF + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' hpg - Ua: ', mask1=umask, & + & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_hpg') + ! + END SUBROUTINE dyn_hpg + + + SUBROUTINE dyn_hpg_init( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_hpg_init *** + !! + !! ** Purpose : initializations for the hydrostatic pressure gradient + !! computation and consistency control + !! + !! ** Action : Read the namelist namdyn_hpg and check the consistency + !! with the type of vertical coordinate used (zco, zps, sco) + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: Kmm ! ocean time level index + ! + INTEGER :: ioptio = 0 ! temporary integer + INTEGER :: ios ! Local integer output status for namelist read + !! + INTEGER :: ji, jj, jk, ikt ! dummy loop indices ISF + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zts_top, zrhd ! hypothesys on isf density + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zrhdtop_isf ! density at bottom of ISF + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ziceload ! density at bottom of ISF + !! + NAMELIST/namdyn_hpg/ ln_hpg_zco, ln_hpg_zps, ln_hpg_sco, & + & ln_hpg_djc, ln_hpg_prj, ln_hpg_isf, & + & ln_hpg_djc_vnh, ln_hpg_djc_vnv + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namdyn_hpg, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_hpg in reference namelist' ) + ! + READ ( numnam_cfg, namdyn_hpg, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_hpg in configuration namelist' ) + IF(lwm) WRITE ( numond, namdyn_hpg ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'dyn_hpg_init : hydrostatic pressure gradient initialisation' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namdyn_hpg : choice of hpg scheme' + WRITE(numout,*) ' z-coord. - full steps ln_hpg_zco = ', ln_hpg_zco + WRITE(numout,*) ' z-coord. - partial steps (interpolation) ln_hpg_zps = ', ln_hpg_zps + WRITE(numout,*) ' s-coord. (standard jacobian formulation) ln_hpg_sco = ', ln_hpg_sco + WRITE(numout,*) ' s-coord. (standard jacobian formulation) for isf ln_hpg_isf = ', ln_hpg_isf + WRITE(numout,*) ' s-coord. (Density Jacobian: Cubic polynomial) ln_hpg_djc = ', ln_hpg_djc + WRITE(numout,*) ' s-coord. (Pressure Jacobian: Cubic polynomial) ln_hpg_prj = ', ln_hpg_prj + ENDIF + ! + IF( .NOT.ln_linssh .AND. (ln_hpg_zco.OR.ln_hpg_zps) ) & + & CALL ctl_stop( 'dyn_hpg_init : non-linear free surface incompatible with hpg_zco or hpg_zps' ) + ! + IF( (.NOT.ln_hpg_isf .AND. ln_isfcav) .OR. (ln_hpg_isf .AND. .NOT.ln_isfcav) ) & + & CALL ctl_stop( 'dyn_hpg_init : ln_hpg_isf=T requires ln_isfcav=T and vice versa' ) + ! + ! + ! ! Set nhpg from ln_hpg_... flags & consistency check + nhpg = np_ERROR + ioptio = 0 + IF( ln_hpg_zco ) THEN ; nhpg = np_zco ; ioptio = ioptio +1 ; ENDIF + IF( ln_hpg_zps ) THEN ; nhpg = np_zps ; ioptio = ioptio +1 ; ENDIF + IF( ln_hpg_sco ) THEN ; nhpg = np_sco ; ioptio = ioptio +1 ; ENDIF + IF( ln_hpg_djc ) THEN ; nhpg = np_djc ; ioptio = ioptio +1 ; ENDIF + IF( ln_hpg_prj ) THEN ; nhpg = np_prj ; ioptio = ioptio +1 ; ENDIF + IF( ln_hpg_isf ) THEN ; nhpg = np_isf ; ioptio = ioptio +1 ; ENDIF + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'NO or several hydrostatic pressure gradient options used' ) + ! + IF(lwp) THEN + WRITE(numout,*) + SELECT CASE( nhpg ) + CASE( np_zco ) ; WRITE(numout,*) ' ==>>> z-coord. - full steps ' + CASE( np_zps ) ; WRITE(numout,*) ' ==>>> z-coord. - partial steps (interpolation)' + CASE( np_sco ) ; WRITE(numout,*) ' ==>>> s-coord. (standard jacobian formulation)' + CASE( np_djc ) ; WRITE(numout,*) ' ==>>> s-coord. (Density Jacobian: Cubic polynomial)' + CASE( np_prj ) ; WRITE(numout,*) ' ==>>> s-coord. (Pressure Jacobian: Cubic polynomial)' + CASE( np_isf ) ; WRITE(numout,*) ' ==>>> s-coord. (standard jacobian formulation) for isf' + END SELECT + WRITE(numout,*) + ENDIF + ! + IF ( ln_hpg_djc ) THEN + IF (ln_hpg_djc_vnh) THEN ! Von Neumann boundary condition + IF(lwp) WRITE(numout,*) ' horizontal bc: von Neumann ' + aco_bc_hor = 6.0_wp/5.0_wp + bco_bc_hor = 7.0_wp/15.0_wp + ELSE ! Linear extrapolation + IF(lwp) WRITE(numout,*) ' horizontal bc: linear extrapolation' + aco_bc_hor = 3.0_wp/2.0_wp + bco_bc_hor = 1.0_wp/2.0_wp + END IF + IF (ln_hpg_djc_vnv) THEN ! Von Neumann boundary condition + IF(lwp) WRITE(numout,*) ' vertical bc: von Neumann ' + aco_bc_vrt = 6.0_wp/5.0_wp + bco_bc_vrt = 7.0_wp/15.0_wp + ELSE ! Linear extrapolation + IF(lwp) WRITE(numout,*) ' vertical bc: linear extrapolation' + aco_bc_vrt = 3.0_wp/2.0_wp + bco_bc_vrt = 1.0_wp/2.0_wp + END IF + END IF + ! + END SUBROUTINE dyn_hpg_init + + + SUBROUTINE hpg_zco( kt, Kmm, puu, pvv, Krhs ) + !!--------------------------------------------------------------------- + !! *** ROUTINE hpg_zco *** + !! + !! ** Method : z-coordinate case, levels are horizontal surfaces. + !! The now hydrostatic pressure gradient at a given level, jk, + !! is computed by taking the vertical integral of the in-situ + !! density gradient along the model level from the suface to that + !! level: zhpi = grav ..... + !! zhpj = grav ..... + !! add it to the general momentum trend (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)). + !! puu(:,:,:,Krhs) = puu(:,:,:,Krhs) - 1/e1u * zhpi + !! pvv(:,:,:,Krhs) = pvv(:,:,:,Krhs) - 1/e2v * zhpj + !! + !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcoef0, zcoef1 ! temporary scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zhpi, zhpj + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:hpg_zco : hydrostatic pressure gradient trend' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ z-coordinate case ' + ENDIF + ENDIF + ! + zcoef0 = - grav * 0.5_wp ! Local constant initialization + ! + DO_2D( 0, 0, 0, 0 ) ! Surface value + zcoef1 = zcoef0 * e3w(ji,jj,1,Kmm) + ! ! hydrostatic pressure gradient + zhpi(ji,jj) = zcoef1 * ( rhd(ji+1,jj,1) - rhd(ji,jj,1) ) * r1_e1u(ji,jj) + zhpj(ji,jj) = zcoef1 * ( rhd(ji,jj+1,1) - rhd(ji,jj,1) ) * r1_e2v(ji,jj) + ! ! add to the general momentum trend + puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj) + pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj) + END_2D + ! + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! interior value (2= 1 ) THEN ! on i-direction (level 2 or more) + puu (ji,jj,iku,Krhs) = puu(ji,jj,iku,Krhs) - zhpi(ji,jj,iku) ! subtract old value + zhpi(ji,jj,iku) = zhpi(ji,jj,iku-1) & ! compute the new one + & + zcoef2 * ( rhd(ji+1,jj,iku-1) - rhd(ji,jj,iku-1) + zgru(ji,jj) ) * r1_e1u(ji,jj) + puu (ji,jj,iku,Krhs) = puu(ji,jj,iku,Krhs) + zhpi(ji,jj,iku) ! add the new one to the general momentum trend + ENDIF + IF( ikv > 1 ) THEN ! on j-direction (level 2 or more) + pvv (ji,jj,ikv,Krhs) = pvv(ji,jj,ikv,Krhs) - zhpj(ji,jj,ikv) ! subtract old value + zhpj(ji,jj,ikv) = zhpj(ji,jj,ikv-1) & ! compute the new one + & + zcoef3 * ( rhd(ji,jj+1,ikv-1) - rhd(ji,jj,ikv-1) + zgrv(ji,jj) ) * r1_e2v(ji,jj) + pvv (ji,jj,ikv,Krhs) = pvv(ji,jj,ikv,Krhs) + zhpj(ji,jj,ikv) ! add the new one to the general momentum trend + ENDIF + END_2D + ! + END SUBROUTINE hpg_zps + + + SUBROUTINE hpg_sco( kt, Kmm, puu, pvv, Krhs ) + !!--------------------------------------------------------------------- + !! *** ROUTINE hpg_sco *** + !! + !! ** Method : s-coordinate case. Jacobian scheme. + !! The now hydrostatic pressure gradient at a given level, jk, + !! is computed by taking the vertical integral of the in-situ + !! density gradient along the model level from the suface to that + !! level. s-coordinates (ln_sco): a corrective term is added + !! to the horizontal pressure gradient : + !! zhpi = grav ..... + 1/e1u mi(rhd) di[ grav dep3w ] + !! zhpj = grav ..... + 1/e2v mj(rhd) dj[ grav dep3w ] + !! add it to the general momentum trend (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)). + !! puu(:,:,:,Krhs) = puu(:,:,:,Krhs) - 1/e1u * zhpi + !! pvv(:,:,:,Krhs) = pvv(:,:,:,Krhs) - 1/e2v * zhpj + !! + !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + !! + INTEGER :: ji, jj, jk, jii, jjj ! dummy loop indices + REAL(wp) :: zcoef0, zuap, zvap, ztmp ! local scalars + LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zhpi, zhpj + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter + !!---------------------------------------------------------------------- + ! + IF( ln_wd_il ) ALLOCATE(zcpx(A2D(nn_hls)), zcpy(A2D(nn_hls))) + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:hpg_sco : hydrostatic pressure gradient trend' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ s-coordinate case, OCE original scheme used' + ENDIF + ENDIF + ! + zcoef0 = - grav * 0.5_wp + ! + IF( ln_wd_il ) THEN + DO_2D( 0, 0, 0, 0 ) + ll_tmp1 = MIN( ssh(ji,jj,Kmm) , ssh(ji+1,jj,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & + & MAX( ssh(ji,jj,Kmm) + ht_0(ji,jj), ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( ssh(ji,jj,Kmm) - ssh(ji+1,jj,Kmm) ) > 1.E-12 ) .AND. ( & + & MAX( ssh(ji,jj,Kmm) , ssh(ji+1,jj,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) + + IF(ll_tmp1) THEN + zcpx(ji,jj) = 1.0_wp + ELSE IF(ll_tmp2) THEN + ! no worries about ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm) = 0, it won't happen ! here + zcpx(ji,jj) = ABS( (ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & + & / (ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm)) ) + ELSE + zcpx(ji,jj) = 0._wp + END IF + + ll_tmp1 = MIN( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & + & MAX( ssh(ji,jj,Kmm) + ht_0(ji,jj), ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( ssh(ji,jj,Kmm) - ssh(ji,jj+1,Kmm) ) > 1.E-12 ) .AND. ( & + & MAX( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) + + IF(ll_tmp1) THEN + zcpy(ji,jj) = 1.0_wp + ELSE IF(ll_tmp2) THEN + ! no worries about ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm) = 0, it won't happen ! here + zcpy(ji,jj) = ABS( (ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & + & / (ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm)) ) + ELSE + zcpy(ji,jj) = 0._wp + END IF + END_2D + END IF + ! + DO_2D( 0, 0, 0, 0 ) ! Surface value + ! ! hydrostatic pressure gradient along s-surfaces + zhpi(ji,jj,1) = zcoef0 * r1_e1u(ji,jj) & + & * ( e3w(ji+1,jj ,1,Kmm) * rhd(ji+1,jj ,1) & + & - e3w(ji ,jj ,1,Kmm) * rhd(ji ,jj ,1) ) + zhpj(ji,jj,1) = zcoef0 * r1_e2v(ji,jj) & + & * ( e3w(ji ,jj+1,1,Kmm) * rhd(ji ,jj+1,1) & + & - e3w(ji ,jj ,1,Kmm) * rhd(ji ,jj ,1) ) + ! ! s-coordinate pressure gradient correction + zuap = -zcoef0 * ( rhd (ji+1,jj,1) + rhd (ji,jj,1) ) & + & * ( gde3w(ji+1,jj,1) - gde3w(ji,jj,1) ) * r1_e1u(ji,jj) + zvap = -zcoef0 * ( rhd (ji,jj+1,1) + rhd (ji,jj,1) ) & + & * ( gde3w(ji,jj+1,1) - gde3w(ji,jj,1) ) * r1_e2v(ji,jj) + ! + IF( ln_wd_il ) THEN + zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) + zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) + zuap = zuap * zcpx(ji,jj) + zvap = zvap * zcpy(ji,jj) + ENDIF + ! ! add to the general momentum trend + puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj,1) + zuap + pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj,1) + zvap + END_2D + ! + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! interior value (2= & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & + & MAX( ssh(ji,jj,Kmm) + ht_0(ji,jj), ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( ssh(ji,jj,Kmm) - ssh(ji+1,jj,Kmm) ) > 1.E-12 ) .AND. ( & + & MAX( ssh(ji,jj,Kmm) , ssh(ji+1,jj,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) + IF(ll_tmp1) THEN + zcpx(ji,jj) = 1.0_wp + ELSE IF(ll_tmp2) THEN + ! no worries about ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm) = 0, it won't happen ! here + zcpx(ji,jj) = ABS( (ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & + & / (ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm)) ) + ELSE + zcpx(ji,jj) = 0._wp + END IF + + ll_tmp1 = MIN( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & + & MAX( ssh(ji,jj,Kmm) + ht_0(ji,jj), ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( ssh(ji,jj,Kmm) - ssh(ji,jj+1,Kmm) ) > 1.E-12 ) .AND. ( & + & MAX( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) + + IF(ll_tmp1) THEN + zcpy(ji,jj) = 1.0_wp + ELSE IF(ll_tmp2) THEN + ! no worries about ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm) = 0, it won't happen ! here + zcpy(ji,jj) = ABS( (ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & + & / (ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm)) ) + ELSE + zcpy(ji,jj) = 0._wp + END IF + END_2D + END IF + + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:hpg_djc : hydrostatic pressure gradient trend' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ s-coordinate case, density Jacobian with cubic polynomial scheme' + ENDIF + ENDIF + + ! Local constant initialization + zcoef0 = - grav * 0.5_wp + z_grav_10 = grav / 10._wp + z1_12 = 1.0_wp / 12._wp + + !---------------------------------------------------------------------------------------- + ! 1. compute and store elementary vertical differences in provisional arrays + !---------------------------------------------------------------------------------------- + +!!bug gm Not a true bug, but... zdzz=e3w for zdzx, zdzy verify what it is really + + DO_3D( 1, 1, 1, 1, 2, jpkm1 ) + zdrhoz(ji,jj,jk) = rhd (ji ,jj ,jk) - rhd (ji,jj,jk-1) + zdzz (ji,jj,jk) = - gde3w(ji ,jj ,jk) + gde3w(ji,jj,jk-1) + END_3D + + !------------------------------------------------------------------------- + ! 2. compute harmonic averages for vertical differences using eq. 5.18 + !------------------------------------------------------------------------- + zep = 1.e-15 + +!! mb zdrho_k, zdz_k, zdrho_i, zdz_i, zdrho_j, zdz_j re-centred about the point (ji,jj,jk) + zdrho_k(:,:,:) = 0._wp + zdz_k (:,:,:) = 0._wp + + DO_3D( 1, 1, 1, 1, 2, jpk-2 ) + cffw = MAX( 2._wp * zdrhoz(ji,jj,jk) * zdrhoz(ji,jj,jk+1), 0._wp ) + z1_cff = zdrhoz(ji,jj,jk) + zdrhoz(ji,jj,jk+1) + zdrho_k(ji,jj,jk) = cffw / SIGN( MAX( ABS(z1_cff), zep ), z1_cff ) + zdz_k(ji,jj,jk) = 2._wp * zdzz(ji,jj,jk) * zdzz(ji,jj,jk+1) & + & / ( zdzz(ji,jj,jk) + zdzz(ji,jj,jk+1) ) + END_3D + + !---------------------------------------------------------------------------------- + ! 3. apply boundary conditions at top and bottom using 5.36-5.37 + !---------------------------------------------------------------------------------- + +! mb for sea-ice shelves we will need to re-write this upper boundary condition in the same form as the lower boundary condition + DO_2D( 1, 1, 1, 1 ) + zdrho_k(ji,jj,1) = aco_bc_vrt * ( rhd (ji,jj,2) - rhd (ji,jj,1) ) - bco_bc_vrt * zdrho_k(ji,jj,2) + zdz_k (ji,jj,1) = aco_bc_vrt * (-gde3w(ji,jj,2) + gde3w(ji,jj,1) ) - bco_bc_vrt * zdz_k (ji,jj,2) + END_2D + + DO_2D( 1, 1, 1, 1 ) + IF ( mbkt(ji,jj)>1 ) THEN + iktb = mbkt(ji,jj) + zdrho_k(ji,jj,iktb) = aco_bc_vrt * ( rhd(ji,jj,iktb) - rhd(ji,jj,iktb-1) ) - bco_bc_vrt * zdrho_k(ji,jj,iktb-1) + zdz_k (ji,jj,iktb) = aco_bc_vrt * (-gde3w(ji,jj,iktb) + gde3w(ji,jj,iktb-1) ) - bco_bc_vrt * zdz_k (ji,jj,iktb-1) + END IF + END_2D + + !-------------------------------------------------------------- + ! 4. Compute side face integrals + !------------------------------------------------------------- + +!! ssh replaces e3w_n ; gde3w is a depth; the formulae involve heights +!! rho_k stores grav * FX / rho_0 + + !-------------------------------------------------------------- + ! 4. a) Upper half of top-most grid box, compute and store + !------------------------------------------------------------- +! *** AY note: ssh(ji,jj,Kmm) + gde3w(ji,jj,1) = e3w(ji,jj,1,Kmm) + DO_2D( 0, 1, 0, 1) + z_rho_k(ji,jj,1) = grav * gdept(ji,jj,1,Kmm) & + & * ( rhd(ji,jj,1) & + & -0.5_wp * ( rhd(ji,jj,2) - rhd(ji,jj,1) ) & + & * gdept(ji,jj,1,Kmm) / e3w(ji,jj,2,Kmm) & + & ) + END_2D + + !-------------------------------------------------------------- + ! 4. b) Interior faces, compute and store + !------------------------------------------------------------- + + DO_3D( 0, 1, 0, 1, 2, jpkm1 ) + z_rho_k(ji,jj,jk) = zcoef0 * ( rhd (ji,jj,jk) + rhd (ji,jj,jk-1) ) & + & * ( - gde3w(ji,jj,jk) + gde3w(ji,jj,jk-1) ) & + & + z_grav_10 * ( & + & ( zdrho_k (ji,jj,jk) - zdrho_k (ji,jj,jk-1) ) & + & * ( - gde3w(ji,jj,jk) + gde3w(ji,jj,jk-1) - z1_12 * ( zdz_k (ji,jj,jk) + zdz_k (ji,jj,jk-1) ) ) & + & - ( zdz_k (ji,jj,jk) - zdz_k (ji,jj,jk-1) ) & + & * ( rhd (ji,jj,jk) - rhd (ji,jj,jk-1) - z1_12 * ( zdrho_k(ji,jj,jk) + zdrho_k(ji,jj,jk-1) ) ) & + & ) + END_3D + + !---------------------------------------------------------------------------------------- + ! 5. compute and store elementary horizontal differences in provisional arrays + !---------------------------------------------------------------------------------------- + zdrhox(:,:,:) = 0._wp + zdzx (:,:,:) = 0._wp + zdrhoy(:,:,:) = 0._wp + zdzy (:,:,:) = 0._wp + + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + zdrhox(ji,jj,jk) = rhd (ji+1,jj ,jk) - rhd (ji ,jj ,jk) + zdzx (ji,jj,jk) = gde3w(ji ,jj ,jk) - gde3w(ji+1,jj ,jk) + zdrhoy(ji,jj,jk) = rhd (ji ,jj+1,jk) - rhd (ji ,jj ,jk) + zdzy (ji,jj,jk) = gde3w(ji ,jj ,jk) - gde3w(ji ,jj+1,jk) + END_3D + + IF( nn_hls == 1 ) CALL lbc_lnk( 'dynhpg', zdrhox, 'U', -1._wp, zdzx, 'U', -1._wp, zdrhoy, 'V', -1._wp, zdzy, 'V', -1._wp ) + + !------------------------------------------------------------------------- + ! 6. compute harmonic averages using eq. 5.18 + !------------------------------------------------------------------------- + + DO_3D( 0, 1, 0, 1, 1, jpkm1 ) + cffu = MAX( 2._wp * zdrhox(ji-1,jj,jk) * zdrhox(ji,jj,jk), 0._wp ) + z1_cff = zdrhox(ji-1,jj,jk) + zdrhox(ji,jj,jk) + zdrho_i(ji,jj,jk) = cffu / SIGN( MAX( ABS(z1_cff), zep ), z1_cff ) + + cffx = MAX( 2._wp * zdzx(ji-1,jj,jk) * zdzx(ji,jj,jk), 0._wp ) + z1_cff = zdzx(ji-1,jj,jk) + zdzx(ji,jj,jk) + zdz_i(ji,jj,jk) = cffx / SIGN( MAX( ABS(z1_cff), zep ), z1_cff ) + + cffv = MAX( 2._wp * zdrhoy(ji,jj-1,jk) * zdrhoy(ji,jj,jk), 0._wp ) + z1_cff = zdrhoy(ji,jj-1,jk) + zdrhoy(ji,jj,jk) + zdrho_j(ji,jj,jk) = cffv / SIGN( MAX( ABS(z1_cff), zep ), z1_cff ) + + cffy = MAX( 2._wp * zdzy(ji,jj-1,jk) * zdzy(ji,jj,jk), 0._wp ) + z1_cff = zdzy(ji,jj-1,jk) + zdzy(ji,jj,jk) + zdz_j(ji,jj,jk) = cffy / SIGN( MAX( ABS(z1_cff), zep ), z1_cff ) + END_3D + +!!! Note that zdzx, zdzy, zdzz, zdrhox, zdrhoy and zdrhoz should NOT be used beyond this point + + !---------------------------------------------------------------------------------- + ! 6B. apply boundary conditions at side boundaries using 5.36-5.37 + !---------------------------------------------------------------------------------- + + DO jk = 1, jpkm1 + zz_drho_i(:,:) = zdrho_i(:,:,jk) + zz_dz_i (:,:) = zdz_i (:,:,jk) + zz_drho_j(:,:) = zdrho_j(:,:,jk) + zz_dz_j (:,:) = zdz_j (:,:,jk) + ! Walls coming from left: should check from 2 to jpi-1 (and jpj=2-jpj) + DO_2D( 0, 0, 0, 1 ) + IF ( umask(ji,jj,jk) > 0.5_wp .AND. umask(ji-1,jj,jk) < 0.5_wp .AND. umask(ji+1,jj,jk) > 0.5_wp) THEN + zz_drho_i(ji,jj) = aco_bc_hor * ( rhd (ji+1,jj,jk) - rhd (ji,jj,jk) ) - bco_bc_hor * zdrho_i(ji+1,jj,jk) + zz_dz_i (ji,jj) = aco_bc_hor * (-gde3w(ji+1,jj,jk) + gde3w(ji,jj,jk) ) - bco_bc_hor * zdz_i (ji+1,jj,jk) + END IF + END_2D + ! Walls coming from right: should check from 3 to jpi (and jpj=2-jpj) + DO_2D( -1, 1, 0, 1 ) + IF ( umask(ji,jj,jk) < 0.5_wp .AND. umask(ji-1,jj,jk) > 0.5_wp .AND. umask(ji-2,jj,jk) > 0.5_wp) THEN + zz_drho_i(ji,jj) = aco_bc_hor * ( rhd (ji,jj,jk) - rhd (ji-1,jj,jk) ) - bco_bc_hor * zdrho_i(ji-1,jj,jk) + zz_dz_i (ji,jj) = aco_bc_hor * (-gde3w(ji,jj,jk) + gde3w(ji-1,jj,jk) ) - bco_bc_hor * zdz_i (ji-1,jj,jk) + END IF + END_2D + ! Walls coming from left: should check from 2 to jpj-1 (and jpi=2-jpi) + DO_2D( 0, 1, 0, 0 ) + IF ( vmask(ji,jj,jk) > 0.5_wp .AND. vmask(ji,jj-1,jk) < 0.5_wp .AND. vmask(ji,jj+1,jk) > 0.5_wp) THEN + zz_drho_j(ji,jj) = aco_bc_hor * ( rhd (ji,jj+1,jk) - rhd (ji,jj,jk) ) - bco_bc_hor * zdrho_j(ji,jj+1,jk) + zz_dz_j (ji,jj) = aco_bc_hor * (-gde3w(ji,jj+1,jk) + gde3w(ji,jj,jk) ) - bco_bc_hor * zdz_j (ji,jj+1,jk) + END IF + END_2D + ! Walls coming from right: should check from 3 to jpj (and jpi=2-jpi) + DO_2D( 0, 1, -1, 1 ) + IF ( vmask(ji,jj,jk) < 0.5_wp .AND. vmask(ji,jj-1,jk) > 0.5_wp .AND. vmask(ji,jj-2,jk) > 0.5_wp) THEN + zz_drho_j(ji,jj) = aco_bc_hor * ( rhd (ji,jj,jk) - rhd (ji,jj-1,jk) ) - bco_bc_hor * zdrho_j(ji,jj-1,jk) + zz_dz_j (ji,jj) = aco_bc_hor * (-gde3w(ji,jj,jk) + gde3w(ji,jj-1,jk) ) - bco_bc_hor * zdz_j (ji,jj-1,jk) + END IF + END_2D + zdrho_i(:,:,jk) = zz_drho_i(:,:) + zdz_i (:,:,jk) = zz_dz_i (:,:) + zdrho_j(:,:,jk) = zz_drho_j(:,:) + zdz_j (:,:,jk) = zz_dz_j (:,:) + END DO + + !-------------------------------------------------------------- + ! 7. Calculate integrals on side faces + !------------------------------------------------------------- + + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) +! two -ve signs cancel in next two lines (within zcoef0 and because gde3w is a depth not a height) + z_rho_i(ji,jj,jk) = zcoef0 * ( rhd (ji+1,jj,jk) + rhd (ji,jj,jk) ) & + & * ( gde3w(ji+1,jj,jk) - gde3w(ji,jj,jk) ) + IF ( umask(ji-1, jj, jk) > 0.5 .OR. umask(ji+1, jj, jk) > 0.5 ) THEN + z_rho_i(ji,jj,jk) = z_rho_i(ji,jj,jk) - z_grav_10 * ( & + & ( zdrho_i (ji+1,jj,jk) - zdrho_i (ji,jj,jk) ) & + & * ( - gde3w(ji+1,jj,jk) + gde3w(ji,jj,jk) - z1_12 * ( zdz_i (ji+1,jj,jk) + zdz_i (ji,jj,jk) ) ) & + & - ( zdz_i (ji+1,jj,jk) - zdz_i (ji,jj,jk) ) & + & * ( rhd (ji+1,jj,jk) - rhd (ji,jj,jk) - z1_12 * ( zdrho_i(ji+1,jj,jk) + zdrho_i(ji,jj,jk) ) ) & + & ) + END IF + + z_rho_j(ji,jj,jk) = zcoef0 * ( rhd (ji,jj+1,jk) + rhd (ji,jj,jk) ) & + & * ( gde3w(ji,jj+1,jk) - gde3w(ji,jj,jk) ) + IF ( vmask(ji, jj-1, jk) > 0.5 .OR. vmask(ji, jj+1, jk) > 0.5 ) THEN + z_rho_j(ji,jj,jk) = z_rho_j(ji,jj,jk) - z_grav_10 * ( & + & ( zdrho_j (ji,jj+1,jk) - zdrho_j (ji,jj,jk) ) & + & * ( - gde3w(ji,jj+1,jk) + gde3w(ji,jj,jk) - z1_12 * ( zdz_j (ji,jj+1,jk) + zdz_j (ji,jj,jk) ) ) & + & - ( zdz_j (ji,jj+1,jk) - zdz_j (ji,jj,jk) ) & + & * ( rhd (ji,jj+1,jk) - rhd (ji,jj,jk) - z1_12 * ( zdrho_j(ji,jj+1,jk) + zdrho_j(ji,jj,jk) ) ) & + & ) + END IF + END_3D + + !-------------------------------------------------------------- + ! 8. Integrate in the vertical + !------------------------------------------------------------- + ! + ! --------------- + ! Surface value + ! --------------- + DO_2D( 0, 0, 0, 0 ) + zhpi(ji,jj,1) = ( z_rho_k(ji,jj,1) - z_rho_k(ji+1,jj ,1) - z_rho_i(ji,jj,1) ) * r1_e1u(ji,jj) + zhpj(ji,jj,1) = ( z_rho_k(ji,jj,1) - z_rho_k(ji ,jj+1,1) - z_rho_j(ji,jj,1) ) * r1_e2v(ji,jj) + IF( ln_wd_il ) THEN + zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) + zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj) + ENDIF + ! add to the general momentum trend + puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj,1) + pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj,1) + END_2D + + ! ---------------- + ! interior value (2= & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & + & MAX( ssh(ji,jj,Kmm) + ht_0(ji,jj), ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) ) > & + & rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( ssh(ji,jj,Kmm) - ssh(ji+1,jj,Kmm) ) > 1.E-12 ) .AND. & + & ( MAX( ssh(ji,jj,Kmm) , ssh(ji+1,jj,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) + + IF(ll_tmp1) THEN + zcpx(ji,jj) = 1.0_wp + ELSE IF(ll_tmp2) THEN + ! no worries about ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm) = 0, it won't happen ! here + zcpx(ji,jj) = ABS( (ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & + & / (ssh(ji+1,jj,Kmm) - ssh(ji ,jj,Kmm)) ) + zcpx(ji,jj) = MAX(MIN( zcpx(ji,jj) , 1.0_wp),0.0_wp) + ELSE + zcpx(ji,jj) = 0._wp + END IF + + ll_tmp1 = MIN( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & + & MAX( ssh(ji,jj,Kmm) + ht_0(ji,jj), ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) ) > & + & rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( ssh(ji,jj,Kmm) - ssh(ji,jj+1,Kmm) ) > 1.E-12 ) .AND. & + & ( MAX( ssh(ji,jj,Kmm) , ssh(ji,jj+1,Kmm) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) + + IF(ll_tmp1) THEN + zcpy(ji,jj) = 1.0_wp + ELSE IF(ll_tmp2) THEN + ! no worries about ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm) = 0, it won't happen ! here + zcpy(ji,jj) = ABS( (ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & + & / (ssh(ji,jj+1,Kmm) - ssh(ji,jj ,Kmm)) ) + zcpy(ji,jj) = MAX(MIN( zcpy(ji,jj) , 1.0_wp),0.0_wp) + ELSE + zcpy(ji,jj) = 0._wp + ENDIF + END_2D + ENDIF + + ! Clean 3-D work arrays + zhpi(:,:,:) = 0._wp + zrhh(:,:,:) = rhd(A2D(nn_hls),:) + + ! Preparing vertical density profile "zrhh(:,:,:)" for hybrid-sco coordinate + DO_2D( 1, 1, 1, 1 ) + jk = mbkt(ji,jj) + IF( jk <= 1 ) THEN ; zrhh(ji,jj, : ) = 0._wp + ELSEIF( jk == 2 ) THEN ; zrhh(ji,jj,jk+1:jpk) = rhd(ji,jj,jk) + ELSEIF( jk < jpkm1 ) THEN + DO jkk = jk+1, jpk + zrhh(ji,jj,jkk) = interp1(gde3w(ji,jj,jkk ), gde3w(ji,jj,jkk-1), & + & gde3w(ji,jj,jkk-2), zrhh (ji,jj,jkk-1), zrhh(ji,jj,jkk-2)) + END DO + ENDIF + END_2D + + ! Transfer the depth of "T(:,:,:)" to vertical coordinate "zdept(:,:,:)" + DO_2D( 1, 1, 1, 1 ) + zdept(ji,jj,1) = 0.5_wp * e3w(ji,jj,1,Kmm) - ssh(ji,jj,Kmm) + END_2D + + DO_3D( 1, 1, 1, 1, 2, jpk ) + zdept(ji,jj,jk) = zdept(ji,jj,jk-1) + e3w(ji,jj,jk,Kmm) + END_3D + + fsp(:,:,:) = zrhh (:,:,:) + xsp(:,:,:) = zdept(:,:,:) + + ! Construct the vertical density profile with the + ! constrained cubic spline interpolation + ! rho(z) = asp + bsp*z + csp*z^2 + dsp*z^3 + CALL cspline( fsp, xsp, asp, bsp, csp, dsp, polynomial_type ) + + ! Integrate the hydrostatic pressure "zhpi(:,:,:)" at "T(ji,jj,1)" + DO_2D( 0, 1, 0, 1 ) + zrhdt1 = zrhh(ji,jj,1) - interp3( zdept(ji,jj,1), asp(ji,jj,1), bsp(ji,jj,1), & + & csp(ji,jj,1), dsp(ji,jj,1) ) * 0.25_wp * e3w(ji,jj,1,Kmm) + + ! assuming linear profile across the top half surface layer + zhpi(ji,jj,1) = 0.5_wp * e3w(ji,jj,1,Kmm) * zrhdt1 + END_2D + + ! Calculate the pressure "zhpi(:,:,:)" at "T(ji,jj,2:jpkm1)" + DO_3D( 0, 1, 0, 1, 2, jpkm1 ) + zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + & + & integ_spline( zdept(ji,jj,jk-1), zdept(ji,jj,jk), & + & asp (ji,jj,jk-1), bsp (ji,jj,jk-1), & + & csp (ji,jj,jk-1), dsp (ji,jj,jk-1) ) + END_3D + + ! Z coordinate of U(ji,jj,1:jpkm1) and V(ji,jj,1:jpkm1) + + ! Prepare zsshu_n and zsshv_n + DO_2D( 0, 0, 0, 0 ) +!!gm BUG ? if it is ssh at u- & v-point then it should be: +! zsshu_n(ji,jj) = (e1e2t(ji,jj) * ssh(ji,jj,Kmm) + e1e2t(ji+1,jj) * ssh(ji+1,jj,Kmm)) * & +! & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp +! zsshv_n(ji,jj) = (e1e2t(ji,jj) * ssh(ji,jj,Kmm) + e1e2t(ji,jj+1) * ssh(ji,jj+1,Kmm)) * & +! & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp +!!gm not this: + zsshu_n(ji,jj) = (e1e2u(ji,jj) * ssh(ji,jj,Kmm) + e1e2u(ji+1, jj) * ssh(ji+1,jj,Kmm)) * & + & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp + zsshv_n(ji,jj) = (e1e2v(ji,jj) * ssh(ji,jj,Kmm) + e1e2v(ji+1, jj) * ssh(ji,jj+1,Kmm)) * & + & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp + END_2D + + DO_2D( 0, 0, 0, 0 ) + zu(ji,jj,1) = - ( e3u(ji,jj,1,Kmm) - zsshu_n(ji,jj) ) + zv(ji,jj,1) = - ( e3v(ji,jj,1,Kmm) - zsshv_n(ji,jj) ) + END_2D + + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + zu(ji,jj,jk) = zu(ji,jj,jk-1) - e3u(ji,jj,jk,Kmm) + zv(ji,jj,jk) = zv(ji,jj,jk-1) - e3v(ji,jj,jk,Kmm) + END_3D + + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zu(ji,jj,jk) = zu(ji,jj,jk) + 0.5_wp * e3u(ji,jj,jk,Kmm) + zv(ji,jj,jk) = zv(ji,jj,jk) + 0.5_wp * e3v(ji,jj,jk,Kmm) + END_3D + + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zu(ji,jj,jk) = MIN( zu(ji,jj,jk) , MAX( -zdept(ji,jj,jk) , -zdept(ji+1,jj,jk) ) ) + zu(ji,jj,jk) = MAX( zu(ji,jj,jk) , MIN( -zdept(ji,jj,jk) , -zdept(ji+1,jj,jk) ) ) + zv(ji,jj,jk) = MIN( zv(ji,jj,jk) , MAX( -zdept(ji,jj,jk) , -zdept(ji,jj+1,jk) ) ) + zv(ji,jj,jk) = MAX( zv(ji,jj,jk) , MIN( -zdept(ji,jj,jk) , -zdept(ji,jj+1,jk) ) ) + END_3D + + + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zpwes = 0._wp; zpwed = 0._wp + zpnss = 0._wp; zpnsd = 0._wp + zuijk = zu(ji,jj,jk) + zvijk = zv(ji,jj,jk) + + !!!!! for u equation + IF( jk <= mbku(ji,jj) ) THEN + IF( -zdept(ji+1,jj,jk) >= -zdept(ji,jj,jk) ) THEN + jis = ji + 1; jid = ji + ELSE + jis = ji; jid = ji +1 + ENDIF + + ! integrate the pressure on the shallow side + jk1 = jk + DO WHILE ( -zdept(jis,jj,jk1) > zuijk ) + IF( jk1 == mbku(ji,jj) ) THEN + zuijk = -zdept(jis,jj,jk1) + EXIT + ENDIF + zdeps = MIN(zdept(jis,jj,jk1+1), -zuijk) + zpwes = zpwes + & + integ_spline(zdept(jis,jj,jk1), zdeps, & + asp(jis,jj,jk1), bsp(jis,jj,jk1), & + csp(jis,jj,jk1), dsp(jis,jj,jk1)) + jk1 = jk1 + 1 + END DO + + ! integrate the pressure on the deep side + jk1 = jk + DO WHILE ( -zdept(jid,jj,jk1) < zuijk ) + IF( jk1 == 1 ) THEN + zdeps = zdept(jid,jj,1) + MIN(zuijk, ssh(jid,jj,Kmm)*znad) + zrhdt1 = zrhh(jid,jj,1) - interp3(zdept(jid,jj,1), asp(jid,jj,1), & + bsp(jid,jj,1) , csp(jid,jj,1), & + dsp(jid,jj,1)) * zdeps + zpwed = zpwed + 0.5_wp * (zrhh(jid,jj,1) + zrhdt1) * zdeps + EXIT + ENDIF + zdeps = MAX(zdept(jid,jj,jk1-1), -zuijk) + zpwed = zpwed + & + integ_spline(zdeps, zdept(jid,jj,jk1), & + asp(jid,jj,jk1-1), bsp(jid,jj,jk1-1), & + csp(jid,jj,jk1-1), dsp(jid,jj,jk1-1) ) + jk1 = jk1 - 1 + END DO + + ! update the momentum trends in u direction + zdpdx1 = zcoef0 * r1_e1u(ji,jj) * ( zhpi(ji+1,jj,jk) - zhpi(ji,jj,jk) ) + IF( .NOT.ln_linssh ) THEN + zdpdx2 = zcoef0 * r1_e1u(ji,jj) * & + & ( REAL(jis-jid, wp) * (zpwes + zpwed) + (ssh(ji+1,jj,Kmm)-ssh(ji,jj,Kmm)) ) + ELSE + zdpdx2 = zcoef0 * r1_e1u(ji,jj) * REAL(jis-jid, wp) * (zpwes + zpwed) + ENDIF + IF( ln_wd_il ) THEN + zdpdx1 = zdpdx1 * zcpx(ji,jj) * wdrampu(ji,jj) + zdpdx2 = zdpdx2 * zcpx(ji,jj) * wdrampu(ji,jj) + ENDIF + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + (zdpdx1 + zdpdx2 - zpgu(ji,jj)) * umask(ji,jj,jk) + ENDIF + + !!!!! for v equation + IF( jk <= mbkv(ji,jj) ) THEN + IF( -zdept(ji,jj+1,jk) >= -zdept(ji,jj,jk) ) THEN + jjs = jj + 1; jjd = jj + ELSE + jjs = jj ; jjd = jj + 1 + ENDIF + + ! integrate the pressure on the shallow side + jk1 = jk + DO WHILE ( -zdept(ji,jjs,jk1) > zvijk ) + IF( jk1 == mbkv(ji,jj) ) THEN + zvijk = -zdept(ji,jjs,jk1) + EXIT + ENDIF + zdeps = MIN(zdept(ji,jjs,jk1+1), -zvijk) + zpnss = zpnss + & + integ_spline(zdept(ji,jjs,jk1), zdeps, & + asp(ji,jjs,jk1), bsp(ji,jjs,jk1), & + csp(ji,jjs,jk1), dsp(ji,jjs,jk1) ) + jk1 = jk1 + 1 + END DO + + ! integrate the pressure on the deep side + jk1 = jk + DO WHILE ( -zdept(ji,jjd,jk1) < zvijk ) + IF( jk1 == 1 ) THEN + zdeps = zdept(ji,jjd,1) + MIN(zvijk, ssh(ji,jjd,Kmm)*znad) + zrhdt1 = zrhh(ji,jjd,1) - interp3(zdept(ji,jjd,1), asp(ji,jjd,1), & + bsp(ji,jjd,1) , csp(ji,jjd,1), & + dsp(ji,jjd,1) ) * zdeps + zpnsd = zpnsd + 0.5_wp * (zrhh(ji,jjd,1) + zrhdt1) * zdeps + EXIT + ENDIF + zdeps = MAX(zdept(ji,jjd,jk1-1), -zvijk) + zpnsd = zpnsd + & + integ_spline(zdeps, zdept(ji,jjd,jk1), & + asp(ji,jjd,jk1-1), bsp(ji,jjd,jk1-1), & + csp(ji,jjd,jk1-1), dsp(ji,jjd,jk1-1) ) + jk1 = jk1 - 1 + END DO + + ! update the momentum trends in v direction + zdpdy1 = zcoef0 * r1_e2v(ji,jj) * ( zhpi(ji,jj+1,jk) - zhpi(ji,jj,jk) ) + IF( .NOT.ln_linssh ) THEN + zdpdy2 = zcoef0 * r1_e2v(ji,jj) * & + ( REAL(jjs-jjd, wp) * (zpnss + zpnsd) + (ssh(ji,jj+1,Kmm)-ssh(ji,jj,Kmm)) ) + ELSE + zdpdy2 = zcoef0 * r1_e2v(ji,jj) * REAL(jjs-jjd, wp) * (zpnss + zpnsd ) + ENDIF + IF( ln_wd_il ) THEN + zdpdy1 = zdpdy1 * zcpy(ji,jj) * wdrampv(ji,jj) + zdpdy2 = zdpdy2 * zcpy(ji,jj) * wdrampv(ji,jj) + ENDIF + + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + (zdpdy1 + zdpdy2 - zpgv(ji,jj)) * vmask(ji,jj,jk) + ENDIF + ! + END_3D + ! + IF( ln_wd_il ) DEALLOCATE( zcpx, zcpy ) + ! + END SUBROUTINE hpg_prj + + + SUBROUTINE cspline( fsp, xsp, asp, bsp, csp, dsp, polynomial_type ) + !!---------------------------------------------------------------------- + !! *** ROUTINE cspline *** + !! + !! ** Purpose : constrained cubic spline interpolation + !! + !! ** Method : f(x) = asp + bsp*x + csp*x^2 + dsp*x^3 + !! + !! Reference: CJC Kruger, Constrained Cubic Spline Interpoltation + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: fsp, xsp ! value and coordinate + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT( out) :: asp, bsp, csp, dsp ! coefficients of the interpoated function + INTEGER , INTENT(in ) :: polynomial_type ! 1: cubic spline ; 2: Linear + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zdf1, zdf2, zddf1, zddf2, ztmp1, ztmp2, zdxtmp + REAL(wp) :: zdxtmp1, zdxtmp2, zalpha + REAL(wp), DIMENSION(jpk) :: zdf + !!---------------------------------------------------------------------- + ! + IF (polynomial_type == 1) THEN ! Constrained Cubic Spline + DO_2D( 1, 1, 1, 1 ) + !!Fritsch&Butland's method, 1984 (preferred, but more computation) + ! DO jk = 2, jpkm1-1 + ! zdxtmp1 = xsp(ji,jj,jk) - xsp(ji,jj,jk-1) + ! zdxtmp2 = xsp(ji,jj,jk+1) - xsp(ji,jj,jk) + ! zdf1 = ( fsp(ji,jj,jk) - fsp(ji,jj,jk-1) ) / zdxtmp1 + ! zdf2 = ( fsp(ji,jj,jk+1) - fsp(ji,jj,jk) ) / zdxtmp2 + ! + ! zalpha = ( zdxtmp1 + 2._wp * zdxtmp2 ) / ( zdxtmp1 + zdxtmp2 ) / 3._wp + ! + ! IF(zdf1 * zdf2 <= 0._wp) THEN + ! zdf(jk) = 0._wp + ! ELSE + ! zdf(jk) = zdf1 * zdf2 / ( ( 1._wp - zalpha ) * zdf1 + zalpha * zdf2 ) + ! ENDIF + ! END DO + + !!Simply geometric average + DO jk = 2, jpk-2 + zdf1 = (fsp(ji,jj,jk ) - fsp(ji,jj,jk-1)) / (xsp(ji,jj,jk ) - xsp(ji,jj,jk-1)) + zdf2 = (fsp(ji,jj,jk+1) - fsp(ji,jj,jk )) / (xsp(ji,jj,jk+1) - xsp(ji,jj,jk )) + + IF(zdf1 * zdf2 <= 0._wp) THEN + zdf(jk) = 0._wp + ELSE + zdf(jk) = 2._wp * zdf1 * zdf2 / (zdf1 + zdf2) + ENDIF + END DO + + zdf(1) = 1.5_wp * ( fsp(ji,jj,2) - fsp(ji,jj,1) ) / & + & ( xsp(ji,jj,2) - xsp(ji,jj,1) ) - 0.5_wp * zdf(2) + zdf(jpkm1) = 1.5_wp * ( fsp(ji,jj,jpkm1) - fsp(ji,jj,jpkm1-1) ) / & + & ( xsp(ji,jj,jpkm1) - xsp(ji,jj,jpkm1-1) ) - 0.5_wp * zdf(jpk - 2) + + DO jk = 1, jpk-2 + zdxtmp = xsp(ji,jj,jk+1) - xsp(ji,jj,jk) + ztmp1 = (zdf(jk+1) + 2._wp * zdf(jk)) / zdxtmp + ztmp2 = 6._wp * (fsp(ji,jj,jk+1) - fsp(ji,jj,jk)) / zdxtmp / zdxtmp + zddf1 = -2._wp * ztmp1 + ztmp2 + ztmp1 = (2._wp * zdf(jk+1) + zdf(jk)) / zdxtmp + zddf2 = 2._wp * ztmp1 - ztmp2 + + dsp(ji,jj,jk) = (zddf2 - zddf1) / 6._wp / zdxtmp + csp(ji,jj,jk) = ( xsp(ji,jj,jk+1) * zddf1 - xsp(ji,jj,jk)*zddf2 ) / 2._wp / zdxtmp + bsp(ji,jj,jk) = ( fsp(ji,jj,jk+1) - fsp(ji,jj,jk) ) / zdxtmp - & + & csp(ji,jj,jk) * ( xsp(ji,jj,jk+1) + xsp(ji,jj,jk) ) - & + & dsp(ji,jj,jk) * ((xsp(ji,jj,jk+1) + xsp(ji,jj,jk))**2 - & + & xsp(ji,jj,jk+1) * xsp(ji,jj,jk)) + asp(ji,jj,jk) = fsp(ji,jj,jk) - xsp(ji,jj,jk) * (bsp(ji,jj,jk) + & + & (xsp(ji,jj,jk) * (csp(ji,jj,jk) + & + & dsp(ji,jj,jk) * xsp(ji,jj,jk)))) + END DO + END_2D + + ELSEIF ( polynomial_type == 2 ) THEN ! Linear + DO_3D( 1, 1, 1, 1, 1, jpk-2 ) + zdxtmp =xsp(ji,jj,jk+1) - xsp(ji,jj,jk) + ztmp1 = fsp(ji,jj,jk+1) - fsp(ji,jj,jk) + + dsp(ji,jj,jk) = 0._wp + csp(ji,jj,jk) = 0._wp + bsp(ji,jj,jk) = ztmp1 / zdxtmp + asp(ji,jj,jk) = fsp(ji,jj,jk) - bsp(ji,jj,jk) * xsp(ji,jj,jk) + END_3D + ! + ELSE + CALL ctl_stop( 'invalid polynomial type in cspline' ) + ENDIF + ! + END SUBROUTINE cspline + + + FUNCTION interp1(x, xl, xr, fl, fr) RESULT(f) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp1 *** + !! + !! ** Purpose : 1-d linear interpolation + !! + !! ** Method : interpolation is straight forward + !! extrapolation is also permitted (no value limit) + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: fl, fr + REAL(dp), INTENT(in) :: x, xl, xr + REAL(wp) :: f ! result of the interpolation (extrapolation) + REAL(wp) :: zdeltx + !!---------------------------------------------------------------------- + ! + zdeltx = xr - xl + IF( abs(zdeltx) <= 10._wp * EPSILON(x) ) THEN + f = 0.5_wp * (fl + fr) + ELSE + f = ( (x - xl ) * fr - ( x - xr ) * fl ) / zdeltx + ENDIF + ! + END FUNCTION interp1 + + + FUNCTION interp2( x, a, b, c, d ) RESULT(f) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp1 *** + !! + !! ** Purpose : 1-d constrained cubic spline interpolation + !! + !! ** Method : cubic spline interpolation + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: x, a, b, c, d + REAL(wp) :: f ! value from the interpolation + !!---------------------------------------------------------------------- + ! + f = a + x* ( b + x * ( c + d * x ) ) + ! + END FUNCTION interp2 + + + FUNCTION interp3( x, a, b, c, d ) RESULT(f) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp1 *** + !! + !! ** Purpose : Calculate the first order of derivative of + !! a cubic spline function y=a+b*x+c*x^2+d*x^3 + !! + !! ** Method : f=dy/dx=b+2*c*x+3*d*x^2 + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: x, a, b, c, d + REAL(wp) :: f ! value from the interpolation + !!---------------------------------------------------------------------- + ! + f = b + x * ( 2._wp * c + 3._wp * d * x) + ! + END FUNCTION interp3 + + + FUNCTION integ_spline( xl, xr, a, b, c, d ) RESULT(f) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp1 *** + !! + !! ** Purpose : 1-d constrained cubic spline integration + !! + !! ** Method : integrate polynomial a+bx+cx^2+dx^3 from xl to xr + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: xl, xr, a, b, c, d + REAL(wp) :: za1, za2, za3 + REAL(wp) :: f ! integration result + !!---------------------------------------------------------------------- + ! + za1 = 0.5_wp * b + za2 = c / 3.0_wp + za3 = 0.25_wp * d + ! + f = xr * ( a + xr * ( za1 + xr * ( za2 + za3 * xr ) ) ) - & + & xl * ( a + xl * ( za1 + xl * ( za2 + za3 * xl ) ) ) + ! + END FUNCTION integ_spline + + !!====================================================================== +END MODULE dynhpg \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynkeg.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynkeg.F90 new file mode 100644 index 0000000..024a454 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynkeg.F90 @@ -0,0 +1,153 @@ +MODULE dynkeg + !!====================================================================== + !! *** MODULE dynkeg *** + !! Ocean dynamics: kinetic energy gradient trend + !!====================================================================== + !! History : 1.0 ! 1987-09 (P. Andrich, M.-A. Foujols) Original code + !! 7.0 ! 1997-05 (G. Madec) Split dynber into dynkeg and dynhpg + !! NEMO 1.0 ! 2002-07 (G. Madec) F90: Free form and module + !! 3.6 ! 2015-05 (N. Ducousso, G. Madec) add Hollingsworth scheme as an option + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_keg : update the momentum trend with the horizontal tke + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + USE prtctl ! Print control + USE timing ! Timing + USE bdy_oce ! ocean open boundary conditions + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_keg ! routine called by step module + + INTEGER, PARAMETER, PUBLIC :: nkeg_C2 = 0 !: 2nd order centered scheme (standard scheme) + INTEGER, PARAMETER, PUBLIC :: nkeg_HW = 1 !: Hollingsworth et al., QJRMS, 1983 + ! + REAL(wp) :: r1_48 = 1._wp / 48._wp !: =1/(4*2*6) + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynkeg.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_keg( kt, kscheme, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_keg *** + !! + !! ** Purpose : Compute the now momentum trend due to the horizontal + !! gradient of the horizontal kinetic energy and add it to the + !! general momentum trend. + !! + !! ** Method : * kscheme = nkeg_C2 : 2nd order centered scheme that + !! conserve kinetic energy. Compute the now horizontal kinetic energy + !! zhke = 1/2 [ mi-1( un^2 ) + mj-1( vn^2 ) ] + !! * kscheme = nkeg_HW : Hollingsworth correction following + !! Arakawa (2001). The now horizontal kinetic energy is given by: + !! zhke = 1/6 [ mi-1( 2 * un^2 + ((u(j+1)+u(j-1))/2)^2 ) + !! + mj-1( 2 * vn^2 + ((v(i+1)+v(i-1))/2)^2 ) ] + !! + !! Take its horizontal gradient and add it to the general momentum + !! trend. + !! u(rhs) = u(rhs) - 1/e1u di[ zhke ] + !! v(rhs) = v(rhs) - 1/e2v dj[ zhke ] + !! + !! ** Action : - Update the (puu(:,:,:,Krhs), pvv(:,:,:,Krhs)) with the hor. ke gradient trend + !! - send this trends to trd_dyn (l_trddyn=T) for post-processing + !! + !! ** References : Arakawa, A., International Geophysics 2001. + !! Hollingsworth et al., Quart. J. Roy. Meteor. Soc., 1983. + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: kscheme ! =0/1 type of KEG scheme + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zu, zv ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zhke + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_keg') + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_keg : kinetic energy gradient trend, scheme number=', kscheme + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + ENDIF + + IF( l_trddyn ) THEN ! Save the input trends + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = puu(:,:,:,Krhs) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + + zhke(:,:,jpk) = 0._wp + + SELECT CASE ( kscheme ) !== Horizontal kinetic energy at T-point ==! + ! + CASE ( nkeg_C2 ) !-- Standard scheme --! + DO_3D( 0, 1, 0, 1, 1, jpkm1 ) + zu = puu(ji-1,jj ,jk,Kmm) * puu(ji-1,jj ,jk,Kmm) & + & + puu(ji ,jj ,jk,Kmm) * puu(ji ,jj ,jk,Kmm) + zv = pvv(ji ,jj-1,jk,Kmm) * pvv(ji ,jj-1,jk,Kmm) & + & + pvv(ji ,jj ,jk,Kmm) * pvv(ji ,jj ,jk,Kmm) + zhke(ji,jj,jk) = 0.25_wp * ( zv + zu ) + END_3D + CASE ( nkeg_HW ) !-- Hollingsworth scheme --! + DO_3D( 0, nn_hls-1, 0, nn_hls-1, 1, jpkm1 ) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zu = 8._wp * ( puu(ji-1,jj ,jk,Kmm) * puu(ji-1,jj ,jk,Kmm) & + & + puu(ji ,jj ,jk,Kmm) * puu(ji ,jj ,jk,Kmm) ) & + & + ( ( puu(ji-1,jj-1,jk,Kmm) + puu(ji-1,jj+1,jk,Kmm) ) * ( puu(ji-1,jj-1,jk,Kmm) + puu(ji-1,jj+1,jk,Kmm) ) & + & + ( puu(ji ,jj-1,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) ) * ( puu(ji ,jj-1,jk,Kmm) + puu(ji ,jj+1,jk,Kmm) ) & + & ) ! bracket for halo 1 - halo 2 compatibility + ! + zv = 8._wp * ( pvv(ji ,jj-1,jk,Kmm) * pvv(ji ,jj-1,jk,Kmm) & + & + pvv(ji ,jj ,jk,Kmm) * pvv(ji ,jj ,jk,Kmm) ) & + & + ( ( pvv(ji-1,jj-1,jk,Kmm) + pvv(ji+1,jj-1,jk,Kmm) ) * ( pvv(ji-1,jj-1,jk,Kmm) + pvv(ji+1,jj-1,jk,Kmm) ) & + & + ( pvv(ji-1,jj ,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) ) * ( pvv(ji-1,jj ,jk,Kmm) + pvv(ji+1,jj ,jk,Kmm) ) & + & ) ! bracket for halo 1 - halo 2 compatibility + zhke(ji,jj,jk) = r1_48 * ( zv + zu ) + END_3D + IF (nn_hls==1) CALL lbc_lnk( 'dynkeg', zhke, 'T', 1.0_wp ) + ! + END SELECT + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== grad( KE ) added to the general momentum trends ==! + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zhke(ji+1,jj ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zhke(ji ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj) + END_3D + ! + IF( l_trddyn ) THEN ! save the Kinetic Energy trends for diagnostic + ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_keg, kt, Kmm ) + DEALLOCATE( ztrdu , ztrdv ) + ENDIF + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' keg - Ua: ', mask1=umask, & + & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_keg') + ! + END SUBROUTINE dyn_keg + + !!====================================================================== +END MODULE dynkeg \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynldf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynldf.F90 new file mode 100644 index 0000000..e438e85 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynldf.F90 @@ -0,0 +1,116 @@ +MODULE dynldf + !!====================================================================== + !! *** MODULE dynldf *** + !! Ocean physics: lateral diffusivity trends + !!===================================================================== + !! History : 2.0 ! 2005-11 (G. Madec) Original code (new step architecture) + !! 3.7 ! 2014-01 (F. Lemarie, G. Madec) restructuration/simplification of ahm specification, + !! ! add velocity dependent coefficient and optional read in file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_ldf : update the dynamics trend with the lateral diffusion + !! dyn_ldf_init : initialization, namelist read, and parameters control + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE ldfdyn ! lateral diffusion: eddy viscosity coef. + USE dynldf_lap_blp ! lateral mixing (dyn_ldf_lap & dyn_ldf_blp routines) + USE dynldf_iso ! lateral mixing (dyn_ldf_iso routine ) + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics (trd_dyn routine) + ! + USE prtctl ! Print control + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_ldf ! called by step module + PUBLIC dyn_ldf_init ! called by opa module + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynldf.F90 12377 2020-02-12 14:39:06Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_ldf( kt, Kbb, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf *** + !! + !! ** Purpose : compute the lateral ocean dynamics physics. + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_ldf') + ! + IF( l_trddyn ) THEN ! temporary save of momentum trends + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = puu(:,:,:,Krhs) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + + SELECT CASE ( nldf_dyn ) ! compute lateral mixing trend and add it to the general trend + ! + CASE ( np_lap ) + CALL dyn_ldf_lap( kt, Kbb, Kmm, puu(:,:,:,Kbb), pvv(:,:,:,Kbb), puu(:,:,:,Krhs), pvv(:,:,:,Krhs), 1 ) ! iso-level laplacian + CASE ( np_lap_i ) + CALL dyn_ldf_iso( kt, Kbb, Kmm, puu, pvv, Krhs ) ! rotated laplacian + CASE ( np_blp ) + CALL dyn_ldf_blp( kt, Kbb, Kmm, puu(:,:,:,Kbb), pvv(:,:,:,Kbb), puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! iso-level bi-laplacian + ! + END SELECT + + IF( l_trddyn ) THEN ! save the horizontal diffusive trends for further diagnostics + ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_ldf, kt, Kmm ) + DEALLOCATE ( ztrdu , ztrdv ) + ENDIF + ! ! print sum trends (used for debugging) + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ldf - Ua: ', mask1=umask, & + & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_ldf') + ! + END SUBROUTINE dyn_ldf + + + SUBROUTINE dyn_ldf_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf_init *** + !! + !! ** Purpose : initializations of the horizontal ocean dynamics physics + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN !== Namelist print ==! + WRITE(numout,*) + WRITE(numout,*) 'dyn_ldf_init : Choice of the lateral diffusive operator on dynamics' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namdyn_ldf: already read in ldfdyn module' + WRITE(numout,*) ' see ldf_dyn_init report for lateral mixing parameters' + WRITE(numout,*) + ! + SELECT CASE( nldf_dyn ) ! print the choice of operator + CASE( np_no_ldf ) ; WRITE(numout,*) ' ==>>> NO lateral viscosity' + CASE( np_lap ) ; WRITE(numout,*) ' ==>>> iso-level laplacian operator' + CASE( np_lap_i ) ; WRITE(numout,*) ' ==>>> rotated laplacian operator with iso-level background' + CASE( np_blp ) ; WRITE(numout,*) ' ==>>> iso-level bi-laplacian operator' + END SELECT + ENDIF + ! + END SUBROUTINE dyn_ldf_init + + !!====================================================================== +END MODULE dynldf \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynldf_iso.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynldf_iso.F90 new file mode 100644 index 0000000..6263aa8 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynldf_iso.F90 @@ -0,0 +1,423 @@ +MODULE dynldf_iso + !!====================================================================== + !! *** MODULE dynldf_iso *** + !! Ocean dynamics: lateral viscosity trend (rotated laplacian operator) + !!====================================================================== + !! History : OPA ! 97-07 (G. Madec) Original code + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! - ! 2004-08 (C. Talandier) New trends organization + !! 2.0 ! 2005-11 (G. Madec) s-coordinate: horizontal diffusion + !! 3.7 ! 2014-01 (F. Lemarie, G. Madec) restructuration/simplification of ahm specification, + !! ! add velocity dependent coefficient and optional read in file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_ldf_iso : update the momentum trend with the horizontal part + !! of the lateral diffusion using isopycnal or horizon- + !! tal s-coordinate laplacian operator. + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE ldfdyn ! lateral diffusion: eddy viscosity coef. + USE ldftra ! lateral physics: eddy diffusivity + USE zdf_oce ! ocean vertical physics + USE ldfslp ! iso-neutral slopes + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control +#if defined key_loop_fusion + USE dynldf_iso_lf, ONLY: dyn_ldf_iso_lf ! lateral mixing - loop fusion version (dyn_ldf_iso routine ) +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_ldf_iso ! called by step.F90 + PUBLIC dyn_ldf_iso_alloc ! called by nemogcm.F90 + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akzu, akzv !: vertical component of rotated lateral viscosity + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynldf_iso.F90 15094 2021-07-06 16:24:19Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION dyn_ldf_iso_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf_iso_alloc *** + !!---------------------------------------------------------------------- + dyn_ldf_iso_alloc = 0 + IF( .NOT. ALLOCATED( akzu ) ) THEN + ALLOCATE( akzu(jpi,jpj,jpk), akzv(jpi,jpj,jpk), STAT=dyn_ldf_iso_alloc ) + ! + IF( dyn_ldf_iso_alloc /= 0 ) CALL ctl_warn('dyn_ldf_iso_alloc: array allocate failed.') + ENDIF + END FUNCTION dyn_ldf_iso_alloc + + + SUBROUTINE dyn_ldf_iso( kt, Kbb, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf_iso *** + !! + !! ** Purpose : Compute the before trend of the rotated laplacian + !! operator of lateral momentum diffusion except the diagonal + !! vertical term that will be computed in dynzdf module. Add it + !! to the general trend of momentum equation. + !! + !! ** Method : + !! The momentum lateral diffusive trend is provided by a 2nd + !! order operator rotated along neutral or geopotential surfaces + !! (in s-coordinates). + !! It is computed using before fields (forward in time) and isopyc- + !! nal or geopotential slopes computed in routine ldfslp. + !! Here, u and v components are considered as 2 independent scalar + !! fields. Therefore, the property of splitting divergent and rota- + !! tional part of the flow of the standard, z-coordinate laplacian + !! momentum diffusion is lost. + !! horizontal fluxes associated with the rotated lateral mixing: + !! u-component: + !! ziut = ( ahmt + rn_ahm_b ) e2t * e3t / e1t di[ uu ] + !! - ahmt e2t * mi-1(uslp) dk[ mi(mk(uu)) ] + !! zjuf = ( ahmf + rn_ahm_b ) e1f * e3f / e2f dj[ uu ] + !! - ahmf e1f * mi(vslp) dk[ mj(mk(uu)) ] + !! v-component: + !! zivf = ( ahmf + rn_ahm_b ) e2t * e3t / e1t di[ vv ] + !! - ahmf e2t * mj(uslp) dk[ mi(mk(vv)) ] + !! zjvt = ( ahmt + rn_ahm_b ) e1f * e3f / e2f dj[ vv ] + !! - ahmt e1f * mj-1(vslp) dk[ mj(mk(vv)) ] + !! take the horizontal divergence of the fluxes: + !! diffu = 1/(e1u*e2u*e3u) { di [ ziut ] + dj-1[ zjuf ] } + !! diffv = 1/(e1v*e2v*e3v) { di-1[ zivf ] + dj [ zjvt ] } + !! Add this trend to the general trend (uu(rhs),vv(rhs)): + !! uu(rhs) = uu(rhs) + diffu + !! CAUTION: here the isopycnal part is with a coeff. of aht. This + !! should be modified for applications others than orca_r2 (!!bug) + !! + !! ** Action : + !! -(puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) updated with the before geopotential harmonic mixing trend + !! -(akzu,akzv) to accompt for the diagonal vertical component + !! of the rotated operator in dynzdf module + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zabe1, zmskt, zmkt, zuav, zuwslpi, zuwslpj ! local scalars + REAL(wp) :: zabe2, zmskf, zmkf, zvav, zvwslpi, zvwslpj ! - - + REAL(wp) :: zcof0, zcof1, zcof2, zcof3, zcof4, zaht_0 ! - - + REAL(wp), DIMENSION(A2D(nn_hls)) :: ziut, zivf, zdku, zdk1u ! 2D workspace + REAL(wp), DIMENSION(A2D(nn_hls)) :: zjuf, zjvt, zdkv, zdk1v ! - - + REAL(wp), DIMENSION(A1Di(nn_hls),jpk) :: zfuw, zdiu, zdju, zdj1u ! - - + REAL(wp), DIMENSION(A1Di(nn_hls),jpk) :: zfvw, zdiv, zdjv, zdj1v ! - - + !!---------------------------------------------------------------------- + ! +#if defined key_loop_fusion + CALL dyn_ldf_iso_lf( kt, Kbb, Kmm, puu, pvv, Krhs ) +#else + + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_ldf_iso : iso-neutral laplacian diffusive operator or ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ s-coordinate horizontal diffusive operator' + ! ! allocate dyn_ldf_iso arrays + IF( dyn_ldf_iso_alloc() /= 0 ) CALL ctl_stop('STOP', 'dyn_ldf_iso: failed to allocate arrays') + ! + DO_2D_OVR( 0, 0, 0, 0 ) + akzu(ji,jj,1) = 0._wp + akzu(ji,jj,jpk) = 0._wp + akzv(ji,jj,1) = 0._wp + akzv(ji,jj,jpk) = 0._wp + END_2D + ! + ENDIF + ENDIF + +!!gm bug is dyn_ldf_iso called before tra_ldf_iso .... <<<<<===== TO BE CHECKED + ! s-coordinate: Iso-level diffusion on momentum but not on tracer + IF( ln_dynldf_hor .AND. ln_traldf_iso ) THEN + ! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) ! set the slopes of iso-level + uslp (ji,jj,jk) = - ( gdept(ji+1,jj,jk,Kbb) - gdept(ji ,jj ,jk,Kbb) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) + vslp (ji,jj,jk) = - ( gdept(ji,jj+1,jk,Kbb) - gdept(ji ,jj ,jk,Kbb) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) + wslpi(ji,jj,jk) = - ( gdepw(ji+1,jj,jk,Kbb) - gdepw(ji-1,jj,jk,Kbb) ) * r1_e1t(ji,jj) * tmask(ji,jj,jk) * 0.5 + wslpj(ji,jj,jk) = - ( gdepw(ji,jj+1,jk,Kbb) - gdepw(ji,jj-1,jk,Kbb) ) * r1_e2t(ji,jj) * tmask(ji,jj,jk) * 0.5 + END_3D + ! Lateral boundary conditions on the slopes + IF (nn_hls == 1) CALL lbc_lnk( 'dynldf_iso', uslp , 'U', -1.0_wp, vslp , 'V', -1.0_wp, wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) + ! + ENDIF + + zaht_0 = 0.5_wp * rn_Ud * rn_Ld ! aht_0 from namtra_ldf = zaht_max + + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + + ! Vertical u- and v-shears at level jk and jk+1 + ! --------------------------------------------- + ! surface boundary condition: zdku(jk=1)=zdku(jk=2) + ! zdkv(jk=1)=zdkv(jk=2) + + DO_2D( 1, 1, 1, 1 ) + zdk1u(ji,jj) = ( puu(ji,jj,jk,Kbb) -puu(ji,jj,jk+1,Kbb) ) * umask(ji,jj,jk+1) + zdk1v(ji,jj) = ( pvv(ji,jj,jk,Kbb) -pvv(ji,jj,jk+1,Kbb) ) * vmask(ji,jj,jk+1) + END_2D + + IF( jk == 1 ) THEN + zdku(:,:) = zdk1u(:,:) + zdkv(:,:) = zdk1v(:,:) + ELSE + DO_2D( 1, 1, 1, 1 ) + zdku(ji,jj) = ( puu(ji,jj,jk-1,Kbb) - puu(ji,jj,jk,Kbb) ) * umask(ji,jj,jk) + zdkv(ji,jj) = ( pvv(ji,jj,jk-1,Kbb) - pvv(ji,jj,jk,Kbb) ) * vmask(ji,jj,jk) + END_2D + ENDIF + + ! -----f----- + ! Horizontal fluxes on U | + ! --------------------=== t u t + ! | + ! i-flux at t-point -----f----- + + IF( ln_zps ) THEN ! z-coordinate - partial steps : min(e3u) + DO_2D( 0, 1, 0, 0 ) + zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) & + & * MIN( e3u(ji ,jj,jk,Kmm), & + & e3u(ji-1,jj,jk,Kmm) ) * r1_e1t(ji,jj) + + zmskt = 1._wp / MAX( umask(ji-1,jj,jk )+umask(ji,jj,jk+1) & + & + umask(ji-1,jj,jk+1)+umask(ji,jj,jk ) , 1._wp ) + + zcof1 = - zaht_0 * e2t(ji,jj) * zmskt * 0.5 * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) ) + + ziut(ji,jj) = ( zabe1 * ( puu(ji,jj,jk,Kbb) - puu(ji-1,jj,jk,Kbb) ) & + & + zcof1 * ( zdku (ji,jj) + zdk1u(ji-1,jj) & + & +zdk1u(ji,jj) + zdku (ji-1,jj) ) ) * tmask(ji,jj,jk) + END_2D + ELSE ! other coordinate system (zco or sco) : e3t + DO_2D( 0, 1, 0, 0 ) + zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) & + & * e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e1t(ji,jj) + + zmskt = 1._wp / MAX( umask(ji-1,jj,jk ) + umask(ji,jj,jk+1) & + & + umask(ji-1,jj,jk+1) + umask(ji,jj,jk ) , 1._wp ) + + zcof1 = - zaht_0 * e2t(ji,jj) * zmskt * 0.5 * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) ) + + ziut(ji,jj) = ( zabe1 * ( puu(ji,jj,jk,Kbb) - puu(ji-1,jj,jk,Kbb) ) & + & + zcof1 * ( zdku (ji,jj) + zdk1u(ji-1,jj) & + & +zdk1u(ji,jj) + zdku (ji-1,jj) ) ) * tmask(ji,jj,jk) + END_2D + ENDIF + + ! j-flux at f-point + DO_2D( 1, 0, 1, 0 ) + zabe2 = ( ahmf(ji,jj,jk) + rn_ahm_b ) & + & * e1f(ji,jj) * e3f(ji,jj,jk) * r1_e2f(ji,jj) + + zmskf = 1._wp / MAX( umask(ji,jj+1,jk )+umask(ji,jj,jk+1) & + & + umask(ji,jj+1,jk+1)+umask(ji,jj,jk ) , 1._wp ) + + zcof2 = - zaht_0 * e1f(ji,jj) * zmskf * 0.5 * ( vslp(ji+1,jj,jk) + vslp(ji,jj,jk) ) + + zjuf(ji,jj) = ( zabe2 * ( puu(ji,jj+1,jk,Kbb) - puu(ji,jj,jk,Kbb) ) & + & + zcof2 * ( zdku (ji,jj+1) + zdk1u(ji,jj) & + & +zdk1u(ji,jj+1) + zdku (ji,jj) ) ) * fmask(ji,jj,jk) + END_2D + + ! | t | + ! Horizontal fluxes on V | | + ! --------------------=== f---v---f + ! | | + ! i-flux at f-point | t | + + DO_2D( 1, 0, 0, 0 ) + zabe1 = ( ahmf(ji,jj,jk) + rn_ahm_b ) & + & * e2f(ji,jj) * e3f(ji,jj,jk) * r1_e1f(ji,jj) + + zmskf = 1._wp / MAX( vmask(ji+1,jj,jk )+vmask(ji,jj,jk+1) & + & + vmask(ji+1,jj,jk+1)+vmask(ji,jj,jk ) , 1._wp ) + + zcof1 = - zaht_0 * e2f(ji,jj) * zmskf * 0.5 * ( uslp(ji,jj+1,jk) + uslp(ji,jj,jk) ) + + zivf(ji,jj) = ( zabe1 * ( pvv(ji+1,jj,jk,Kbb) - pvv(ji,jj,jk,Kbb) ) & + & + zcof1 * ( zdkv (ji,jj) + zdk1v(ji+1,jj) & + & + zdk1v(ji,jj) + zdkv (ji+1,jj) ) ) * fmask(ji,jj,jk) + END_2D + + ! j-flux at t-point + IF( ln_zps ) THEN ! z-coordinate - partial steps : min(e3u) + DO_2D( 1, 0, 0, 1 ) + zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) & + & * MIN( e3v(ji,jj ,jk,Kmm), & + & e3v(ji,jj-1,jk,Kmm) ) * r1_e2t(ji,jj) + + zmskt = 1._wp / MAX( vmask(ji,jj-1,jk )+vmask(ji,jj,jk+1) & + & + vmask(ji,jj-1,jk+1)+vmask(ji,jj,jk ) , 1._wp ) + + zcof2 = - zaht_0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) ) + + zjvt(ji,jj) = ( zabe2 * ( pvv(ji,jj,jk,Kbb) - pvv(ji,jj-1,jk,Kbb) ) & + & + zcof2 * ( zdkv (ji,jj-1) + zdk1v(ji,jj) & + & +zdk1v(ji,jj-1) + zdkv (ji,jj) ) ) * tmask(ji,jj,jk) + END_2D + ELSE ! other coordinate system (zco or sco) : e3t + DO_2D( 1, 0, 0, 1 ) + zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) & + & * e1t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e2t(ji,jj) + + zmskt = 1./MAX( vmask(ji,jj-1,jk )+vmask(ji,jj,jk+1) & + & + vmask(ji,jj-1,jk+1)+vmask(ji,jj,jk ), 1. ) + + zcof2 = - zaht_0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) ) + + zjvt(ji,jj) = ( zabe2 * ( pvv(ji,jj,jk,Kbb) - pvv(ji,jj-1,jk,Kbb) ) & + & + zcof2 * ( zdkv (ji,jj-1) + zdk1v(ji,jj) & + & +zdk1v(ji,jj-1) + zdkv (ji,jj) ) ) * tmask(ji,jj,jk) + END_2D + ENDIF + + + ! Second derivative (divergence) and add to the general trend + ! ----------------------------------------------------------- + DO_2D( 0, 0, 0, 0 ) !!gm Question vectop possible??? !!bug + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( ziut(ji+1,jj) - ziut(ji,jj ) & + & + zjuf(ji ,jj) - zjuf(ji,jj-1) ) * r1_e1e2u(ji,jj) & + & / e3u(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + ( zivf(ji,jj ) - zivf(ji-1,jj) & + & + zjvt(ji,jj+1) - zjvt(ji,jj ) ) * r1_e1e2v(ji,jj) & + & / e3v(ji,jj,jk,Kmm) + END_2D + ! ! =============== + END DO ! End of slab + ! ! =============== + + ! print sum trends (used for debugging) + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ldfh - Ua: ', mask1=umask, & + & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + + + ! ! =============== + DO jj = ntsj, ntej ! Vertical slab + ! ! =============== + + + ! I. vertical trends associated with the lateral mixing + ! ===================================================== + ! (excluding the vertical flux proportional to dk[t] + + + ! I.1 horizontal momentum gradient + ! -------------------------------- + + DO jk = 1, jpk + DO ji = ntsi, ntei + nn_hls + ! i-gradient of u at jj + zdiu (ji,jk) = tmask(ji,jj ,jk) * ( puu(ji,jj ,jk,Kbb) - puu(ji-1,jj ,jk,Kbb) ) + ! j-gradient of u and v at jj + zdju (ji,jk) = fmask(ji,jj ,jk) * ( puu(ji,jj+1,jk,Kbb) - puu(ji ,jj ,jk,Kbb) ) + zdjv (ji,jk) = tmask(ji,jj ,jk) * ( pvv(ji,jj ,jk,Kbb) - pvv(ji ,jj-1,jk,Kbb) ) + ! j-gradient of u and v at jj+1 + zdj1u(ji,jk) = fmask(ji,jj-1,jk) * ( puu(ji,jj ,jk,Kbb) - puu(ji ,jj-1,jk,Kbb) ) + zdj1v(ji,jk) = tmask(ji,jj+1,jk) * ( pvv(ji,jj+1,jk,Kbb) - pvv(ji ,jj ,jk,Kbb) ) + END DO + END DO + DO jk = 1, jpk + DO ji = ntsi - nn_hls, ntei + ! i-gradient of v at jj + zdiv (ji,jk) = fmask(ji,jj ,jk) * ( pvv(ji+1,jj,jk,Kbb) - pvv(ji ,jj ,jk,Kbb) ) + END DO + END DO + + + ! I.2 Vertical fluxes + ! ------------------- + + ! Surface and bottom vertical fluxes set to zero + DO ji = ntsi - nn_hls, ntei + nn_hls + zfuw(ji, 1 ) = 0.e0 + zfvw(ji, 1 ) = 0.e0 + zfuw(ji,jpk) = 0.e0 + zfvw(ji,jpk) = 0.e0 + END DO + + ! interior (2=0) + ENDIF + ! + SELECT CASE( nn_dynldf_typ ) + ! + CASE ( np_typ_rot ) !== Vorticity-Divergence operator ==! + ! + ALLOCATE( zcur(A2D(nn_hls)) , zdiv(A2D(nn_hls)) ) + ! + DO jk = 1, jpkm1 ! Horizontal slab + ! + DO_2D( iij-1, iij, iij-1, iij ) + ! ! ahm * e3 * curl (warning: computed for ji-1,jj-1) + zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1) & ! ahmf already * by fmask + & * ( e2v(ji ,jj-1) * pv(ji ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk) & + & - e1u(ji-1,jj ) * pu(ji-1,jj ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk) ) + ! ! ahm * div (warning: computed for ji,jj) + zdiv(ji,jj) = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb) & ! ahmt already * by tmask + & * ( e2u(ji,jj)*e3u(ji,jj,jk,Kbb) * pu(ji,jj,jk) - e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb) * pu(ji-1,jj,jk) & + & + e1v(ji,jj)*e3v(ji,jj,jk,Kbb) * pv(ji,jj,jk) - e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kbb) * pv(ji,jj-1,jk) ) + END_2D + ! + DO_2D( iij-1, iij-1, iij-1, iij-1 ) ! - curl( curl) + grad( div ) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * ( & ! * by umask is mandatory for dyn_ldf_blp use + & - ( zcur(ji ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & + & + ( zdiv(ji+1,jj) - zdiv(ji,jj ) ) * r1_e1u(ji,jj) ) + ! + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * vmask(ji,jj,jk) * ( & ! * by vmask is mandatory for dyn_ldf_blp use + & ( zcur(ji,jj ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm) & + & + ( zdiv(ji,jj+1) - zdiv(ji ,jj) ) * r1_e2v(ji,jj) ) + END_2D + ! + END DO ! End of slab + ! + DEALLOCATE( zcur , zdiv ) + ! + CASE ( np_typ_sym ) !== Symmetric operator ==! + ! + ALLOCATE( zten(A2D(nn_hls)) , zshe(A2D(nn_hls)) ) + ! + DO jk = 1, jpkm1 ! Horizontal slab + ! + DO_2D( iij-1, iij, iij-1, iij ) + ! ! shearing stress component (F-point) NB : ahmf has already been multiplied by fmask + zshe(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) & + & * ( e1f(ji-1,jj-1) * r1_e2f(ji-1,jj-1) & + & * ( pu(ji-1,jj ,jk) * r1_e1u(ji-1,jj ) - pu(ji-1,jj-1,jk) * r1_e1u(ji-1,jj-1) ) & + & + e2f(ji-1,jj-1) * r1_e1f(ji-1,jj-1) & + & * ( pv(ji ,jj-1,jk) * r1_e2v(ji ,jj-1) - pv(ji-1,jj-1,jk) * r1_e2v(ji-1,jj-1) ) ) + ! ! tension stress component (T-point) NB : ahmt has already been multiplied by tmask + zten(ji,jj) = ahmt(ji,jj,jk) & + & * ( e2t(ji,jj) * r1_e1t(ji,jj) & + & * ( pu(ji,jj,jk) * r1_e2u(ji,jj) - pu(ji-1,jj,jk) * r1_e2u(ji-1,jj) ) & + & - e1t(ji,jj) * r1_e2t(ji,jj) & + & * ( pv(ji,jj,jk) * r1_e1v(ji,jj) - pv(ji,jj-1,jk) * r1_e1v(ji,jj-1) ) ) + END_2D + ! + DO_2D( iij-1, iij-1, iij-1, iij-1 ) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & + & * ( ( zten(ji+1,jj ) * e2t(ji+1,jj )*e2t(ji+1,jj ) * e3t(ji+1,jj ,jk,Kmm) & + & - zten(ji ,jj ) * e2t(ji ,jj )*e2t(ji ,jj ) * e3t(ji ,jj ,jk,Kmm) ) * r1_e2u(ji,jj) & + & + ( zshe(ji ,jj ) * e1f(ji ,jj )*e1f(ji ,jj ) * e3f(ji ,jj ,jk) & + & - zshe(ji ,jj-1) * e1f(ji ,jj-1)*e1f(ji ,jj-1) * e3f(ji ,jj-1,jk) ) * r1_e1u(ji,jj) ) + ! + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) & + & * ( ( zshe(ji ,jj ) * e2f(ji ,jj )*e2f(ji ,jj ) * e3f(ji ,jj ,jk) & + & - zshe(ji-1,jj ) * e2f(ji-1,jj )*e2f(ji-1,jj ) * e3f(ji-1,jj ,jk) ) * r1_e2v(ji,jj) & + & - ( zten(ji ,jj+1) * e1t(ji ,jj+1)*e1t(ji ,jj+1) * e3t(ji ,jj+1,jk,Kmm) & + & - zten(ji ,jj ) * e1t(ji ,jj )*e1t(ji ,jj ) * e3t(ji ,jj ,jk,Kmm) ) * r1_e1v(ji,jj) ) + ! + END_2D + ! + END DO + ! + DEALLOCATE( zten , zshe ) + ! + END SELECT + ! + END SUBROUTINE dyn_ldf_lap_t + + + SUBROUTINE dyn_ldf_blp( kt, Kbb, Kmm, pu, pv, pu_rhs, pv_rhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf_blp *** + !! + !! ** Purpose : Compute the before lateral momentum viscous trend + !! and add it to the general trend of momentum equation. + !! + !! ** Method : The lateral viscous trends is provided by a bilaplacian + !! operator applied to before field (forward in time). + !! It is computed by two successive calls to dyn_ldf_lap routine + !! + !! ** Action : pt(:,:,:,:,Krhs) updated with the before rotated bilaplacian diffusion + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu, pv ! before velocity fields + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! momentum trend + ! + REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zulap, zvlap ! laplacian at u- and v-point + !!---------------------------------------------------------------------- + ! +#if defined key_loop_fusion + CALL dyn_ldf_blp_lf( kt, Kbb, Kmm, pu, pv, pu_rhs, pv_rhs ) +#else + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_ldf_blp : bilaplacian operator momentum ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ENDIF + ! + zulap(:,:,:) = 0._wp + zvlap(:,:,:) = 0._wp + ! + CALL dyn_ldf_lap( kt, Kbb, Kmm, pu, pv, zulap, zvlap, 1 ) ! rotated laplacian applied to pt (output in zlap,Kbb) + ! + IF (nn_hls==1) CALL lbc_lnk( 'dynldf_lap_blp', zulap, 'U', -1.0_dp, zvlap, 'V', -1.0_dp ) ! Lateral boundary conditions + ! + CALL dyn_ldf_lap( kt, Kbb, Kmm, zulap, zvlap, pu_rhs, pv_rhs, 2 ) ! rotated laplacian applied to zlap (output in pt(:,:,:,:,Krhs)) + ! +#endif + END SUBROUTINE dyn_ldf_blp + + !!====================================================================== +END MODULE dynldf_lap_blp diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynldf_lap_blp_lf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynldf_lap_blp_lf.F90 new file mode 100644 index 0000000..a7be529 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynldf_lap_blp_lf.F90 @@ -0,0 +1,225 @@ +MODULE dynldf_lap_blp_lf + !!====================================================================== + !! *** MODULE dynldf_lap_blp *** + !! Ocean dynamics: lateral viscosity trend (laplacian and bilaplacian) + !!====================================================================== + !! History : 3.7 ! 2014-01 (G. Madec, S. Masson) Original code, re-entrant laplacian + !! 4.0 ! 2020-04 (A. Nasser, G. Madec) Add symmetric mixing tensor + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_ldf_lap : update the momentum trend with the lateral viscosity using an iso-level laplacian operator + !! dyn_ldf_blp : update the momentum trend with the lateral viscosity using an iso-level bilaplacian operator + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE domutl, ONLY : is_tile + USE ldfdyn ! lateral diffusion: eddy viscosity coef. + USE ldfslp ! iso-neutral slopes + USE zdf_oce ! ocean vertical physics + ! + USE in_out_manager ! I/O manager + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_ldf_lap_lf ! called by dynldf.F90 + PUBLIC dyn_ldf_blp_lf ! called by dynldf.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynldf_lap_blp.F90 14757 2021-04-27 15:33:44Z francesca $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_ldf_lap_lf( kt, Kbb, Kmm, pu, pv, pu_rhs, pv_rhs, kpass ) + !! + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pu, pv ! before velocity [m/s] + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pu_rhs, pv_rhs ! velocity trend [m/s2] + !! + CALL dyn_ldf_lap_lf_t( kt, Kbb, Kmm, pu, pv, is_tile(pu), pu_rhs, pv_rhs, is_tile(pu_rhs), kpass ) + + END SUBROUTINE dyn_ldf_lap_lf + + SUBROUTINE dyn_ldf_lap_lf_t( kt, Kbb, Kmm, pu, pv, ktuv, pu_rhs, pv_rhs, ktuv_rhs, kpass ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf_lap *** + !! + !! ** Purpose : Compute the before horizontal momentum diffusive + !! trend and add it to the general trend of momentum equation. + !! + !! ** Method : The Laplacian operator apply on horizontal velocity is + !! writen as : grad_h( ahmt div_h(U )) - curl_h( ahmf curl_z(U) ) + !! + !! ** Action : - pu_rhs, pv_rhs increased by the harmonic operator applied on pu, pv. + !! + !! Reference : S.Griffies, R.Hallberg 2000 Mon.Wea.Rev., DOI:/ + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage + INTEGER , INTENT(in ) :: ktuv, ktuv_rhs + REAL(wp), DIMENSION(A2D_T(ktuv) ,JPK), INTENT(in ) :: pu, pv ! before velocity [m/s] + REAL(wp), DIMENSION(A2D_T(ktuv_rhs),JPK), INTENT(inout) :: pu_rhs, pv_rhs ! velocity trend [m/s2] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iij + REAL(wp) :: zsign ! local scalars + REAL(wp) :: zcur, zcur_im1, zcur_jm1 ! local scalars + REAL(wp) :: zdiv, zdiv_ip1, zdiv_jp1 ! local scalars + REAL(wp) :: zten, zten_ip1, zten_jp1, zshe, zshe_im1, zshe_jm1 ! tension (diagonal) and shearing (anti-diagonal) terms + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_ldf_lf : iso-level harmonic (laplacian) operator, pass=', kpass + WRITE(numout,*) '~~~~~~~ ' + ENDIF + ENDIF + ! + ! Define pu_rhs/pv_rhs halo points for multi-point haloes in bilaplacian case + IF( nldf_dyn == np_blp .AND. kpass == 1 ) THEN ; iij = nn_hls + ELSE ; iij = 1 + ENDIF + ! + IF( kpass == 1 ) THEN ; zsign = 1._wp ! bilaplacian operator require a minus sign + ELSE ; zsign = -1._wp ! (eddy viscosity coef. >0) + ENDIF + ! + SELECT CASE( nn_dynldf_typ ) + ! + CASE ( np_typ_rot ) !== Vorticity-Divergence operator ==! + ! + DO_3D( iij-1, iij-1, iij-1, iij-1, 1, jpkm1 ) ! Horizontal slab + ! ! ahm * e3 * curl (warning: computed for ji-1,jj-1) + zcur = ahmf(ji ,jj ,jk) * e3f(ji ,jj ,jk) * r1_e1e2f(ji ,jj ) & ! ahmf already * by fmask + & * ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) + zcur_jm1 = ahmf(ji ,jj-1,jk) * e3f(ji ,jj-1,jk) * r1_e1e2f(ji ,jj-1) & ! ahmf already * by fmask + & * ( e2v(ji+1,jj-1) * pv(ji+1,jj-1,jk) - e2v(ji,jj-1) * pv(ji,jj-1,jk) & + & - e1u(ji ,jj ) * pu(ji ,jj ,jk) + e1u(ji,jj-1) * pu(ji,jj-1,jk) ) + zcur_im1 = ahmf(ji-1,jj ,jk) * e3f(ji-1,jj ,jk) * r1_e1e2f(ji-1,jj ) & ! ahmf already * by fmask + & * ( e2v(ji ,jj ) * pv(ji ,jj ,jk) - e2v(ji-1,jj) * pv(ji-1,jj,jk) & + & - e1u(ji-1,jj+1) * pu(ji-1,jj+1,jk) + e1u(ji-1,jj) * pu(ji-1,jj,jk) ) + ! ! ahm * div (warning: computed for ji,jj) + zdiv = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb) & ! ahmt already * by tmask + & * ( e2u(ji,jj)*e3u(ji,jj,jk,Kbb) * pu(ji,jj,jk) - e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb) * pu(ji-1,jj,jk) & + & + e1v(ji,jj)*e3v(ji,jj,jk,Kbb) * pv(ji,jj,jk) - e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kbb) * pv(ji,jj-1,jk) ) + zdiv_ip1 = ahmt(ji+1,jj,jk) * r1_e1e2t(ji+1,jj) / e3t(ji+1,jj,jk,Kbb) & ! ahmt already * by tmask + & * ( e2u(ji+1,jj)*e3u(ji+1,jj,jk,Kbb) * pu(ji+1,jj,jk) - e2u(ji,jj)*e3u(ji,jj,jk,Kbb) * pu(ji,jj,jk) & + & + e1v(ji+1,jj)*e3v(ji+1,jj,jk,Kbb) * pv(ji+1,jj,jk) - e1v(ji+1,jj-1)*e3v(ji+1,jj-1,jk,Kbb) * pv(ji+1,jj-1,jk) ) + zdiv_jp1 = ahmt(ji,jj+1,jk) * r1_e1e2t(ji,jj+1) / e3t(ji,jj+1,jk,Kbb) & ! ahmt already * by tmask + & * ( e2u(ji,jj+1)*e3u(ji,jj+1,jk,Kbb) * pu(ji,jj+1,jk) - e2u(ji-1,jj+1)*e3u(ji-1,jj+1,jk,Kbb) * pu(ji-1,jj+1,jk) & + & + e1v(ji,jj+1)*e3v(ji,jj+1,jk,Kbb) * pv(ji,jj+1,jk) - e1v(ji,jj)*e3v(ji,jj,jk,Kbb) * pv(ji,jj,jk) ) + ! ! - curl( curl) + grad( div ) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * ( & ! * by umask is mandatory for dyn_ldf_blp use + & - ( zcur - zcur_jm1 ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & + & + ( zdiv_ip1 - zdiv ) * r1_e1u(ji,jj) ) + ! + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * vmask(ji,jj,jk) * ( & ! * by vmask is mandatory for dyn_ldf_blp use + & ( zcur - zcur_im1 ) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm) & + & + ( zdiv_jp1 - zdiv ) * r1_e2v(ji,jj) ) + END_3D ! End of slab + ! + CASE ( np_typ_sym ) !== Symmetric operator ==! + ! + DO_3D( iij-1, iij-1, iij-1, iij-1, 1, jpkm1 ) ! Horizontal slab + ! ! shearing stress component (F-point) NB : ahmf has already been multiplied by fmask + zshe = ahmf(ji,jj,jk) & + & * ( e1f(ji,jj) * r1_e2f(ji,jj) & + & * ( pu(ji,jj+1,jk) * r1_e1u(ji,jj+1) - pu(ji,jj,jk) * r1_e1u(ji,jj) ) & + & + e2f(ji,jj) * r1_e1f(ji,jj) & + & * ( pv(ji+1,jj,jk) * r1_e2v(ji+1,jj) - pv(ji,jj,jk) * r1_e2v(ji,jj) ) ) + zshe_im1 = ahmf(ji-1,jj,jk) & + & * ( e1f(ji-1,jj) * r1_e2f(ji-1,jj) & + & * ( pu(ji-1,jj+1,jk) * r1_e1u(ji-1,jj+1) - pu(ji-1,jj,jk) * r1_e1u(ji-1,jj) ) & + & + e2f(ji-1,jj) * r1_e1f(ji-1,jj) & + & * ( pv(ji ,jj,jk) * r1_e2v(ji ,jj) - pv(ji-1,jj,jk) * r1_e2v(ji-1,jj) ) ) + zshe_jm1 = ahmf(ji,jj-1,jk) & + & * ( e1f(ji,jj-1) * r1_e2f(ji,jj-1) & + & * ( pu(ji,jj,jk) * r1_e1u(ji,jj) - pu(ji,jj-1,jk) * r1_e1u(ji,jj-1) ) & + & + e2f(ji,jj-1) * r1_e1f(ji,jj-1) & + & * ( pv(ji+1,jj-1,jk) * r1_e2v(ji+1,jj-1) - pv(ji,jj-1,jk) * r1_e2v(ji,jj-1) ) ) + ! ! tension stress component (T-point) NB : ahmt has already been multiplied by tmask + zten = ahmt(ji,jj,jk) & + & * ( e2t(ji,jj) * r1_e1t(ji,jj) & + & * ( pu(ji,jj,jk) * r1_e2u(ji,jj) - pu(ji-1,jj,jk) * r1_e2u(ji-1,jj) ) & + & - e1t(ji,jj) * r1_e2t(ji,jj) & + & * ( pv(ji,jj,jk) * r1_e1v(ji,jj) - pv(ji,jj-1,jk) * r1_e1v(ji,jj-1) ) ) + zten_ip1 = ahmt(ji+1,jj,jk) & + & * ( e2t(ji+1,jj) * r1_e1t(ji+1,jj) & + & * ( pu(ji+1,jj,jk) * r1_e2u(ji+1,jj) - pu(ji,jj,jk) * r1_e2u(ji,jj) ) & + & - e1t(ji+1,jj) * r1_e2t(ji+1,jj) & + & * ( pv(ji+1,jj,jk) * r1_e1v(ji+1,jj) - pv(ji+1,jj-1,jk) * r1_e1v(ji+1,jj-1) ) ) + zten_jp1 = ahmt(ji,jj+1,jk) & + & * ( e2t(ji,jj+1) * r1_e1t(ji,jj+1) & + & * ( pu(ji,jj+1,jk) * r1_e2u(ji,jj+1) - pu(ji-1,jj+1,jk) * r1_e2u(ji-1,jj+1) ) & + & - e1t(ji,jj+1) * r1_e2t(ji,jj+1) & + & * ( pv(ji,jj+1,jk) * r1_e1v(ji,jj+1) - pv(ji,jj,jk) * r1_e1v(ji,jj) ) ) + ! + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & + & * ( ( zten_ip1 * e2t(ji+1,jj )*e2t(ji+1,jj ) * e3t(ji+1,jj ,jk,Kmm) & + & - zten * e2t(ji ,jj )*e2t(ji ,jj ) * e3t(ji ,jj ,jk,Kmm) ) * r1_e2u(ji,jj) & + & + ( zshe * e1f(ji ,jj )*e1f(ji ,jj ) * e3f(ji ,jj ,jk) & + & - zshe_jm1 * e1f(ji ,jj-1)*e1f(ji ,jj-1) * e3f(ji ,jj-1,jk) ) * r1_e1u(ji,jj) ) + ! + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) & + & * ( ( zshe * e2f(ji ,jj )*e2f(ji ,jj ) * e3f(ji ,jj ,jk) & + & - zshe_im1 * e2f(ji-1,jj )*e2f(ji-1,jj ) * e3f(ji-1,jj ,jk) ) * r1_e2v(ji,jj) & + & - ( zten_jp1 * e1t(ji ,jj+1)*e1t(ji ,jj+1) * e3t(ji ,jj+1,jk,Kmm) & + & - zten * e1t(ji ,jj )*e1t(ji ,jj ) * e3t(ji ,jj ,jk,Kmm) ) * r1_e1v(ji,jj) ) + ! + END_3D + ! + END SELECT + ! + END SUBROUTINE dyn_ldf_lap_lf_t + + + SUBROUTINE dyn_ldf_blp_lf( kt, Kbb, Kmm, pu, pv, pu_rhs, pv_rhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf_blp *** + !! + !! ** Purpose : Compute the before lateral momentum viscous trend + !! and add it to the general trend of momentum equation. + !! + !! ** Method : The lateral viscous trends is provided by a bilaplacian + !! operator applied to before field (forward in time). + !! It is computed by two successive calls to dyn_ldf_lap routine + !! + !! ** Action : pt(:,:,:,:,Krhs) updated with the before rotated bilaplacian diffusion + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu, pv ! before velocity fields + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! momentum trend + ! + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zulap, zvlap ! laplacian at u- and v-point + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_ldf_blp_lf : bilaplacian operator momentum ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + zulap(:,:,:) = 0._wp + zvlap(:,:,:) = 0._wp + ! + CALL dyn_ldf_lap_lf( kt, Kbb, Kmm, pu, pv, zulap, zvlap, 1 ) ! rotated laplacian applied to pt (output in zlap,Kbb) + ! + CALL dyn_ldf_lap_lf( kt, Kbb, Kmm, zulap, zvlap, pu_rhs, pv_rhs, 2 ) ! rotated laplacian applied to zlap (output in pt(:,:,:,:,Krhs)) + ! + END SUBROUTINE dyn_ldf_blp_lf + + !!====================================================================== +END MODULE dynldf_lap_blp_lf \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynspg.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynspg.F90 new file mode 100644 index 0000000..0d1e916 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynspg.F90 @@ -0,0 +1,244 @@ +MODULE dynspg + !!====================================================================== + !! *** MODULE dynspg *** + !! Ocean dynamics: surface pressure gradient control + !!====================================================================== + !! History : 1.0 ! 2005-12 (C. Talandier, G. Madec, V. Garnier) Original code + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !! 4.2 ! 2020-12 (G. Madec, E. Clementi) add Bernoulli Head for + !! wave coupling + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_spg : update the dynamics trend with surface pressure gradient + !! dyn_spg_init: initialization, namelist read, and parameters control + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE c1d ! 1D vertical configuration + USE phycst ! physical constants + USE sbc_oce ! surface boundary condition: ocean + USE sbc_ice , ONLY : snwice_mass, snwice_mass_b + USE sbcapr ! surface boundary condition: atmospheric pressure + USE sbcwave, ONLY : bhd_wave + USE dynspg_exp ! surface pressure gradient (dyn_spg_exp routine) + USE dynspg_ts ! surface pressure gradient (dyn_spg_ts routine) + USE tide_mod ! + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + ! + USE prtctl ! Print control (prt_ctl routine) + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_spg ! routine called by step module + PUBLIC dyn_spg_init ! routine called by opa module + + INTEGER :: nspg = 0 ! type of surface pressure gradient scheme defined from lk_dynspg_... + + ! ! Parameter to control the surface pressure gradient scheme + INTEGER, PARAMETER :: np_TS = 1 ! split-explicit time stepping (Time-Splitting) + INTEGER, PARAMETER :: np_EXP = 0 ! explicit time stepping + INTEGER, PARAMETER :: np_NO =-1 ! no surface pressure gradient, no scheme + ! + REAL(wp) :: zt0step ! Time of day at the beginning of the time step + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynspg.F90 14225 2020-12-19 14:58:39Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_spg( kt, Kbb, Kmm, Krhs, puu, pvv, pssh, puu_b, pvv_b, Kaa, k_only_ADV ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_spg *** + !! + !! ** Purpose : compute surface pressure gradient including the + !! atmospheric pressure forcing (ln_apr_dyn=T). + !! + !! ** Method : Two schemes: + !! - explicit : the spg is evaluated at now + !! - split-explicit : a time splitting technique is used + !! + !! ln_apr_dyn=T : the atmospheric pressure forcing is applied + !! as the gradient of the inverse barometer ssh: + !! apgu = - 1/rho0 di[apr] = 0.5*grav di[ssh_ib+ssh_ibb] + !! apgv = - 1/rho0 dj[apr] = 0.5*grav dj[ssh_ib+ssh_ibb] + !! Note that as all external forcing a time averaging over a two rn_Dt + !! period is used to prevent the divergence of odd and even time step. + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs, Kaa ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + REAL(wp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: puu_b, pvv_b! SSH and barotropic velocities at main time levels + REAL(dp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: pssh! SSH and barotropic velocities at main time levels + INTEGER , OPTIONAL , INTENT( in ) :: k_only_ADV ! only Advection in the RHS + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: z2dt, zg_2, zintp, zgrho0r, zld ! local scalars + REAL(wp) , DIMENSION(jpi,jpj) :: zpgu, zpgv ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zpice + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_spg') + ! + IF( l_trddyn ) THEN ! temporary save of ta and sa trends + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = puu(:,:,:,Krhs) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + ! + IF( ln_apr_dyn & ! atmos. pressure + .OR. ( .NOT.ln_dynspg_ts .AND. (ln_tide_pot .AND. ln_tide) ) & ! tide potential (no time slitting) + .OR. ln_ice_embd & ! embedded sea-ice + .OR. ( ln_wave .and. ln_bern_srfc ) ) THEN ! depth-independent Bernoulli head + ! + DO_2D( 0, 0, 0, 0 ) + zpgu(ji,jj) = 0._wp + zpgv(ji,jj) = 0._wp + END_2D + ! + IF( ln_apr_dyn .AND. .NOT.ln_dynspg_ts ) THEN !== Atmospheric pressure gradient (added later in time-split case) ==! + zg_2 = grav * 0.5 + DO_2D( 0, 0, 0, 0 ) ! gradient of Patm using inverse barometer ssh + zpgu(ji,jj) = zpgu(ji,jj) + zg_2 * ( ssh_ib (ji+1,jj) - ssh_ib (ji,jj) & + & + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj) + zpgv(ji,jj) = zpgv(ji,jj) + zg_2 * ( ssh_ib (ji,jj+1) - ssh_ib (ji,jj) & + & + ssh_ibb(ji,jj+1) - ssh_ibb(ji,jj) ) * r1_e2v(ji,jj) + END_2D + ENDIF + ! + ! !== tide potential forcing term ==! + IF( .NOT.ln_dynspg_ts .AND. ( ln_tide_pot .AND. ln_tide ) ) THEN ! N.B. added directly at sub-time-step in ts-case + ! + ! Update tide potential at the beginning of current time step + zt0step = REAL(nsec_day, wp)-0.5_wp*rn_Dt + CALL upd_tide(zt0step, Kmm) + ! + DO_2D( 0, 0, 0, 0 ) ! add tide potential forcing + zpgu(ji,jj) = zpgu(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) + zpgv(ji,jj) = zpgv(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) + END_2D + ! + IF (ln_scal_load) THEN + zld = rn_scal_load * grav + DO_2D( 0, 0, 0, 0 ) ! add scalar approximation for load potential + zpgu(ji,jj) = zpgu(ji,jj) + zld * ( pssh(ji+1,jj,Kmm) - pssh(ji,jj,Kmm) ) * r1_e1u(ji,jj) + zpgv(ji,jj) = zpgv(ji,jj) + zld * ( pssh(ji,jj+1,Kmm) - pssh(ji,jj,Kmm) ) * r1_e2v(ji,jj) + END_2D + ENDIF + ENDIF + ! + IF( ln_ice_embd ) THEN !== embedded sea ice: Pressure gradient due to snow-ice mass ==! + ALLOCATE( zpice(jpi,jpj) ) + zintp = REAL( MOD( kt-1, nn_fsbc ) ) / REAL( nn_fsbc ) + zgrho0r = - grav * r1_rho0 + zpice(:,:) = ( zintp * snwice_mass(:,:) + ( 1.- zintp ) * snwice_mass_b(:,:) ) * zgrho0r + DO_2D( 0, 0, 0, 0 ) + zpgu(ji,jj) = zpgu(ji,jj) + ( zpice(ji+1,jj) - zpice(ji,jj) ) * r1_e1u(ji,jj) + zpgv(ji,jj) = zpgv(ji,jj) + ( zpice(ji,jj+1) - zpice(ji,jj) ) * r1_e2v(ji,jj) + END_2D + DEALLOCATE( zpice ) + ENDIF + ! + IF( ln_wave .and. ln_bern_srfc ) THEN !== Add J terms: depth-independent Bernoulli head + DO_2D( 0, 0, 0, 0 ) + zpgu(ji,jj) = zpgu(ji,jj) + ( bhd_wave(ji+1,jj) - bhd_wave(ji,jj) ) / e1u(ji,jj) !++ bhd_wave from wave model in m2/s2 [BHD parameters in WW3] + zpgv(ji,jj) = zpgv(ji,jj) + ( bhd_wave(ji,jj+1) - bhd_wave(ji,jj) ) / e2v(ji,jj) + END_2D + ENDIF + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Add all terms to the general trend + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zpgu(ji,jj) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zpgv(ji,jj) + END_3D + ! +!!gm add here a call to dyn_trd for ice pressure gradient, the surf pressure trends ???? + ! + ENDIF + ! + SELECT CASE ( nspg ) !== surface pressure gradient computed and add to the general trend ==! + CASE ( np_EXP ) ; CALL dyn_spg_exp( kt, Kmm, puu, pvv, Krhs ) ! explicit + CASE ( np_TS ) ; CALL dyn_spg_ts ( kt, Kbb, Kmm, Krhs, puu, pvv, pssh, puu_b, pvv_b, Kaa, k_only_ADV ) ! time-splitting + END SELECT + ! + IF( l_trddyn ) THEN ! save the surface pressure gradient trends for further diagnostics + ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_spg, kt, Kmm ) + DEALLOCATE( ztrdu , ztrdv ) + ENDIF + ! ! print mean trends (used for debugging) + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' spg - Ua: ', mask1=umask, & + & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_spg') + ! + END SUBROUTINE dyn_spg + + + SUBROUTINE dyn_spg_init + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_spg_init *** + !! + !! ** Purpose : Control the consistency between namelist options for + !! surface pressure gradient schemes + !!---------------------------------------------------------------------- + INTEGER :: ioptio, ios ! local integers + ! + NAMELIST/namdyn_spg/ ln_dynspg_exp , ln_dynspg_ts, & + & ln_bt_fw, ln_bt_av , ln_bt_auto , & + & nn_e , rn_bt_cmax, nn_bt_flt, rn_bt_alpha + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_spg_init : choice of the surface pressure gradient scheme' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + READ ( numnam_ref, namdyn_spg, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_spg in reference namelist' ) + ! + READ ( numnam_cfg, namdyn_spg, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_spg in configuration namelist' ) + IF(lwm) WRITE ( numond, namdyn_spg ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) ' Namelist : namdyn_spg ' + WRITE(numout,*) ' Explicit free surface ln_dynspg_exp = ', ln_dynspg_exp + WRITE(numout,*) ' Free surface with time splitting ln_dynspg_ts = ', ln_dynspg_ts + ENDIF + ! ! Control of surface pressure gradient scheme options + nspg = np_NO ; ioptio = 0 + IF( ln_dynspg_exp ) THEN ; nspg = np_EXP ; ioptio = ioptio + 1 ; ENDIF + IF( ln_dynspg_ts ) THEN ; nspg = np_TS ; ioptio = ioptio + 1 ; ENDIF + ! + IF( ioptio > 1 ) CALL ctl_stop( 'Choose only one surface pressure gradient scheme' ) + IF( ioptio == 0 ) CALL ctl_warn( 'NO surface pressure gradient trend in momentum Eqs.' ) + IF( ln_dynspg_exp .AND. ln_isfcav ) & + & CALL ctl_stop( ' dynspg_exp not tested with ice shelf cavity ' ) + ! + IF(lwp) THEN + WRITE(numout,*) + IF( nspg == np_EXP ) WRITE(numout,*) ' ==>>> explicit free surface' + IF( nspg == np_TS ) WRITE(numout,*) ' ==>>> free surface with time splitting scheme' + IF( nspg == np_NO ) WRITE(numout,*) ' ==>>> No surface surface pressure gradient trend in momentum Eqs.' + ENDIF + ! + IF( nspg == np_TS ) THEN ! split-explicit scheme initialisation + CALL dyn_spg_ts_init ! do it first: set nn_e used to allocate some arrays later on + ENDIF + ! + END SUBROUTINE dyn_spg_init + + !!====================================================================== +END MODULE dynspg \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynspg_exp.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynspg_exp.F90 new file mode 100644 index 0000000..ccbb111 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynspg_exp.F90 @@ -0,0 +1,88 @@ +MODULE dynspg_exp + !!====================================================================== + !! *** MODULE dynspg_exp *** + !! Ocean dynamics: surface pressure gradient trend, explicit scheme + !!====================================================================== + !! History : 2.0 ! 2005-11 (V. Garnier, G. Madec, L. Bessieres) Original code + !! 3.2 ! 2009-06 (G. Madec, M. Leclair, R. Benshila) introduce sshwzv module + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_spg_exp : update the momentum trend with the surface + !! pressure gradient in the free surface constant + !! volume case with vector optimization + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface boundary condition: ocean + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distributed memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE iom ! I/O library + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_spg_exp ! called in dynspg.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynspg_exp.F90 14064 2020-12-03 17:01:12Z ayoung $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_spg_exp( kt, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** routine dyn_spg_exp *** + !! + !! ** Purpose : Compute the now trend due to the surface pressure + !! gradient in case of explicit free surface formulation and + !! add it to the general trend of momentum equation. + !! + !! ** Method : Explicit free surface formulation. Add to the general + !! momentum trend the surface pressure gradient : + !! (uu(rhs),vv(rhs)) = (uu(rhs),vv(rhs)) + (spgu,spgv) + !! where spgu = -1/rho0 d/dx(ps) = -g/e1u di( ssh(now) ) + !! spgv = -1/rho0 d/dy(ps) = -g/e2v dj( ssh(now) ) + !! + !! ** Action : (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) trend of horizontal velocity increased by + !! the surf. pressure gradient trend + !!--------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: zpgu, zpgv ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_spg_exp : surface pressure gradient trend' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ (explicit free surface)' + ! + zpgu(:,:) = 0._wp ; zpgv(:,:) = 0._wp + ! + IF( .NOT.ln_linssh .AND. lwp ) WRITE(numout,*) ' non linear free surface: spg is included in dynhpg' + ENDIF + ! + DO_2D( 0, 0, 0, 0 ) + zpgu(ji,jj) = - grav * ( ssh(ji+1,jj,Kmm) - ssh(ji,jj,Kmm) ) * r1_e1u(ji,jj) + zpgv(ji,jj) = - grav * ( ssh(ji,jj+1,Kmm) - ssh(ji,jj,Kmm) ) * r1_e2v(ji,jj) + END_2D + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zpgu(ji,jj) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zpgv(ji,jj) + END_3D + ! + END SUBROUTINE dyn_spg_exp + + !!====================================================================== +END MODULE dynspg_exp \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynspg_ts.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynspg_ts.F90 new file mode 100644 index 0000000..369782f --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynspg_ts.F90 @@ -0,0 +1,1505 @@ +MODULE dynspg_ts + + !! Includes ROMS wd scheme with diagnostic outputs ; puu(:,:,:,Kmm) and puu(:,:,:,Krhs) updates are commented out ! + + !!====================================================================== + !! *** MODULE dynspg_ts *** + !! Ocean dynamics: surface pressure gradient trend, split-explicit scheme + !!====================================================================== + !! History : 1.0 ! 2004-12 (L. Bessieres, G. Madec) Original code + !! - ! 2005-11 (V. Garnier, G. Madec) optimization + !! - ! 2006-08 (S. Masson) distributed restart using iom + !! 2.0 ! 2007-07 (D. Storkey) calls to BDY routines + !! - ! 2008-01 (R. Benshila) change averaging method + !! 3.2 ! 2009-07 (R. Benshila, G. Madec) Complete revisit associated to vvl reactivation + !! 3.3 ! 2010-09 (D. Storkey, E. O'Dea) update for BDY for Shelf configurations + !! 3.3 ! 2011-03 (R. Benshila, R. Hordoir, P. Oddo) update calculation of ub_b + !! 3.5 ! 2013-07 (J. Chanut) Switch to Forward-backward time stepping + !! 3.6 ! 2013-11 (A. Coward) Update for z-tilde compatibility + !! 3.7 ! 2015-11 (J. Chanut) free surface simplification + !! - ! 2016-12 (G. Madec, E. Clementi) update for Stoke-Drift divergence + !! 4.0 ! 2017-05 (G. Madec) drag coef. defined at t-point (zdfdrg.F90) + !!--------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_spg_ts : compute surface pressure gradient trend using a time-splitting scheme + !! dyn_spg_ts_init: initialisation of the time-splitting scheme + !! ts_wgt : set time-splitting weights for temporal averaging (or not) + !! ts_rst : read/write time-splitting fields in restart file + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface boundary condition: ocean + USE isf_oce ! ice shelf variable (fwfisf) + USE zdf_oce ! vertical physics: variables + USE zdfdrg ! vertical physics: top/bottom drag coef. + USE sbcapr ! surface boundary condition: atmospheric pressure + USE dynadv , ONLY: ln_dynadv_vec + USE dynvor ! vortivity scheme indicators + USE phycst ! physical constants + USE dynvor ! vorticity term + USE wet_dry ! wetting/drying flux limter + USE bdy_oce ! open boundary + USE bdyvol ! open boundary volume conservation + USE bdytides ! open boundary condition data + USE bdydyn2d ! open boundary conditions on barotropic variables + USE tide_mod ! + USE sbcwave ! surface wave +#if defined key_agrif + USE agrif_oce_interp ! agrif + USE agrif_oce +#endif +#if defined key_asminc + USE asminc ! Assimilation increment +#endif + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distributed memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE iom ! IOM library + USE restart ! only for lrst_oce + + USE iom ! to remove + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_spg_ts ! called by dyn_spg + PUBLIC dyn_spg_ts_init ! - - dyn_spg_init + + !! Time filtered arrays at baroclinic time step: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_adv , vn_adv !: Advection vel. at "now" barocl. step + ! + INTEGER, SAVE :: icycle ! Number of barotropic sub-steps for each internal step nn_e <= 2.5 nn_e + REAL(dp),SAVE :: rDt_e ! Barotropic time step + ! + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: wgtbtp2! 1st & 2nd weights used in time filtering of barotropic fields + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:) :: wgtbtp1! 1st & 2nd weights used in time filtering of barotropic fields + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zwz ! ff_f/h at F points + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftnw, ftne ! triad of coriolis parameter + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftsw, ftse ! (only used with een vorticity scheme) + + REAL(wp) :: r1_12 = 1._wp / 12._wp ! local ratios + REAL(wp) :: r1_8 = 0.125_wp ! + REAL(wp) :: r1_4 = 0.25_wp ! + REAL(wp) :: r1_2 = 0.5_wp ! + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynspg_ts.F90 15489 2021-11-10 09:18:39Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION dyn_spg_ts_alloc() + !!---------------------------------------------------------------------- + !! *** routine dyn_spg_ts_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(3) + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! + ALLOCATE( wgtbtp1(3*nn_e), wgtbtp2(3*nn_e), zwz(jpi,jpj), STAT=ierr(1) ) + IF( ln_dynvor_een .OR. ln_dynvor_eeT ) & + & ALLOCATE( ftnw(jpi,jpj) , ftne(jpi,jpj) , ftsw(jpi,jpj) , ftse(jpi,jpj), STAT=ierr(2) ) + ! + ALLOCATE( un_adv(jpi,jpj), vn_adv(jpi,jpj) , STAT=ierr(3) ) + ! + dyn_spg_ts_alloc = MAXVAL( ierr(:) ) + ! + CALL mpp_sum( 'dynspg_ts', dyn_spg_ts_alloc ) + IF( dyn_spg_ts_alloc /= 0 ) CALL ctl_stop( 'STOP', 'dyn_spg_ts_alloc: failed to allocate arrays' ) + ! + END FUNCTION dyn_spg_ts_alloc + + + SUBROUTINE dyn_spg_ts( kt, Kbb, Kmm, Krhs, puu, pvv, pssh, puu_b, pvv_b, Kaa, k_only_ADV ) + !!---------------------------------------------------------------------- + !! + !! ** Purpose : - Compute the now trend due to the explicit time stepping + !! of the quasi-linear barotropic system, and add it to the + !! general momentum trend. + !! + !! ** Method : - split-explicit schem (time splitting) : + !! Barotropic variables are advanced from internal time steps + !! "n" to "n+1" if ln_bt_fw=T + !! or from + !! "n-1" to "n+1" if ln_bt_fw=F + !! thanks to a generalized forward-backward time stepping (see ref. below). + !! + !! ** Action : + !! -Update the filtered free surface at step "n+1" : pssh(:,:,Kaa) + !! -Update filtered barotropic velocities at step "n+1" : puu_b(:,:,:,Kaa), vv_b(:,:,:,Kaa) + !! -Compute barotropic advective fluxes at step "n" : un_adv, vn_adv + !! These are used to advect tracers and are compliant with discrete + !! continuity equation taken at the baroclinic time steps. This + !! ensures tracers conservation. + !! - (puu(:,:,:,Krhs), pvv(:,:,:,Krhs)) momentum trend updated with barotropic component. + !! + !! References : Shchepetkin and McWilliams, Ocean Modelling, 2005. + !!--------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs, Kaa ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + REAL(wp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: puu_b, pvv_b! SSH and barotropic velocities at main time levels + REAL(dp), DIMENSION(jpi,jpj,jpt) , INTENT(inout) :: pssh! SSH and barotropic velocities at main time levels + INTEGER , OPTIONAL , INTENT( in ) :: k_only_ADV ! only Advection in the RHS + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + LOGICAL :: ll_fw_start ! =T : forward integration + LOGICAL :: ll_init ! =T : special startup of 2d equations + INTEGER :: noffset ! local integers : time offset for bdy update + REAL(wp) :: r1_Dt_b, z1_hu, z1_hv ! local scalars + REAL(wp) :: za0, za2, za3! - - + REAL(dp) :: za1! - - + REAL(wp) :: zztmp, zldg ! - - + REAL(wp) :: zhu_bck, zhv_bck! - - + REAL(dp) :: zhdiv! - - + REAL(wp) :: zun_save, zvn_save ! - - + REAL(wp), DIMENSION(jpi,jpj) :: zu_trd, zu_frc, zu_spg + REAL(wp), DIMENSION(jpi,jpj) :: zv_trd, zv_frc, zv_spg + REAL(wp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhtp2_e + REAL(wp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zsshp2_e + REAL(wp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v ! top/bottom stress at u- & v-points + REAL(wp), DIMENSION(jpi,jpj) :: zhV! fluxes + REAL(dp), DIMENSION(jpi,jpj) :: zhU! fluxes +!!st#if defined key_qco +!!st REAL(wp), DIMENSION(jpi, jpj, jpk) :: ze3u, ze3v +!!st#endif + ! + REAL(wp) :: zwdramp ! local scalar - only used if ln_wd_dl = .True. + + INTEGER :: iwdg, jwdg, kwdg ! short-hand values for the indices of the output point + + REAL(wp) :: zepsilon, zgamma ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zcpx, zcpy ! Wetting/Dying gravity filter coef. + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztwdmask, zuwdmask, zvwdmask ! ROMS wetting and drying masks at t,u,v points + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zuwdav2, zvwdav2 ! averages over the sub-steps of zuwdmask and zvwdmask + REAL(wp) :: zt0substep ! Time of day at the beginning of the time substep + !!---------------------------------------------------------------------- + ! + IF( ln_wd_il ) ALLOCATE( zcpx(jpi,jpj), zcpy(jpi,jpj) ) + ! !* Allocate temporary arrays + IF( ln_wd_dl ) ALLOCATE( ztwdmask(jpi,jpj), zuwdmask(jpi,jpj), zvwdmask(jpi,jpj), zuwdav2(jpi,jpj), zvwdav2(jpi,jpj)) + ! + zwdramp = r_rn_wdmin1 ! simplest ramp +! zwdramp = 1._wp / (rn_wdmin2 - rn_wdmin1) ! more general ramp + ! ! inverse of baroclinic time step + r1_Dt_b = 1._wp / rDt + ! + ll_init = ln_bt_av ! if no time averaging, then no specific restart + ll_fw_start = .FALSE. + ! ! time offset in steps for bdy data update + IF( .NOT.ln_bt_fw ) THEN ; noffset = - nn_e + ELSE ; noffset = 0 + ENDIF + ! + IF( kt == nit000 ) THEN !* initialisation + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_spg_ts : surface pressure gradient trend' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~ free surface with time splitting' + IF(lwp) WRITE(numout,*) + ! + IF( l_1st_euler ) ll_init=.TRUE. + ! + IF( ln_bt_fw .OR. l_1st_euler ) THEN + ll_fw_start =.TRUE. + noffset = 0 + ELSE + ll_fw_start =.FALSE. + ENDIF + ! ! Set averaging weights and cycle length: + CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 ) + ! + ELSEIF( kt == nit000 + 1 ) THEN !* initialisation 2nd time-step + ! + IF( .NOT.ln_bt_fw ) THEN + ! If we did an Euler timestep on the first timestep we need to reset ll_fw_start + ! and the averaging weights. We don't have an easy way of telling whether we did + ! an Euler timestep on the first timestep (because l_1st_euler is reset to .false. + ! at the end of the first timestep) so just do this in all cases. + ll_fw_start = .FALSE. + CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 ) + ENDIF + ! + ENDIF + ! + ! ----------------------------------------------------------------------------- + ! Phase 1 : Coupling between general trend and barotropic estimates (1st step) + ! ----------------------------------------------------------------------------- + ! + ! + ! != zu_frc = 1/H e3*d/dt(Ua) =! (Vertical mean of Ua, the 3D trends) + ! ! --------------------------- ! +#if defined key_qco + zu_frc(:,:) = SUM( e3u_0(:,:,: ) * puu(:,:,:,Krhs) * umask(:,:,:), DIM=3 ) * r1_hu_0(:,:) + zv_frc(:,:) = SUM( e3v_0(:,:,: ) * pvv(:,:,:,Krhs) * vmask(:,:,:), DIM=3 ) * r1_hv_0(:,:) +#else + zu_frc(:,:) = SUM( e3u(:,:,:,Kmm) * puu(:,:,:,Krhs) * umask(:,:,:), DIM=3 ) * r1_hu(:,:,Kmm) + zv_frc(:,:) = SUM( e3v(:,:,:,Kmm) * pvv(:,:,:,Krhs) * vmask(:,:,:), DIM=3 ) * r1_hv(:,:,Kmm) +#endif + ! + ! + ! != U(Krhs) => baroclinic trend =! (remove its vertical mean) + DO jk = 1, jpkm1 ! ----------------------------- ! + puu(:,:,jk,Krhs) = ( puu(:,:,jk,Krhs) - zu_frc(:,:) ) * umask(:,:,jk) + pvv(:,:,jk,Krhs) = ( pvv(:,:,jk,Krhs) - zv_frc(:,:) ) * vmask(:,:,jk) + END DO + +!!gm Question here when removing the Vertically integrated trends, we remove the vertically integrated NL trends on momentum.... +!!gm Is it correct to do so ? I think so... + + ! != remove 2D Coriolis trend =! + ! ! -------------------------- ! + ! + IF( kt == nit000 .OR. .NOT. ln_linssh ) CALL dyn_cor_2D_init( Kmm ) ! Set zwz, the barotropic Coriolis force coefficient + ! ! recompute zwz = f/depth at every time step for (.NOT.ln_linssh) as the water colomn height changes + ! + IF( .NOT. PRESENT(k_only_ADV) ) THEN !* remove the 2D Coriolis trend + zhU(:,:) = puu_b(:,:,Kmm) * hu(:,:,Kmm) * e2u(:,:) ! now fluxes + zhV(:,:) = pvv_b(:,:,Kmm) * hv(:,:,Kmm) * e1v(:,:) ! NB: FULL domain : put a value in last row and column + ! + CALL dyn_cor_2d( CASTSP(ht(:,:)), hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV, & ! <<== in + & zu_trd, zv_trd ) ! ==>> out + ! + DO_2D( 0, 0, 0, 0 ) ! Remove coriolis term (and possibly spg) from barotropic trend + zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj) + zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj) + END_2D + ENDIF + ! + ! != Add bottom stress contribution from baroclinic velocities =! + ! ! ----------------------------------------------------------- ! + IF( PRESENT(k_only_ADV) ) THEN !* only Advection in the RHS : provide the barotropic bottom drag coefficients + DO_2D( 0, 0, 0, 0 ) + zCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) + zCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) + END_2D + ELSE !* remove baroclinic drag AND provide the barotropic drag coefficients + CALL dyn_drg_init( Kbb, Kmm, puu, pvv, puu_b, pvv_b, zu_frc, zv_frc, zCdU_u, zCdU_v ) + ENDIF + ! + ! != Add atmospheric pressure forcing =! + ! ! ---------------------------------- ! + IF( ln_apr_dyn ) THEN + IF( ln_bt_fw ) THEN ! FORWARD integration: use kt+1/2 pressure (NOW+1/2) + DO_2D( 0, 0, 0, 0 ) + zu_frc(ji,jj) = zu_frc(ji,jj) + grav * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) + zv_frc(ji,jj) = zv_frc(ji,jj) + grav * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) + END_2D + ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 pressure (NOW) + zztmp = grav * r1_2 + DO_2D( 0, 0, 0, 0 ) + zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) & + & + ssh_ibb(ji+1,jj ) - ssh_ibb(ji,jj) ) * r1_e1u(ji,jj) + zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) & + & + ssh_ibb(ji ,jj+1) - ssh_ibb(ji,jj) ) * r1_e2v(ji,jj) + END_2D + ENDIF + ENDIF + ! + ! != Add wind forcing =! + ! ! ------------------ ! + IF( ln_bt_fw ) THEN + DO_2D( 0, 0, 0, 0 ) + zu_frc(ji,jj) = zu_frc(ji,jj) + r1_rho0 * utau(ji,jj) * r1_hu(ji,jj,Kmm) + zv_frc(ji,jj) = zv_frc(ji,jj) + r1_rho0 * vtau(ji,jj) * r1_hv(ji,jj,Kmm) + END_2D + ELSE + zztmp = r1_rho0 * r1_2 + DO_2D( 0, 0, 0, 0 ) + zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( utau_b(ji,jj) + utau(ji,jj) ) * r1_hu(ji,jj,Kmm) + zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( vtau_b(ji,jj) + vtau(ji,jj) ) * r1_hv(ji,jj,Kmm) + END_2D + ENDIF + ! + ! !----------------! + ! !== sssh_frc ==! Right-Hand-Side of the barotropic ssh equation (over the FULL domain) + ! !----------------! + ! != Net water flux forcing applied to a water column =! + ! ! --------------------------------------------------- ! + IF (ln_bt_fw) THEN ! FORWARD integration: use kt+1/2 fluxes (NOW+1/2) + ssh_frc(:,:) = r1_rho0 * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) ) + ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 fluxes (NOW) + zztmp = r1_rho0 * r1_2 + ssh_frc(:,:) = zztmp * ( emp(:,:) + emp_b(:,:) & + & - rnf(:,:) - rnf_b(:,:) & + & - fwfisf_cav(:,:) - fwfisf_cav_b(:,:) & + & - fwfisf_par(:,:) - fwfisf_par_b(:,:) ) + ENDIF + ! != Add Stokes drift divergence =! (if exist) + IF( ln_sdw ) THEN ! ----------------------------- ! + ssh_frc(:,:) = ssh_frc(:,:) + div_sd(:,:) + ENDIF + ! + ! ! ice sheet coupling + IF ( ln_isf .AND. ln_isfcpl ) THEN + ! + ! ice sheet coupling + IF( ln_rstart .AND. kt == nit000 ) THEN + ssh_frc(:,:) = ssh_frc(:,:) + risfcpl_ssh(:,:) + END IF + ! + ! conservation option + IF( ln_isfcpl_cons ) THEN + ssh_frc(:,:) = ssh_frc(:,:) + risfcpl_cons_ssh(:,:) + END IF + ! + END IF + ! +#if defined key_asminc + ! != Add the IAU weighted SSH increment =! + ! ! ------------------------------------ ! + IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN + ssh_frc(:,:) = ssh_frc(:,:) - ssh_iau(:,:) + ENDIF +#endif + ! != Fill boundary data arrays for AGRIF + ! ! ------------------------------------ +#if defined key_agrif + IF( .NOT.Agrif_Root() ) CALL agrif_dta_ts( kt ) +#endif + ! + ! ----------------------------------------------------------------------- + ! Phase 2 : Integration of the barotropic equations + ! ----------------------------------------------------------------------- + ! + ! ! ==================== ! + ! ! Initialisations ! + ! ! ==================== ! + ! Initialize barotropic variables: + IF( ll_init )THEN + sshbb_e(:,:) = 0._wp + ubb_e (:,:) = 0._wp + vbb_e (:,:) = 0._wp + sshb_e (:,:) = 0._wp + ub_e (:,:) = 0._wp + vb_e (:,:) = 0._wp + ENDIF + ! + IF( ln_linssh ) THEN ! mid-step ocean depth is fixed (hup2_e=hu_n=hu_0) + zhup2_e(:,:) = hu_0(:,:) + zhvp2_e(:,:) = hv_0(:,:) + zhtp2_e(:,:) = ht_0(:,:) + ENDIF + ! + IF( ln_bt_fw ) THEN ! FORWARD integration: start from NOW fields + sshn_e(:,:) = pssh (:,:,Kmm) + un_e (:,:) = puu_b(:,:,Kmm) + vn_e (:,:) = pvv_b(:,:,Kmm) + ! + hu_e (:,:) = hu(:,:,Kmm) + hv_e (:,:) = hv(:,:,Kmm) + hur_e (:,:) = r1_hu(:,:,Kmm) + hvr_e (:,:) = r1_hv(:,:,Kmm) + ELSE ! CENTRED integration: start from BEFORE fields + sshn_e(:,:) = pssh (:,:,Kbb) + un_e (:,:) = puu_b(:,:,Kbb) + vn_e (:,:) = pvv_b(:,:,Kbb) + ! + hu_e (:,:) = hu(:,:,Kbb) + hv_e (:,:) = hv(:,:,Kbb) + hur_e (:,:) = r1_hu(:,:,Kbb) + hvr_e (:,:) = r1_hv(:,:,Kbb) + ENDIF + ! + ! Initialize sums: + puu_b (:,:,Kaa) = 0._wp ! After barotropic velocities (or transport if flux form) + pvv_b (:,:,Kaa) = 0._wp + pssh (:,:,Kaa) = 0._wp ! Sum for after averaged sea level + un_adv(:,:) = 0._wp ! Sum for now transport issued from ts loop + vn_adv(:,:) = 0._wp + ! + IF( ln_wd_dl ) THEN + zuwdmask(:,:) = 0._wp ! set to zero for definiteness (not sure this is necessary) + zvwdmask(:,:) = 0._wp ! + zuwdav2 (:,:) = 0._wp + zvwdav2 (:,:) = 0._wp + END IF + + ! ! ==================== ! + DO jn = 1, icycle ! sub-time-step loop ! + ! ! ==================== ! + ! + l_full_nf_update = jn == icycle ! false: disable full North fold update (performances) for jn = 1 to icycle-1 + ! + ! !== Update the forcing ==! (BDY and tides) + ! + IF( ln_bdy .AND. ln_tide ) CALL bdy_dta_tides( kt, kit=jn, pt_offset= REAL(noffset+1,wp) ) + ! Update tide potential at the beginning of current time substep + IF( ln_tide_pot .AND. ln_tide ) THEN + zt0substep = REAL(nsec_day, wp) - 0.5_wp*rn_Dt + (jn + noffset - 1) * rn_Dt / REAL(nn_e, wp) + CALL upd_tide(zt0substep, Kmm) + END IF + ! + ! !== extrapolation at mid-step ==! (jn+1/2) + ! + ! !* Set extrapolation coefficients for predictor step: + IF ((jn<3).AND.ll_init) THEN ! Forward + za1 = 1._wp + za2 = 0._wp + za3 = 0._wp + ELSE ! AB3-AM4 Coefficients: bet=0.281105 + za1 = 1.781105_wp ! za1 = 3/2 + bet + za2 = -1.06221_wp ! za2 = -(1/2 + 2*bet) + za3 = 0.281105_wp ! za3 = bet + ENDIF + ! + ! !* Extrapolate barotropic velocities at mid-step (jn+1/2) + !-- m+1/2 m m-1 m-2 --! + !-- u = (3/2+beta) u -(1/2+2beta) u + beta u --! + !-------------------------------------------------------------------------! + ua_e(:,:) = za1 * un_e(:,:) + za2 * ub_e(:,:) + za3 * ubb_e(:,:) + va_e(:,:) = za1 * vn_e(:,:) + za2 * vb_e(:,:) + za3 * vbb_e(:,:) + + IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) + ! ! ------------------ + ! Extrapolate Sea Level at step jit+0.5: + !-- m+1/2 m m-1 m-2 --! + !-- ssh = (3/2+beta) ssh -(1/2+2beta) ssh + beta ssh --! + !--------------------------------------------------------------------------------! + zsshp2_e(:,:) = za1 * sshn_e(:,:) + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) + + ! set wetting & drying mask at tracer points for this barotropic mid-step + IF( ln_wd_dl ) CALL wad_tmsk( zsshp2_e, ztwdmask ) + ! + ! ! ocean t-depth at mid-step + zhtp2_e(:,:) = ht_0(:,:) + zsshp2_e(:,:) + ! + ! ! ocean u- and v-depth at mid-step (separate DO-loops remove the need of a lbc_lnk) +#if defined key_qcoTest_FluxForm + ! ! 'key_qcoTest_FluxForm' : simple ssh average + DO_2D( 1, 0, 1, 1 ) ! not jpi-column + zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji+1,jj ) ) * ssumask(ji,jj) + END_2D + DO_2D( 1, 1, 1, 0 ) + zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji ,jj+1) ) * ssvmask(ji,jj) + END_2D +#else + ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average + DO_2D( 1, 0, 1, 1 ) ! not jpi-column + zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj) & + & * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & + & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) + END_2D + DO_2D( 1, 1, 1, 0 ) ! not jpj-row + zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj) & + & * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & + & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) + END_2D +#endif + ! + ENDIF + ! + ! !== after SSH ==! (jn+1) + ! + ! ! update (ua_e,va_e) to enforce volume conservation at open boundaries + ! ! values of zhup2_e and zhvp2_e on the halo are not needed in bdy_vol2d + IF( ln_bdy .AND. ln_vol ) CALL bdy_vol2d( kt, jn, ua_e, va_e, zhup2_e, zhvp2_e ) + ! + ! ! resulting flux at mid-step (not over the full domain) + DO_2D( 1, 0, 1, 1 ) ! not jpi-column + zhU(ji,jj) = e2u(ji,jj) * ua_e(ji,jj) * zhup2_e(ji,jj) + END_2D + DO_2D( 1, 1, 1, 0 ) ! not jpj-row + zhV(ji,jj) = e1v(ji,jj) * va_e(ji,jj) * zhvp2_e(ji,jj) + END_2D + ! +#if defined key_agrif + ! Set fluxes during predictor step to ensure volume conservation + IF( ln_bt_fw ) CALL agrif_dyn_ts_flux( jn, zhU, zhV ) +#endif + IF( ln_wd_il ) CALL wad_lmt_bt(zhU, zhV, sshn_e, ssh_frc, rDt_e) !!gm wad_lmt_bt use of lbc_lnk on zhU, zhV + + IF( ln_wd_dl ) THEN ! un_e and vn_e are set to zero at faces where + ! ! the direction of the flow is from dry cells + CALL wad_Umsk( ztwdmask, zhU, zhV, un_e, vn_e, zuwdmask, zvwdmask ) ! not jpi colomn for U, not jpj row for V + ! + ENDIF + ! + ! + ! Compute Sea Level at step jit+1 + !-- m+1 m m+1/2 --! + !-- ssh = ssh - delta_t' * [ frc + div( flux ) ] --! + !-------------------------------------------------------------------------! + DO_2D( 0, 0, 0, 0 ) + zhdiv = ( zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1) ) * r1_e1e2t(ji,jj) + ssha_e(ji,jj) = ( sshn_e(ji,jj) - rDt_e * ( ssh_frc(ji,jj) + zhdiv ) ) * ssmask(ji,jj) + END_2D + ! + CALL lbc_lnk( 'dynspg_ts', ssha_e, 'T', 1._dp, zhU, 'U', -1._dp) + CALL lbc_lnk( 'dynspg_ts', zhV, 'V', -1._wp ) + ! + ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T) + IF( ln_bdy ) CALL bdy_ssh( ssha_e ) +#if defined key_agrif + CALL agrif_ssh_ts( jn ) +#endif + ! + ! ! Sum over sub-time-steps to compute advective velocities + za2 = wgtbtp2(jn) ! zhU, zhV hold fluxes extrapolated at jn+0.5 + un_adv(:,:) = un_adv(:,:) + za2 * zhU(:,:) * r1_e2u(:,:) + vn_adv(:,:) = vn_adv(:,:) + za2 * zhV(:,:) * r1_e1v(:,:) + ! sum over sub-time-steps to decide which baroclinic velocities to set to zero (zuwdav2 is only used when ln_wd_dl_bc=True) + IF ( ln_wd_dl_bc ) THEN + DO_2D( 1, 0, 1, 1 ) ! not jpi-column + zuwdav2(ji,jj) = zuwdav2(ji,jj) + za2 * zuwdmask(ji,jj) + END_2D + DO_2D( 1, 1, 1, 0 ) ! not jpj-row + zvwdav2(ji,jj) = zvwdav2(ji,jj) + za2 * zvwdmask(ji,jj) + END_2D + END IF + ! + ! + ! Sea Surface Height at u-,v-points (vvl case only) + IF( .NOT.ln_linssh ) THEN +#if defined key_qcoTest_FluxForm + ! ! 'key_qcoTest_FluxForm' : simple ssh average + DO_2D( 1, 0, 1, 1 ) + zsshu_a(ji,jj) = r1_2 * ( ssha_e(ji,jj) + ssha_e(ji+1,jj ) ) * ssumask(ji,jj) + END_2D + DO_2D( 1, 1, 1, 0 ) + zsshv_a(ji,jj) = r1_2 * ( ssha_e(ji,jj) + ssha_e(ji ,jj+1) ) * ssvmask(ji,jj) + END_2D +#else + DO_2D( 0, 0, 0, 0 ) + zsshu_a(ji,jj) = r1_2 * r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & + & + e1e2t(ji+1,jj ) * ssha_e(ji+1,jj ) ) * ssumask(ji,jj) + zsshv_a(ji,jj) = r1_2 * r1_e1e2v(ji,jj) * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & + & + e1e2t(ji ,jj+1) * ssha_e(ji ,jj+1) ) * ssvmask(ji,jj) + END_2D +#endif + ENDIF + ! + ! Half-step back interpolation of SSH for surface pressure computation at step jit+1/2 + !-- m+1/2 m+1 m m-1 m-2 --! + !-- ssh' = za0 * ssh + za1 * ssh + za2 * ssh + za3 * ssh --! + !------------------------------------------------------------------------------------------! + CALL ts_bck_interp( jn, ll_init, za0, za1, za2, za3 ) ! coeficients of the interpolation + zsshp2_e(:,:) = za0 * ssha_e(:,:) + za1 * sshn_e (:,:) & + & + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) + ! + ! ! Surface pressure gradient + zldg = ( 1._wp - rn_scal_load ) * grav ! local factor + DO_2D( 0, 0, 0, 0 ) + zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) + zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) + END_2D + IF( ln_wd_il ) THEN ! W/D : gravity filters applied on pressure gradient + CALL wad_spg( zsshp2_e, zcpx, zcpy ) ! Calculating W/D gravity filters + DO_2D( 0, 0, 0, 0 ) + zu_spg(ji,jj) = zu_spg(ji,jj) * zcpx(ji,jj) + zv_spg(ji,jj) = zv_spg(ji,jj) * zcpy(ji,jj) + END_2D + ENDIF + ! + ! Add Coriolis trend: + ! zwz array below or triads normally depend on sea level with ln_linssh=F and should be updated + ! at each time step. We however keep them constant here for optimization. + ! Recall that zhU and zhV hold fluxes at jn+0.5 (extrapolated not backward interpolated) + CALL dyn_cor_2d( zhtp2_e, zhup2_e, zhvp2_e, ua_e, va_e, zhU, zhV, zu_trd, zv_trd ) + ! + ! Add tidal astronomical forcing if defined + IF ( ln_tide .AND. ln_tide_pot ) THEN + DO_2D( 0, 0, 0, 0 ) + zu_trd(ji,jj) = zu_trd(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) + zv_trd(ji,jj) = zv_trd(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) + END_2D + ENDIF + ! + ! Add bottom stresses: +!jth do implicitly instead + IF ( .NOT. ll_wd ) THEN ! Revert to explicit for bit comparison tests in non wad runs + DO_2D( 0, 0, 0, 0 ) + zu_trd(ji,jj) = zu_trd(ji,jj) + zCdU_u(ji,jj) * un_e(ji,jj) * hur_e(ji,jj) + zv_trd(ji,jj) = zv_trd(ji,jj) + zCdU_v(ji,jj) * vn_e(ji,jj) * hvr_e(ji,jj) + END_2D + ENDIF + ! + ! Set next velocities: + ! Compute barotropic speeds at step jit+1 (h : total height of the water colomn) + !-- VECTOR FORM + !-- m+1 m / m+1/2 \ --! + !-- u = u + delta_t' * \ (1-r)*g * grad_x( ssh') - f * k vect u + frc / --! + !-- --! + !-- FLUX FORM --! + !-- m+1 __1__ / m m / m+1/2 m+1/2 m+1/2 n \ \ --! + !-- u = m+1 | h * u + delta_t' * \ h * (1-r)*g * grad_x( ssh') - h * f * k vect u + h * frc / | --! + !-- h \ / --! + !------------------------------------------------------------------------------------------------------------------------! + IF( ln_dynadv_vec .OR. ln_linssh ) THEN !* Vector form + DO_2D( 0, 0, 0, 0 ) + ua_e(ji,jj) = ( un_e(ji,jj) & + & + rDt_e * ( zu_spg(ji,jj) & + & + zu_trd(ji,jj) & + & + zu_frc(ji,jj) ) & + & ) * ssumask(ji,jj) + + va_e(ji,jj) = ( vn_e(ji,jj) & + & + rDt_e * ( zv_spg(ji,jj) & + & + zv_trd(ji,jj) & + & + zv_frc(ji,jj) ) & + & ) * ssvmask(ji,jj) + END_2D + ! + ELSE !* Flux form + DO_2D( 0, 0, 0, 0 ) + ! ! hu_e, hv_e hold depth at jn, zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 + ! ! backward interpolated depth used in spg terms at jn+1/2 +#if defined key_qcoTest_FluxForm + ! ! 'key_qcoTest_FluxForm' : simple ssh average + zhu_bck = hu_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji+1,jj ) ) * ssumask(ji,jj) + zhv_bck = hv_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji ,jj+1) ) * ssvmask(ji,jj) +#else + zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & + & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) + zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & + & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) +#endif + ! ! inverse depth at jn+1 + z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) + z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask(ji,jj) ) + ! + ua_e(ji,jj) = ( hu_e (ji,jj) * un_e (ji,jj) & + & + rDt_e * ( zhu_bck * zu_spg (ji,jj) & ! + & + zhup2_e(ji,jj) * zu_trd (ji,jj) & ! + & + hu(ji,jj,Kmm) * zu_frc (ji,jj) ) ) * z1_hu + ! + va_e(ji,jj) = ( hv_e (ji,jj) * vn_e (ji,jj) & + & + rDt_e * ( zhv_bck * zv_spg (ji,jj) & ! + & + zhvp2_e(ji,jj) * zv_trd (ji,jj) & ! + & + hv(ji,jj,Kmm) * zv_frc (ji,jj) ) ) * z1_hv + END_2D + ENDIF +!jth implicit bottom friction: + IF ( ll_wd ) THEN ! revert to explicit for bit comparison tests in non wad runs + DO_2D( 0, 0, 0, 0 ) + ua_e(ji,jj) = ua_e(ji,jj) / ( 1._wp - rDt_e * zCdU_u(ji,jj) * hur_e(ji,jj) ) + va_e(ji,jj) = va_e(ji,jj) / ( 1._wp - rDt_e * zCdU_v(ji,jj) * hvr_e(ji,jj) ) + END_2D + ENDIF + + IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) + DO_2D( 0, 0, 0, 0 ) + hu_e (ji,jj) = hu_0(ji,jj) + zsshu_a(ji,jj) + hur_e(ji,jj) = ssumask(ji,jj) / ( hu_e(ji,jj) + 1._wp - ssumask(ji,jj) ) + hv_e (ji,jj) = hv_0(ji,jj) + zsshv_a(ji,jj) + hvr_e(ji,jj) = ssvmask(ji,jj) / ( hv_e(ji,jj) + 1._wp - ssvmask(ji,jj) ) + END_2D + ENDIF + ! + IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) + CALL lbc_lnk( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp & + & , hu_e , 'U', 1._wp, hv_e , 'V', 1._wp & + & , hur_e, 'U', 1._wp, hvr_e, 'V', 1._wp ) + ELSE + CALL lbc_lnk( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp ) + ENDIF + ! ! open boundaries + IF( ln_bdy ) CALL bdy_dyn2d( jn, ua_e, va_e, un_e, vn_e, hur_e, hvr_e, ssha_e ) +#if defined key_agrif + CALL agrif_dyn_ts( jn ) ! Agrif +#endif + ! !* Swap + ! ! ---- + ubb_e (:,:) = ub_e (:,:) + ub_e (:,:) = un_e (:,:) + un_e (:,:) = ua_e (:,:) + ! + vbb_e (:,:) = vb_e (:,:) + vb_e (:,:) = vn_e (:,:) + vn_e (:,:) = va_e (:,:) + ! + sshbb_e(:,:) = sshb_e(:,:) + sshb_e (:,:) = sshn_e(:,:) + sshn_e (:,:) = ssha_e(:,:) + + ! !* Sum over whole bt loop + ! ! ---------------------- + za1 = wgtbtp1(jn) + IF( ln_dynadv_vec .OR. ln_linssh ) THEN ! Sum velocities + puu_b (:,:,Kaa) = puu_b (:,:,Kaa) + za1 * ua_e (:,:) + pvv_b (:,:,Kaa) = pvv_b (:,:,Kaa) + za1 * va_e (:,:) + ELSE ! Sum transports + IF ( .NOT.ln_wd_dl ) THEN + puu_b (:,:,Kaa) = puu_b (:,:,Kaa) + za1 * ua_e (:,:) * hu_e (:,:) + pvv_b (:,:,Kaa) = pvv_b (:,:,Kaa) + za1 * va_e (:,:) * hv_e (:,:) + ELSE + puu_b (:,:,Kaa) = puu_b (:,:,Kaa) + za1 * ua_e (:,:) * hu_e (:,:) * zuwdmask(:,:) + pvv_b (:,:,Kaa) = pvv_b (:,:,Kaa) + za1 * va_e (:,:) * hv_e (:,:) * zvwdmask(:,:) + END IF + ENDIF + ! ! Sum sea level + pssh(:,:,Kaa) = pssh(:,:,Kaa) + za1 * ssha_e(:,:) + + ! ! ==================== ! + END DO ! end loop ! + ! ! ==================== ! + ! ----------------------------------------------------------------------------- + ! Phase 3. update the general trend with the barotropic trend + ! ----------------------------------------------------------------------------- + ! + ! Set advection velocity correction: + IF (ln_bt_fw) THEN + IF( .NOT.( kt == nit000 .AND. l_1st_euler ) ) THEN + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zun_save = un_adv(ji,jj) + zvn_save = vn_adv(ji,jj) + ! ! apply the previously computed correction + un_adv(ji,jj) = r1_2 * ( ub2_b(ji,jj) + zun_save - rn_atfp * un_bf(ji,jj) ) + vn_adv(ji,jj) = r1_2 * ( vb2_b(ji,jj) + zvn_save - rn_atfp * vn_bf(ji,jj) ) + ! ! Update corrective fluxes for next time step + un_bf(ji,jj) = rn_atfp * un_bf(ji,jj) + ( zun_save - ub2_b(ji,jj) ) + vn_bf(ji,jj) = rn_atfp * vn_bf(ji,jj) + ( zvn_save - vb2_b(ji,jj) ) + ! ! Save integrated transport for next computation + ub2_b(ji,jj) = zun_save + vb2_b(ji,jj) = zvn_save + END_2D + ELSE + un_bf(:,:) = 0._wp ! corrective fluxes for next time step set to zero + vn_bf(:,:) = 0._wp + ub2_b(:,:) = un_adv(:,:) ! Save integrated transport for next computation + vb2_b(:,:) = vn_adv(:,:) + END IF + ENDIF + + + ! + ! Update barotropic trend: + IF( ln_dynadv_vec .OR. ln_linssh ) THEN + DO jk=1,jpkm1 + puu(:,:,jk,Krhs) = puu(:,:,jk,Krhs) + ( puu_b(:,:,Kaa) - puu_b(:,:,Kbb) ) * r1_Dt_b + pvv(:,:,jk,Krhs) = pvv(:,:,jk,Krhs) + ( pvv_b(:,:,Kaa) - pvv_b(:,:,Kbb) ) * r1_Dt_b + END DO + ELSE + ! At this stage, pssh(:,:,:,Krhs) has been corrected: compute new depths at velocity points +#if defined key_qcoTest_FluxForm + ! ! 'key_qcoTest_FluxForm' : simple ssh average + DO_2D( 1, 0, 1, 0 ) + zsshu_a(ji,jj) = r1_2 * ( pssh(ji,jj,Kaa) + pssh(ji+1,jj ,Kaa) ) * ssumask(ji,jj) + zsshv_a(ji,jj) = r1_2 * ( pssh(ji,jj,Kaa) + pssh(ji ,jj+1,Kaa) ) * ssvmask(ji,jj) + END_2D +#else + DO_2D( 1, 0, 1, 0 ) + zsshu_a(ji,jj) = r1_2 * r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj) * pssh(ji ,jj,Kaa) & + & + e1e2t(ji+1,jj) * pssh(ji+1,jj,Kaa) ) * ssumask(ji,jj) + zsshv_a(ji,jj) = r1_2 * r1_e1e2v(ji,jj) * ( e1e2t(ji,jj ) * pssh(ji,jj ,Kaa) & + & + e1e2t(ji,jj+1) * pssh(ji,jj+1,Kaa) ) * ssvmask(ji,jj) + END_2D +#endif + CALL lbc_lnk( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions + ! + DO jk=1,jpkm1 + puu(:,:,jk,Krhs) = puu(:,:,jk,Krhs) + r1_hu(:,:,Kmm) & + & * ( puu_b(:,:,Kaa) - puu_b(:,:,Kbb) * hu(:,:,Kbb) ) * r1_Dt_b + pvv(:,:,jk,Krhs) = pvv(:,:,jk,Krhs) + r1_hv(:,:,Kmm) & + & * ( pvv_b(:,:,Kaa) - pvv_b(:,:,Kbb) * hv(:,:,Kbb) ) * r1_Dt_b + END DO + ! Save barotropic velocities not transport: + puu_b(:,:,Kaa) = puu_b(:,:,Kaa) / ( hu_0(:,:) + zsshu_a(:,:) + 1._wp - ssumask(:,:) ) + pvv_b(:,:,Kaa) = pvv_b(:,:,Kaa) / ( hv_0(:,:) + zsshv_a(:,:) + 1._wp - ssvmask(:,:) ) + ENDIF + + + ! Correct velocities so that the barotropic velocity equals (un_adv, vn_adv) (in all cases) + DO jk = 1, jpkm1 + puu(:,:,jk,Kmm) = ( puu(:,:,jk,Kmm) + un_adv(:,:)*r1_hu(:,:,Kmm) - puu_b(:,:,Kmm) ) * umask(:,:,jk) + pvv(:,:,jk,Kmm) = ( pvv(:,:,jk,Kmm) + vn_adv(:,:)*r1_hv(:,:,Kmm) - pvv_b(:,:,Kmm) ) * vmask(:,:,jk) + END DO + + IF ( ln_wd_dl .and. ln_wd_dl_bc) THEN + DO jk = 1, jpkm1 + puu(:,:,jk,Kmm) = ( un_adv(:,:)*r1_hu(:,:,Kmm) & + & + zuwdav2(:,:)*(puu(:,:,jk,Kmm) - un_adv(:,:)*r1_hu(:,:,Kmm)) ) * umask(:,:,jk) + pvv(:,:,jk,Kmm) = ( vn_adv(:,:)*r1_hv(:,:,Kmm) & + & + zvwdav2(:,:)*(pvv(:,:,jk,Kmm) - vn_adv(:,:)*r1_hv(:,:,Kmm)) ) * vmask(:,:,jk) + END DO + END IF + + + CALL iom_put( "ubar", un_adv(:,:)*r1_hu(:,:,Kmm) ) ! barotropic i-current + CALL iom_put( "vbar", vn_adv(:,:)*r1_hv(:,:,Kmm) ) ! barotropic i-current + ! +#if defined key_agrif + ! Save time integrated fluxes during child grid integration + ! (used to update coarse grid transports at next time step) + ! + IF( .NOT.Agrif_Root() .AND. ln_bt_fw .AND. ln_agrif_2way ) THEN + IF( Agrif_NbStepint() == 0 ) THEN + ub2_i_b(:,:) = 0._wp + vb2_i_b(:,:) = 0._wp + END IF + ! + za1 = 1._wp / REAL(Agrif_rhot(), wp) + ub2_i_b(:,:) = ub2_i_b(:,:) + za1 * ub2_b(:,:) + vb2_i_b(:,:) = vb2_i_b(:,:) + za1 * vb2_b(:,:) + ENDIF +#endif + ! !* write time-spliting arrays in the restart + IF( lrst_oce .AND.ln_bt_fw ) CALL ts_rst( kt, 'WRITE' ) + ! + IF( ln_wd_il ) DEALLOCATE( zcpx, zcpy ) + IF( ln_wd_dl ) DEALLOCATE( ztwdmask, zuwdmask, zvwdmask, zuwdav2, zvwdav2 ) + ! + CALL iom_put( "baro_u" , puu_b(:,:,Kmm) ) ! Barotropic U Velocity + CALL iom_put( "baro_v" , pvv_b(:,:,Kmm) ) ! Barotropic V Velocity + ! + END SUBROUTINE dyn_spg_ts + + + SUBROUTINE ts_wgt( ll_av, ll_fw, jpit, zwgt1, zwgt2) + !!--------------------------------------------------------------------- + !! *** ROUTINE ts_wgt *** + !! + !! ** Purpose : Set time-splitting weights for temporal averaging (or not) + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in) :: ll_av ! temporal averaging=.true. + LOGICAL, INTENT(in) :: ll_fw ! forward time splitting =.true. + INTEGER, INTENT(inout) :: jpit ! cycle length + REAL(wp), DIMENSION(3*nn_e), INTENT(inout) :: zwgt2 + REAL(dp), DIMENSION(3*nn_e), INTENT(inout) :: zwgt1 + + + INTEGER :: jic, jn, ji ! temporary integers + REAL(wp) :: za2 + REAL(dp) :: za1 + !!---------------------------------------------------------------------- + + zwgt1(:) = 0._wp + zwgt2(:) = 0._wp + + ! Set time index when averaged value is requested + IF (ll_fw) THEN + jic = nn_e + ELSE + jic = 2 * nn_e + ENDIF + + ! Set primary weights: + IF (ll_av) THEN + ! Define simple boxcar window for primary weights + ! (width = nn_e, centered around jic) + SELECT CASE ( nn_bt_flt ) + CASE( 0 ) ! No averaging + zwgt1(jic) = 1._wp + jpit = jic + + CASE( 1 ) ! Boxcar, width = nn_e + DO jn = 1, 3*nn_e + za1 = ABS(float(jn-jic))/float(nn_e) + IF (za1 < 0.5_wp) THEN + zwgt1(jn) = 1._wp + jpit = jn + ENDIF + ENDDO + + CASE( 2 ) ! Boxcar, width = 2 * nn_e + DO jn = 1, 3*nn_e + za1 = ABS(float(jn-jic))/float(nn_e) + IF (za1 < 1._wp) THEN + zwgt1(jn) = 1._wp + jpit = jn + ENDIF + ENDDO + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_bt_flt' ) + END SELECT + + ELSE ! No time averaging + zwgt1(jic) = 1._wp + jpit = jic + ENDIF + + ! Set secondary weights + DO jn = 1, jpit + DO ji = jn, jpit + zwgt2(jn) = zwgt2(jn) + zwgt1(ji) + END DO + END DO + + ! Normalize weigths: + za1 = 1._wp / SUM(zwgt1(1:jpit)) + za2 = 1._wp / SUM(zwgt2(1:jpit)) + DO jn = 1, jpit + zwgt1(jn) = zwgt1(jn) * za1 + zwgt2(jn) = zwgt2(jn) * za2 + END DO + ! + END SUBROUTINE ts_wgt + + + SUBROUTINE ts_rst( kt, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE ts_rst *** + !! + !! ** Purpose : Read or write time-splitting arrays in restart file + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + !!---------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise + ! ! --------------- + IF( ln_rstart .AND. ln_bt_fw .AND. .NOT.l_1st_euler ) THEN !* Read the restart file + CALL iom_get( numror, jpdom_auto, 'ub2_b' , ub2_b (:,:), cd_type = 'U', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'vb2_b' , vb2_b (:,:), cd_type = 'V', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'un_bf' , un_bf (:,:), cd_type = 'U', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'vn_bf' , vn_bf (:,:), cd_type = 'V', psgn = -1._dp ) + IF( .NOT.ln_bt_av ) THEN + CALL iom_get( numror, jpdom_auto, 'sshbb_e' , sshbb_e(:,:), cd_type = 'T', psgn = 1._dp ) + CALL iom_get( numror, jpdom_auto, 'ubb_e' , ubb_e(:,:), cd_type = 'U', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'vbb_e' , vbb_e(:,:), cd_type = 'V', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'sshb_e' , sshb_e(:,:), cd_type = 'T', psgn = 1._dp ) + CALL iom_get( numror, jpdom_auto, 'ub_e' , ub_e(:,:), cd_type = 'U', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'vb_e' , vb_e(:,:), cd_type = 'V', psgn = -1._dp ) + ENDIF +#if defined key_agrif + ! Read time integrated fluxes + IF ( .NOT.Agrif_Root() ) THEN + CALL iom_get( numror, jpdom_auto, 'ub2_i_b' , ub2_i_b(:,:), cd_type = 'U', psgn = -1._wp ) + CALL iom_get( numror, jpdom_auto, 'vb2_i_b' , vb2_i_b(:,:), cd_type = 'V', psgn = -1._wp ) + ELSE + ub2_i_b(:,:) = 0._wp ; vb2_i_b(:,:) = 0._wp ! used in the 1st update of agrif + ENDIF +#endif + ELSE !* Start from rest + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> start from rest: set barotropic values to 0' + ub2_b (:,:) = 0._wp ; vb2_b (:,:) = 0._wp ! used in the 1st interpol of agrif + un_adv (:,:) = 0._wp ; vn_adv (:,:) = 0._wp ! used in the 1st interpol of agrif + un_bf (:,:) = 0._wp ; vn_bf (:,:) = 0._wp ! used in the 1st update of agrif +#if defined key_agrif + ub2_i_b(:,:) = 0._wp ; vb2_i_b(:,:) = 0._wp ! used in the 1st update of agrif +#endif + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! ------------------- + IF(lwp) WRITE(numout,*) '---- ts_rst ----' + CALL iom_rstput( kt, nitrst, numrow, 'ub2_b' , ub2_b (:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'vb2_b' , vb2_b (:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'un_bf' , un_bf (:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'vn_bf' , vn_bf (:,:) ) + ! + IF (.NOT.ln_bt_av) THEN + CALL iom_rstput( kt, nitrst, numrow, 'sshbb_e' , sshbb_e(:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'ubb_e' , ubb_e(:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'vbb_e' , vbb_e(:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'sshb_e' , sshb_e(:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'ub_e' , ub_e(:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'vb_e' , vb_e(:,:) ) + ENDIF +#if defined key_agrif + ! Save time integrated fluxes + IF ( .NOT.Agrif_Root() ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'ub2_i_b' , ub2_i_b(:,:) ) + CALL iom_rstput( kt, nitrst, numrow, 'vb2_i_b' , vb2_i_b(:,:) ) + ENDIF +#endif + ENDIF + ! + END SUBROUTINE ts_rst + + + SUBROUTINE dyn_spg_ts_init + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_spg_ts_init *** + !! + !! ** Purpose : Set time splitting options + !!---------------------------------------------------------------------- + INTEGER :: ji ,jj ! dummy loop indices + REAL(wp) :: zxr2, zyr2, zcmax ! local scalar + REAL(wp), DIMENSION(jpi,jpj) :: zcu + !!---------------------------------------------------------------------- + ! + ! Max courant number for ext. grav. waves + ! + DO_2D( 0, 0, 0, 0 ) + zxr2 = r1_e1t(ji,jj) * r1_e1t(ji,jj) + zyr2 = r1_e2t(ji,jj) * r1_e2t(ji,jj) + zcu(ji,jj) = SQRT( grav * MAX(ht_0(ji,jj),0._wp) * (zxr2 + zyr2) ) + END_2D + ! + zcmax = MAXVAL( zcu(Nis0:Nie0,Njs0:Nje0) ) + CALL mpp_max( 'dynspg_ts', zcmax ) + + ! Estimate number of iterations to satisfy a max courant number= rn_bt_cmax + IF( ln_bt_auto ) nn_e = CEILING( rn_Dt / rn_bt_cmax * zcmax) + + rDt_e = rn_Dt / REAL( nn_e , dp ) + zcmax = zcmax * rDt_e + ! Print results + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_spg_ts_init : split-explicit free surface' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~' + IF( ln_bt_auto ) THEN + IF(lwp) WRITE(numout,*) ' ln_ts_auto =.true. Automatically set nn_e ' + IF(lwp) WRITE(numout,*) ' Max. courant number allowed: ', rn_bt_cmax + ELSE + IF(lwp) WRITE(numout,*) ' ln_ts_auto=.false.: Use nn_e in namelist nn_e = ', nn_e + ENDIF + + IF(ln_bt_av) THEN + IF(lwp) WRITE(numout,*) ' ln_bt_av =.true. ==> Time averaging over nn_e time steps is on ' + ELSE + IF(lwp) WRITE(numout,*) ' ln_bt_av =.false. => No time averaging of barotropic variables ' + ENDIF + ! + ! + IF(ln_bt_fw) THEN + IF(lwp) WRITE(numout,*) ' ln_bt_fw=.true. => Forward integration of barotropic variables ' + ELSE + IF(lwp) WRITE(numout,*) ' ln_bt_fw =.false.=> Centred integration of barotropic variables ' + ENDIF + ! +#if defined key_agrif + ! Restrict the use of Agrif to the forward case only + IF( .NOT.ln_bt_fw .AND. .NOT.Agrif_Root() ) CALL ctl_stop( 'AGRIF not implemented if ln_bt_fw=.FALSE.' ) +#endif + ! + IF(lwp) WRITE(numout,*) ' Time filter choice, nn_bt_flt: ', nn_bt_flt + SELECT CASE ( nn_bt_flt ) + CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' Dirac' + CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' Boxcar: width = nn_e' + CASE( 2 ) ; IF(lwp) WRITE(numout,*) ' Boxcar: width = 2*nn_e' + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_bt_flt: should 0,1, or 2' ) + END SELECT + ! + IF(lwp) WRITE(numout,*) ' ' + IF(lwp) WRITE(numout,*) ' nn_e = ', nn_e + IF(lwp) WRITE(numout,*) ' Barotropic time step [s] is :', rDt_e + IF(lwp) WRITE(numout,*) ' Maximum Courant number is :', zcmax + ! + IF(lwp) WRITE(numout,*) ' Time diffusion parameter rn_bt_alpha: ', rn_bt_alpha + IF ((ln_bt_av.AND.nn_bt_flt/=0).AND.(rn_bt_alpha>0._wp)) THEN + CALL ctl_stop( 'dynspg_ts ERROR: if rn_bt_alpha > 0, remove temporal averaging' ) + ENDIF + ! + IF( .NOT.ln_bt_av .AND. .NOT.ln_bt_fw ) THEN + CALL ctl_stop( 'dynspg_ts ERROR: No time averaging => only forward integration is possible' ) + ENDIF + IF( zcmax>0.9_wp ) THEN + CALL ctl_stop( 'dynspg_ts ERROR: Maximum Courant number is greater than 0.9: Inc. nn_e !' ) + ENDIF + ! + ! ! Allocate time-splitting arrays + IF( dyn_spg_ts_alloc() /= 0 ) CALL ctl_stop('STOP', 'dyn_spg_init: failed to allocate dynspg_ts arrays' ) + ! + ! ! read restart when needed + CALL ts_rst( nit000, 'READ' ) + ! + END SUBROUTINE dyn_spg_ts_init + + + SUBROUTINE dyn_cor_2D_init( Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_cor_2D_init *** + !! + !! ** Purpose : Set time splitting options + !! Set arrays to remove/compute coriolis trend. + !! Do it once during initialization if volume is fixed, else at each long time step. + !! Note that these arrays are also used during barotropic loop. These are however frozen + !! although they should be updated in the variable volume case. Not a big approximation. + !! To remove this approximation, copy lines below inside barotropic loop + !! and update depths at T- points (ht) at each barotropic time step + !! + !! Compute zwz = f / ( height of the water colomn ) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! Time index + INTEGER :: ji ,jj, jk ! dummy loop indices + REAL(wp) :: z1_ht + !!---------------------------------------------------------------------- + ! + SELECT CASE( nvor_scheme ) + CASE( np_EEN, np_ENE, np_ENS , np_MIX ) != schemes using the same e3f definition + SELECT CASE( nn_e3f_typ ) !* ff_f/e3 at F-point + CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) + DO_2D( 0, 0, 0, 0 ) + zwz(ji,jj) = ( ht(ji,jj+1) + ht(ji+1,jj+1) & + & + ht(ji,jj ) + ht(ji+1,jj ) ) * 0.25_wp + IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) + END_2D + CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) + DO_2D( 0, 0, 0, 0 ) + zwz(ji,jj) = ( ht(ji,jj+1) + ht(ji+1,jj+1) & + & + ht(ji,jj ) + ht(ji+1,jj ) ) & + & / ( MAX(ssmask(ji,jj+1) + ssmask(ji+1,jj+1) & + & + ssmask(ji,jj ) + ssmask(ji+1,jj ) , 1._wp ) ) + IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) + END_2D + END SELECT + CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) + END SELECT + ! + SELECT CASE( nvor_scheme ) + CASE( np_EEN ) + ! + ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp + DO_2D( 0, 1, 0, 1 ) + ftne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1) + ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj ) + ftse(ji,jj) = zwz(ji ,jj ) + zwz(ji ,jj-1) + zwz(ji-1,jj-1) + ftsw(ji,jj) = zwz(ji ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj ) + END_2D + ! + CASE( np_EET ) != EEN scheme using e3t energy conserving scheme + ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp + DO_2D( 0, 1, 0, 1 ) + z1_ht = ssmask(ji,jj) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) ) + ftne(ji,jj) = ( ff_f(ji-1,jj ) + ff_f(ji ,jj ) + ff_f(ji ,jj-1) ) * z1_ht + ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) + ff_f(ji ,jj ) ) * z1_ht + ftse(ji,jj) = ( ff_f(ji ,jj ) + ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht + ftsw(ji,jj) = ( ff_f(ji ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj ) ) * z1_ht + END_2D + ! + END SELECT + + END SUBROUTINE dyn_cor_2d_init + + + SUBROUTINE dyn_cor_2d( pht, phu, phv, punb, pvnb, zhU, zhV, zu_trd, zv_trd ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_cor_2d *** + !! + !! ** Purpose : Compute u and v coriolis trends + !!---------------------------------------------------------------------- + INTEGER :: ji ,jj ! dummy loop indices + REAL(wp) :: zx1, zx2, zy1, zy2, z1_hu, z1_hv ! - - + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pht, phu, phv, punb, pvnb, zhV + REAL(dp), DIMENSION(jpi,jpj), INTENT(in ) :: zhU + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: zu_trd, zv_trd + !!---------------------------------------------------------------------- + SELECT CASE( nvor_scheme ) + CASE( np_ENT ) ! enstrophy conserving scheme (f-point) + DO_2D( 0, 0, 0, 0 ) + z1_hu = ssumask(ji,jj) / ( phu(ji,jj) + 1._wp - ssumask(ji,jj) ) + z1_hv = ssvmask(ji,jj) / ( phv(ji,jj) + 1._wp - ssvmask(ji,jj) ) + zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu & + & * ( e1e2t(ji+1,jj)*pht(ji+1,jj)*ff_t(ji+1,jj) * ( pvnb(ji+1,jj) + pvnb(ji+1,jj-1) ) & + & + e1e2t(ji ,jj)*pht(ji ,jj)*ff_t(ji ,jj) * ( pvnb(ji ,jj) + pvnb(ji ,jj-1) ) ) + ! + zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv & + & * ( e1e2t(ji,jj+1)*pht(ji,jj+1)*ff_t(ji,jj+1) * ( punb(ji,jj+1) + punb(ji-1,jj+1) ) & + & + e1e2t(ji,jj )*pht(ji,jj )*ff_t(ji,jj ) * ( punb(ji,jj ) + punb(ji-1,jj ) ) ) + END_2D + ! + CASE( np_ENE , np_MIX ) ! energy conserving scheme (t-point) ENE or MIX + DO_2D( 0, 0, 0, 0 ) + zy1 = ( zhV(ji,jj-1) + zhV(ji+1,jj-1) ) * r1_e1u(ji,jj) + zy2 = ( zhV(ji,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj) + zx1 = ( zhU(ji-1,jj) + zhU(ji-1,jj+1) ) * r1_e2v(ji,jj) + zx2 = ( zhU(ji ,jj) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj) + ! energy conserving formulation for planetary vorticity term + zu_trd(ji,jj) = r1_4 * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) + zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) + END_2D + ! + CASE( np_ENS ) ! enstrophy conserving scheme (f-point) + DO_2D( 0, 0, 0, 0 ) + zy1 = r1_8 * ( zhV(ji ,jj-1) + zhV(ji+1,jj-1) & + & + zhV(ji ,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj) + zx1 = - r1_8 * ( zhU(ji-1,jj ) + zhU(ji-1,jj+1) & + & + zhU(ji ,jj ) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj) + zu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) ) + zv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) ) + END_2D + ! + CASE( np_EET , np_EEN ) ! energy & enstrophy scheme (using e3t or e3f) + DO_2D( 0, 0, 0, 0 ) + zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * ( ftne(ji,jj ) * zhV(ji ,jj ) & + & + ftnw(ji+1,jj) * zhV(ji+1,jj ) & + & + ftse(ji,jj ) * zhV(ji ,jj-1) & + & + ftsw(ji+1,jj) * zhV(ji+1,jj-1) ) + zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * ( ftsw(ji,jj+1) * zhU(ji-1,jj+1) & + & + ftse(ji,jj+1) * zhU(ji ,jj+1) & + & + ftnw(ji,jj ) * zhU(ji-1,jj ) & + & + ftne(ji,jj ) * zhU(ji ,jj ) ) + END_2D + ! + END SELECT + ! + END SUBROUTINE dyn_cor_2D + + + SUBROUTINE wad_tmsk( pssh, ptmsk ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wad_lmt *** + !! + !! ** Purpose : set wetting & drying mask at tracer points + !! for the current barotropic sub-step + !! + !! ** Method : ??? + !! + !! ** Action : ptmsk : wetting & drying t-mask + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pssh ! + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: ptmsk ! + ! + INTEGER :: ji, jj ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF( ln_wd_dl_rmp ) THEN + DO_2D( 1, 1, 1, 1 ) + IF ( pssh(ji,jj) + ht_0(ji,jj) > 2._wp * rn_wdmin1 ) THEN + ! IF ( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin2 ) THEN + ptmsk(ji,jj) = 1._wp + ELSEIF( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN + ptmsk(ji,jj) = TANH( 50._wp*( ( pssh(ji,jj) + ht_0(ji,jj) - rn_wdmin1 )*r_rn_wdmin1) ) + ELSE + ptmsk(ji,jj) = 0._wp + ENDIF + END_2D + ELSE + DO_2D( 1, 1, 1, 1 ) + IF ( pssh(ji,jj) + ht_0(ji,jj) > rn_wdmin1 ) THEN ; ptmsk(ji,jj) = 1._wp + ELSE ; ptmsk(ji,jj) = 0._wp + ENDIF + END_2D + ENDIF + ! + END SUBROUTINE wad_tmsk + + + SUBROUTINE wad_Umsk( pTmsk, phU, phV, pu, pv, pUmsk, pVmsk ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wad_lmt *** + !! + !! ** Purpose : set wetting & drying mask at tracer points + !! for the current barotropic sub-step + !! + !! ** Method : ??? + !! + !! ** Action : ptmsk : wetting & drying t-mask + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pTmsk ! W & D t-mask + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: phV, pu, pv! ocean velocities and transports + REAL(dp), DIMENSION(jpi,jpj), INTENT(inout) :: phU! ocean velocities and transports + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pUmsk, pVmsk ! W & D u- and v-mask + ! + INTEGER :: ji, jj ! dummy loop indices + !!---------------------------------------------------------------------- + ! + DO_2D( 1, 0, 1, 1 ) ! not jpi-column + IF ( phU(ji,jj) > 0._wp ) THEN ; pUmsk(ji,jj) = pTmsk(ji ,jj) + ELSE ; pUmsk(ji,jj) = pTmsk(ji+1,jj) + ENDIF + phU(ji,jj) = pUmsk(ji,jj)*phU(ji,jj) + pu (ji,jj) = pUmsk(ji,jj)*pu (ji,jj) + END_2D + ! + DO_2D( 1, 1, 1, 0 ) ! not jpj-row + IF ( phV(ji,jj) > 0._wp ) THEN ; pVmsk(ji,jj) = pTmsk(ji,jj ) + ELSE ; pVmsk(ji,jj) = pTmsk(ji,jj+1) + ENDIF + phV(ji,jj) = pVmsk(ji,jj)*phV(ji,jj) + pv (ji,jj) = pVmsk(ji,jj)*pv (ji,jj) + END_2D + ! + END SUBROUTINE wad_Umsk + + + SUBROUTINE wad_spg( pshn, zcpx, zcpy ) + !!--------------------------------------------------------------------- + !! *** ROUTINE wad_sp *** + !! + !! ** Purpose : + !!---------------------------------------------------------------------- + INTEGER :: ji ,jj ! dummy loop indices + LOGICAL :: ll_tmp1, ll_tmp2 + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pshn + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zcpx, zcpy + !!---------------------------------------------------------------------- + DO_2D( 0, 0, 0, 0 ) + ll_tmp1 = MIN( pshn(ji,jj) , pshn(ji+1,jj) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & + & MAX( pshn(ji,jj) + ht_0(ji,jj) , pshn(ji+1,jj) + ht_0(ji+1,jj) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( pshn(ji+1,jj) - pshn(ji ,jj)) > 1.E-12 ).AND.( & + & MAX( pshn(ji,jj) , pshn(ji+1,jj) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) + IF(ll_tmp1) THEN + zcpx(ji,jj) = 1.0_wp + ELSEIF(ll_tmp2) THEN + ! no worries about pshn(ji+1,jj) - pshn(ji ,jj) = 0, it won't happen ! here + zcpx(ji,jj) = ABS( (pshn(ji+1,jj) + ht_0(ji+1,jj) - pshn(ji,jj) - ht_0(ji,jj)) & + & / (pshn(ji+1,jj) - pshn(ji ,jj)) ) + zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) + ELSE + zcpx(ji,jj) = 0._wp + ENDIF + ! + ll_tmp1 = MIN( pshn(ji,jj) , pshn(ji,jj+1) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & + & MAX( pshn(ji,jj) + ht_0(ji,jj) , pshn(ji,jj+1) + ht_0(ji,jj+1) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( pshn(ji,jj) - pshn(ji,jj+1)) > 1.E-12 ).AND.( & + & MAX( pshn(ji,jj) , pshn(ji,jj+1) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) + + IF(ll_tmp1) THEN + zcpy(ji,jj) = 1.0_wp + ELSE IF(ll_tmp2) THEN + ! no worries about pshn(ji,jj+1) - pshn(ji,jj ) = 0, it won't happen ! here + zcpy(ji,jj) = ABS( (pshn(ji,jj+1) + ht_0(ji,jj+1) - pshn(ji,jj) - ht_0(ji,jj)) & + & / (pshn(ji,jj+1) - pshn(ji,jj )) ) + zcpy(ji,jj) = MAX( 0._wp , MIN( zcpy(ji,jj) , 1.0_wp ) ) + ELSE + zcpy(ji,jj) = 0._wp + ENDIF + END_2D + + END SUBROUTINE wad_spg + + + SUBROUTINE dyn_drg_init( Kbb, Kmm, puu, pvv, puu_b ,pvv_b, pu_RHSi, pv_RHSi, pCdU_u, pCdU_v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_drg_init *** + !! + !! ** Purpose : - add the baroclinic top/bottom drag contribution to + !! the baroclinic part of the barotropic RHS + !! - compute the barotropic drag coefficients + !! + !! ** Method : computation done over the INNER domain only + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(in ) :: puu, pvv ! ocean velocities and RHS of momentum equation + REAL(wp), DIMENSION(jpi,jpj,jpt) , INTENT(in ) :: puu_b, pvv_b ! barotropic velocities at main time levels + REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: pu_RHSi, pv_RHSi ! baroclinic part of the barotropic RHS + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pCdU_u , pCdU_v ! barotropic drag coefficients + ! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ikbu, ikbv, iktu, iktv + REAL(wp) :: zztmp + REAL(wp), DIMENSION(jpi,jpj) :: zu_i, zv_i + !!---------------------------------------------------------------------- + ! + ! !== Set the barotropic drag coef. ==! + ! + IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! top+bottom friction (ocean cavities) + + DO_2D( 0, 0, 0, 0 ) + pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) + pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) + END_2D + ELSE ! bottom friction only + DO_2D( 0, 0, 0, 0 ) + pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) + pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) + END_2D + ENDIF + ! + ! !== BOTTOM stress contribution from baroclinic velocities ==! + ! + IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW bottom baroclinic velocities + + DO_2D( 0, 0, 0, 0 ) + ikbu = mbku(ji,jj) + ikbv = mbkv(ji,jj) + zu_i(ji,jj) = puu(ji,jj,ikbu,Kmm) - puu_b(ji,jj,Kmm) + zv_i(ji,jj) = pvv(ji,jj,ikbv,Kmm) - pvv_b(ji,jj,Kmm) + END_2D + ELSE ! CENTRED integration: use BEFORE bottom baroclinic velocities + + DO_2D( 0, 0, 0, 0 ) + ikbu = mbku(ji,jj) + ikbv = mbkv(ji,jj) + zu_i(ji,jj) = puu(ji,jj,ikbu,Kbb) - puu_b(ji,jj,Kbb) + zv_i(ji,jj) = pvv(ji,jj,ikbv,Kbb) - pvv_b(ji,jj,Kbb) + END_2D + ENDIF + ! + IF( ln_wd_il ) THEN ! W/D : use the "clipped" bottom friction !!gm explain WHY, please ! + zztmp = -1._wp / rDt_e + DO_2D( 0, 0, 0, 0 ) + pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) * wdrampu(ji,jj) * MAX( & + & r1_hu(ji,jj,Kmm) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) , zztmp ) + pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + zv_i(ji,jj) * wdrampv(ji,jj) * MAX( & + & r1_hv(ji,jj,Kmm) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) , zztmp ) + END_2D + ELSE ! use "unclipped" drag (even if explicit friction is used in 3D calculation) + + DO_2D( 0, 0, 0, 0 ) + pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu(ji,jj,Kmm) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj) + pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv(ji,jj,Kmm) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj) + END_2D + END IF + ! + ! !== TOP stress contribution from baroclinic velocities ==! (no W/D case) + ! + IF( ln_isfcav.OR.ln_drgice_imp ) THEN + ! + IF( ln_bt_fw ) THEN ! FORWARD integration: use NOW top baroclinic velocity + + DO_2D( 0, 0, 0, 0 ) + iktu = miku(ji,jj) + iktv = mikv(ji,jj) + zu_i(ji,jj) = puu(ji,jj,iktu,Kmm) - puu_b(ji,jj,Kmm) + zv_i(ji,jj) = pvv(ji,jj,iktv,Kmm) - pvv_b(ji,jj,Kmm) + END_2D + ELSE ! CENTRED integration: use BEFORE top baroclinic velocity + + DO_2D( 0, 0, 0, 0 ) + iktu = miku(ji,jj) + iktv = mikv(ji,jj) + zu_i(ji,jj) = puu(ji,jj,iktu,Kbb) - puu_b(ji,jj,Kbb) + zv_i(ji,jj) = pvv(ji,jj,iktv,Kbb) - pvv_b(ji,jj,Kbb) + END_2D + ENDIF + ! + ! ! use "unclipped" top drag (even if explicit friction is used in 3D calculation) + + DO_2D( 0, 0, 0, 0 ) + pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu(ji,jj,Kmm) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj) + pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv(ji,jj,Kmm) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj) + END_2D + ! + ENDIF + ! + END SUBROUTINE dyn_drg_init + + SUBROUTINE ts_bck_interp( jn, ll_init, & ! <== in + & za0, za1, za2, za3 ) ! ==> out + !!---------------------------------------------------------------------- + INTEGER ,INTENT(in ) :: jn ! index of sub time step + LOGICAL ,INTENT(in ) :: ll_init ! + REAL(wp),INTENT( out) :: za0, za2, za3! Half-step back interpolation coefficient + REAL(dp),INTENT( out) :: za1! Half-step back interpolation coefficient + ! + REAL(wp) :: zepsilon, zgamma ! - - + !!---------------------------------------------------------------------- + ! ! set Half-step back interpolation coefficient + IF ( jn==1 .AND. ll_init ) THEN !* Forward-backward + za0 = 1._wp + za1 = 0._wp + za2 = 0._wp + za3 = 0._wp + ELSEIF( jn==2 .AND. ll_init ) THEN !* AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/12 + za0 = 1.0833333333333_wp ! za0 = 1-gam-eps + za1 =-0.1666666666666_wp ! za1 = gam + za2 = 0.0833333333333_wp ! za2 = eps + za3 = 0._wp + ELSE !* AB3-AM4 Coefficients; bet=0.281105 ; eps=0.013 ; gam=0.0880 + IF( rn_bt_alpha == 0._wp ) THEN ! Time diffusion + za0 = 0.614_wp ! za0 = 1/2 + gam + 2*eps + za1 = 0.285_wp ! za1 = 1/2 - 2*gam - 3*eps + za2 = 0.088_wp ! za2 = gam + za3 = 0.013_wp ! za3 = eps + ELSE ! no time diffusion + zepsilon = 0.00976186_wp - 0.13451357_wp * rn_bt_alpha + zgamma = 0.08344500_wp - 0.51358400_wp * rn_bt_alpha + za0 = 0.5_wp + zgamma + 2._wp * rn_bt_alpha + 2._wp * zepsilon + za1 = 1._wp - za0 - zgamma - zepsilon + za2 = zgamma + za3 = zepsilon + ENDIF + ENDIF + END SUBROUTINE ts_bck_interp + + + !!====================================================================== +END MODULE dynspg_ts diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynvor.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynvor.F90 new file mode 100644 index 0000000..a0c1140 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynvor.F90 @@ -0,0 +1,1080 @@ +MODULE dynvor + !!====================================================================== + !! *** MODULE dynvor *** + !! Ocean dynamics: Update the momentum trend with the relative and + !! planetary vorticity trends + !!====================================================================== + !! History : OPA ! 1989-12 (P. Andrich) vor_ens: Original code + !! 5.0 ! 1991-11 (G. Madec) vor_ene, vor_mix: Original code + !! 6.0 ! 1996-01 (G. Madec) s-coord, suppress work arrays + !! NEMO 0.5 ! 2002-08 (G. Madec) F90: Free form and module + !! 1.0 ! 2004-02 (G. Madec) vor_een: Original code + !! - ! 2003-08 (G. Madec) add vor_ctl + !! - ! 2005-11 (G. Madec) add dyn_vor (new step architecture) + !! 2.0 ! 2006-11 (G. Madec) flux form advection: add metric term + !! 3.2 ! 2009-04 (R. Benshila) vvl: correction of een scheme + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.7 ! 2014-04 (G. Madec) trend simplification: suppress jpdyn_trd_dat vorticity + !! - ! 2014-06 (G. Madec) suppression of velocity curl from in-core memory + !! - ! 2016-12 (G. Madec, E. Clementi) add Stokes-Coriolis trends (ln_stcor=T) + !! 4.0 ! 2017-07 (G. Madec) linear dynamics + trends diag. with Stokes-Coriolis + !! - ! 2018-03 (G. Madec) add two new schemes (ln_dynvor_enT and ln_dynvor_eet) + !! - ! 2018-04 (G. Madec) add pre-computed gradient for metric term calculation + !! 4.x ! 2020-03 (G. Madec, A. Nasser) make ln_dynvor_msk truly efficient on relative vorticity + !! 4.2 ! 2020-12 (G. Madec, E. Clementi) add vortex force trends (ln_vortex_force=T) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_vor : Update the momentum trend with the vorticity trend + !! vor_enT : energy conserving scheme at T-pt (ln_dynvor_enT=T) + !! vor_ene : energy conserving scheme (ln_dynvor_ene=T) + !! vor_ens : enstrophy conserving scheme (ln_dynvor_ens=T) + !! vor_een : energy and enstrophy conserving (ln_dynvor_een=T) + !! vor_eeT : energy conserving at T-pt (ln_dynvor_eeT=T) + !! dyn_vor_init : set and control of the different vorticity option + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE dommsk ! ocean mask + USE dynadv ! momentum advection + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + USE sbcwave ! Surface Waves (add Stokes-Coriolis force) + USE sbc_oce, ONLY : ln_stcor, ln_vortex_force ! use Stoke-Coriolis force + ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_vor ! routine called by step.F90 + PUBLIC dyn_vor_init ! routine called by nemogcm.F90 + + ! !!* Namelist namdyn_vor: vorticity term + LOGICAL, PUBLIC :: ln_dynvor_ens !: enstrophy conserving scheme (ENS) + LOGICAL, PUBLIC :: ln_dynvor_ene !: f-point energy conserving scheme (ENE) + LOGICAL, PUBLIC :: ln_dynvor_enT !: t-point energy conserving scheme (ENT) + LOGICAL, PUBLIC :: ln_dynvor_eeT !: t-point energy conserving scheme (EET) + LOGICAL, PUBLIC :: ln_dynvor_een !: energy & enstrophy conserving scheme (EEN) + LOGICAL, PUBLIC :: ln_dynvor_mix !: mixed scheme (MIX) + LOGICAL, PUBLIC :: ln_dynvor_msk !: vorticity multiplied by fmask (=T) or not (=F) (all vorticity schemes) + INTEGER, PUBLIC :: nn_e3f_typ !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) + + INTEGER, PUBLIC :: nvor_scheme !: choice of the type of advection scheme + ! ! associated indices: + INTEGER, PUBLIC, PARAMETER :: np_ENS = 0 ! ENS scheme + INTEGER, PUBLIC, PARAMETER :: np_ENE = 1 ! ENE scheme + INTEGER, PUBLIC, PARAMETER :: np_ENT = 2 ! ENT scheme (t-point vorticity) + INTEGER, PUBLIC, PARAMETER :: np_EET = 3 ! EET scheme (EEN using e3t) + INTEGER, PUBLIC, PARAMETER :: np_EEN = 4 ! EEN scheme + INTEGER, PUBLIC, PARAMETER :: np_MIX = 5 ! MIX scheme + + INTEGER :: ncor, nrvm, ntot ! choice of calculated vorticity + ! ! associated indices: + INTEGER, PUBLIC, PARAMETER :: np_COR = 1 ! Coriolis (planetary) + INTEGER, PUBLIC, PARAMETER :: np_RVO = 2 ! relative vorticity + INTEGER, PUBLIC, PARAMETER :: np_MET = 3 ! metric term + INTEGER, PUBLIC, PARAMETER :: np_CRV = 4 ! relative + planetary (total vorticity) + INTEGER, PUBLIC, PARAMETER :: np_CME = 5 ! Coriolis + metric term + + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2u_2 ! = di(e2u)/2 used in T-point metric term calculation + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1v_2 ! = dj(e1v)/2 - - - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2v_2e1e2f ! = di(e2u)/(2*e1e2f) used in F-point metric term calculation + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1v)/(2*e1e2f) - - - - + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: e3f_0vor ! e3f used in EEN, ENE and ENS cases (key_qco only) + + REAL(wp) :: r1_4 = 0.250_wp ! =1/4 + REAL(wp) :: r1_8 = 0.125_wp ! =1/8 + REAL(wp) :: r1_12 = 1._wp / 12._wp ! 1/12 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynvor.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_vor( kt, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! + !! ** Purpose : compute the lateral ocean tracer physics. + !! + !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now vorticity term trend + !! - save the trends in (ztrdu,ztrdv) in 2 parts (relative + !! and planetary vorticity trends) and send them to trd_dyn + !! for futher diagnostics (l_trddyn=T) + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocity field and RHS of momentum equation + ! + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_vor') + ! + IF( l_trddyn ) THEN !== trend diagnostics case : split the added trend in two parts ==! + ! + ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) ) + ! + ztrdu(:,:,:) = puu(:,:,:,Krhs) !* planetary vorticity trend + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + SELECT CASE( nvor_scheme ) + CASE( np_ENS ) ; CALL vor_ens( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! enstrophy conserving scheme + CASE( np_ENE, np_MIX ) ; CALL vor_ene( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme + CASE( np_ENT ) ; CALL vor_enT( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme (T-pts) + CASE( np_EET ) ; CALL vor_eeT( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme (een with e3t) + CASE( np_EEN ) ; CALL vor_een( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy & enstrophy scheme + END SELECT + ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt, Kmm ) + ! + IF( n_dynadv /= np_LIN_dyn ) THEN !* relative vorticity or metric trend (only in non-linear case) + ztrdu(:,:,:) = puu(:,:,:,Krhs) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + SELECT CASE( nvor_scheme ) + CASE( np_ENT ) ; CALL vor_enT( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme (T-pts) + CASE( np_EET ) ; CALL vor_eeT( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme (een with e3t) + CASE( np_ENE ) ; CALL vor_ene( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme + CASE( np_ENS, np_MIX ) ; CALL vor_ens( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! enstrophy conserving scheme + CASE( np_EEN ) ; CALL vor_een( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy & enstrophy scheme + END SELECT + ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt, Kmm ) + ENDIF + ! + DEALLOCATE( ztrdu, ztrdv ) + ! + ELSE !== total vorticity trend added to the general trend ==! + ! + SELECT CASE ( nvor_scheme ) !== vorticity trend added to the general trend ==! + CASE( np_ENT ) !* energy conserving scheme (T-pts) + CALL vor_enT( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend + IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN + CALL vor_enT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend + ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN + CALL vor_enT( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force + ENDIF + CASE( np_EET ) !* energy conserving scheme (een scheme using e3t) + CALL vor_eeT( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend + IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN + CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend + ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN + CALL vor_eeT( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force + ENDIF + CASE( np_ENE ) !* energy conserving scheme + CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend + IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN + CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend + ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN + CALL vor_ene( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force + ENDIF + CASE( np_ENS ) !* enstrophy conserving scheme + CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend + + IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN + CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend + ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN + CALL vor_ens( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force + ENDIF + CASE( np_MIX ) !* mixed ene-ens scheme + CALL vor_ens( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! relative vorticity or metric trend (ens) + CALL vor_ene( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! planetary vorticity trend (ene) + IF( ln_stcor ) CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend + IF( ln_vortex_force ) CALL vor_ens( kt, Kmm, nrvm, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add vortex force + CASE( np_EEN ) !* energy and enstrophy conserving scheme + CALL vor_een( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend + IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN + CALL vor_een( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend + ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN + CALL vor_een( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force + ENDIF + END SELECT + ! + ENDIF + ! + ! ! print sum trends (used for debugging) + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' vor - Ua: ', mask1=umask, & + & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_vor') + ! + END SUBROUTINE dyn_vor + + + SUBROUTINE vor_enT( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE vor_enT *** + !! + !! ** Purpose : Compute the now total vorticity trend and add it to + !! the general trend of the momentum equation. + !! + !! ** Method : Trend evaluated using now fields (centered in time) + !! and t-point evaluation of vorticity (planetary and relative). + !! conserves the horizontal kinetic energy. + !! The general trend of momentum is increased due to the vorticity + !! term which is given by: + !! voru = 1/bu mj[ ( mi(mj(bf*rvor))+bt*f_t)/e3t mj[vn] ] + !! vorv = 1/bv mi[ ( mi(mj(bf*rvor))+bt*f_t)/e3f mj[un] ] + !! where rvor is the relative vorticity at f-point + !! + !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx, zwy, zwt ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwz ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:vor_enT : vorticity term: t-point energy conserving scheme' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! + SELECT CASE( kvor ) !== relative vorticity considered ==! + ! + CASE ( np_RVO , np_CRV ) !* relative vorticity at f-point is used + ALLOCATE( zwz(A2D(nn_hls),jpk) ) + DO jk = 1, jpkm1 ! Horizontal slab + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj,jk) = ( e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END_2D + IF( ln_dynvor_msk ) THEN ! mask relative vorticity + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) + END_2D + ENDIF + END DO + IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) + ! + END SELECT + + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + SELECT CASE( kvor ) !== volume weighted vorticity considered ==! + ! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + DO_2D( 0, 1, 0, 1 ) + zwt(ji,jj) = ff_t(ji,jj) * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) + END_2D + CASE ( np_RVO ) !* relative vorticity + DO_2D( 0, 1, 0, 1 ) + zwt(ji,jj) = r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) & + & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) & + & * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) + END_2D + CASE ( np_MET ) !* metric term + DO_2D( 0, 1, 0, 1 ) + zwt(ji,jj) = ( ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & + & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) & + & * e3t(ji,jj,jk,Kmm) + END_2D + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO_2D( 0, 1, 0, 1 ) + zwt(ji,jj) = ( ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) & + & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) ) & + & * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) + END_2D + CASE ( np_CME ) !* Coriolis + metric + DO_2D( 0, 1, 0, 1 ) + zwt(ji,jj) = ( ff_t(ji,jj) * e1e2t(ji,jj) & + & + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & + & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) & + & * e3t(ji,jj,jk,Kmm) + END_2D + CASE DEFAULT ! error + CALL ctl_stop('STOP','dyn_vor: wrong value for kvor') + END SELECT + ! + ! !== compute and add the vorticity term trend =! + DO_2D( 0, 0, 0, 0 ) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & + & * ( zwt(ji+1,jj) * ( pv(ji+1,jj,jk) + pv(ji+1,jj-1,jk) ) & + & + zwt(ji ,jj) * ( pv(ji ,jj,jk) + pv(ji ,jj-1,jk) ) ) + ! + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) & + & * ( zwt(ji,jj+1) * ( pu(ji,jj+1,jk) + pu(ji-1,jj+1,jk) ) & + & + zwt(ji,jj ) * ( pu(ji,jj ,jk) + pu(ji-1,jj ,jk) ) ) + END_2D + ! ! =============== + END DO ! End of slab + ! ! =============== + ! + SELECT CASE( kvor ) ! deallocate zwz if necessary + CASE ( np_RVO , np_CRV ) ; DEALLOCATE( zwz ) + END SELECT + ! + END SUBROUTINE vor_enT + + + SUBROUTINE vor_ene( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE vor_ene *** + !! + !! ** Purpose : Compute the now total vorticity trend and add it to + !! the general trend of the momentum equation. + !! + !! ** Method : Trend evaluated using now fields (centered in time) + !! and the Sadourny (1975) flux form formulation : conserves the + !! horizontal kinetic energy. + !! The general trend of momentum is increased due to the vorticity + !! term which is given by: + !! voru = 1/e1u mj-1[ (rvor+f)/e3f mi(e1v*e3v pvv(:,:,:,Kmm)) ] + !! vorv = 1/e2v mi-1[ (rvor+f)/e3f mj(e2u*e3u puu(:,:,:,Kmm)) ] + !! where rvor is the relative vorticity + !! + !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend + !! + !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zx1, zy1, zx2, zy2, ze3f, zmsk ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx, zwy, zwz ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:vor_ene : vorticity term: energy conserving scheme' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + SELECT CASE( kvor ) !== vorticity considered ==! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + DO_2D( 1, 0, 1, 0 ) + zwz(ji,jj) = ff_f(ji,jj) + END_2D + CASE ( np_RVO ) !* relative vorticity + DO_2D( 1, 0, 1, 0 ) + zwz(ji,jj) = ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END_2D + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity + DO_2D( 1, 0, 1, 0 ) + zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) + END_2D + ENDIF + CASE ( np_MET ) !* metric term + DO_2D( 1, 0, 1, 0 ) + zwz(ji,jj) = ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END_2D + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO_2D( 1, 0, 1, 0 ) + zwz(ji,jj) = ff_f(ji,jj) + ( e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END_2D + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity (NOT the Coriolis term) + DO_2D( 1, 0, 1, 0 ) + zwz(ji,jj) = ( zwz(ji,jj) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) + END_2D + ENDIF + CASE ( np_CME ) !* Coriolis + metric + DO_2D( 1, 0, 1, 0 ) + zwz(ji,jj) = ff_f(ji,jj) + ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END_2D + CASE DEFAULT ! error + CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' ) + END SELECT + ! +#if defined key_qco || defined key_linssh + DO_2D( 1, 0, 1, 0 ) !== potential vorticity ==! (key_qco) + zwz(ji,jj) = zwz(ji,jj) / e3f_vor(ji,jj,jk) + END_2D +#else + SELECT CASE( nn_e3f_typ ) !== potential vorticity ==! + CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) + DO_2D( 1, 0, 1, 0 ) + ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & + & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & + & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & + & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) + IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * 4._wp / ze3f + ELSE ; zwz(ji,jj) = 0._wp + ENDIF + END_2D + CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) + DO_2D( 1, 0, 1, 0 ) + ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & + & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & + & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & + & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) + zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & + & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) ) + IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * zmsk / ze3f + ELSE ; zwz(ji,jj) = 0._wp + ENDIF + END_2D + END SELECT +#endif + ! !== horizontal fluxes ==! + DO_2D( 1, 1, 1, 1 ) + zwx(ji,jj) = e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * pu(ji,jj,jk) + zwy(ji,jj) = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * pv(ji,jj,jk) + END_2D + ! + ! !== compute and add the vorticity term trend =! + DO_2D( 0, 0, 0, 0 ) + zy1 = zwy(ji,jj-1) + zwy(ji+1,jj-1) + zy2 = zwy(ji,jj ) + zwy(ji+1,jj ) + zx1 = zwx(ji-1,jj) + zwx(ji-1,jj+1) + zx2 = zwx(ji ,jj) + zwx(ji ,jj+1) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) + END_2D + ! ! =============== + END DO ! End of slab + ! ! =============== + END SUBROUTINE vor_ene + + + SUBROUTINE vor_ens( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE vor_ens *** + !! + !! ** Purpose : Compute the now total vorticity trend and add it to + !! the general trend of the momentum equation. + !! + !! ** Method : Trend evaluated using now fields (centered in time) + !! and the Sadourny (1975) flux FORM formulation : conserves the + !! potential enstrophy of a horizontally non-divergent flow. the + !! trend of the vorticity term is given by: + !! voru = 1/e1u mj-1[ (rvor+f)/e3f ] mj-1[ mi(e1v*e3v pvv(:,:,:,Kmm)) ] + !! vorv = 1/e2v mi-1[ (rvor+f)/e3f ] mi-1[ mj(e2u*e3u puu(:,:,:,Kmm)) ] + !! Add this trend to the general momentum trend: + !! (u(rhs),v(Krhs)) = (u(rhs),v(Krhs)) + ( voru , vorv ) + !! + !! ** Action : - Update (pu_rhs,pv_rhs)) arrays with the now vorticity term trend + !! + !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zuav, zvau, ze3f, zmsk ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx, zwy, zwz ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:vor_ens : vorticity term: enstrophy conserving scheme' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ENDIF + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + SELECT CASE( kvor ) !== vorticity considered ==! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + DO_2D( 1, 0, 1, 0 ) + zwz(ji,jj) = ff_f(ji,jj) + END_2D + CASE ( np_RVO ) !* relative vorticity + DO_2D( 1, 0, 1, 0 ) + zwz(ji,jj) = ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END_2D + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity + DO_2D( 1, 0, 1, 0 ) + zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) + END_2D + ENDIF + CASE ( np_MET ) !* metric term + DO_2D( 1, 0, 1, 0 ) + zwz(ji,jj) = ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END_2D + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO_2D( 1, 0, 1, 0 ) + zwz(ji,jj) = ff_f(ji,jj) + ( e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END_2D + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity (NOT the Coriolis term) + DO_2D( 1, 0, 1, 0 ) + zwz(ji,jj) = ( zwz(ji,jj) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) + END_2D + ENDIF + CASE ( np_CME ) !* Coriolis + metric + DO_2D( 1, 0, 1, 0 ) + zwz(ji,jj) = ff_f(ji,jj) + ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END_2D + CASE DEFAULT ! error + CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' ) + END SELECT + ! + ! +#if defined key_qco || defined key_linssh + DO_2D( 1, 0, 1, 0 ) !== potential vorticity ==! (key_qco) + zwz(ji,jj) = zwz(ji,jj) / e3f_vor(ji,jj,jk) + END_2D +#else + SELECT CASE( nn_e3f_typ ) !== potential vorticity ==! + CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) + DO_2D( 1, 0, 1, 0 ) + ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & + & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & + & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & + & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) + IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * 4._wp / ze3f + ELSE ; zwz(ji,jj) = 0._wp + ENDIF + END_2D + CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) + DO_2D( 1, 0, 1, 0 ) + ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & + & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & + & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & + & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) + zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & + & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) ) + IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * zmsk / ze3f + ELSE ; zwz(ji,jj) = 0._wp + ENDIF + END_2D + END SELECT +#endif + ! !== horizontal fluxes ==! + DO_2D( 1, 1, 1, 1 ) + zwx(ji,jj) = e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * pu(ji,jj,jk) + zwy(ji,jj) = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * pv(ji,jj,jk) + END_2D + ! + ! !== compute and add the vorticity term trend =! + DO_2D( 0, 0, 0, 0 ) + zuav = r1_8 * r1_e1u(ji,jj) * ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) & + & + zwy(ji ,jj ) + zwy(ji+1,jj ) ) + zvau =-r1_8 * r1_e2v(ji,jj) * ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) & + & + zwx(ji ,jj ) + zwx(ji ,jj+1) ) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zuav * ( zwz(ji ,jj-1) + zwz(ji,jj) ) + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zvau * ( zwz(ji-1,jj ) + zwz(ji,jj) ) + END_2D + ! ! =============== + END DO ! End of slab + ! ! =============== + END SUBROUTINE vor_ens + + + SUBROUTINE vor_een( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE vor_een *** + !! + !! ** Purpose : Compute the now total vorticity trend and add it to + !! the general trend of the momentum equation. + !! + !! ** Method : Trend evaluated using now fields (centered in time) + !! and the Arakawa and Lamb (1980) flux form formulation : conserves + !! both the horizontal kinetic energy and the potential enstrophy + !! when horizontal divergence is zero (see the NEMO documentation) + !! Add this trend to the general momentum trend (pu_rhs,pv_rhs). + !! + !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend + !! + !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ierr ! local integer + REAL(wp) :: zua, zva ! local scalars + REAL(wp) :: zmsk, ze3f ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: z1_e3f +#if defined key_loop_fusion + REAL(wp) :: ztne, ztnw, ztnw_ip1, ztse, ztse_jp1, ztsw_jp1, ztsw_ip1 + REAL(wp) :: zwx, zwx_im1, zwx_jp1, zwx_im1_jp1 + REAL(wp) :: zwy, zwy_ip1, zwy_jm1, zwy_ip1_jm1 +#else + REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx , zwy + REAL(wp), DIMENSION(A2D(nn_hls)) :: ztnw, ztne, ztsw, ztse +#endif + REAL(wp), DIMENSION(A2D(nn_hls),jpkm1) :: zwz ! 3D workspace, jpkm1 -> jpkm1 -> avoid lbc_lnk on jpk that is not defined + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:vor_een : vorticity term: energy and enstrophy conserving scheme' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! +#if defined key_qco || defined key_linssh + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! == reciprocal of e3 at F-point (key_qco) + z1_e3f(ji,jj) = 1._wp / e3f_vor(ji,jj,jk) + END_2D +#else + SELECT CASE( nn_e3f_typ ) ! == reciprocal of e3 at F-point + CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + ze3f = ( (e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & + & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)) & + & + (e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & + & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk)) ) + IF( ze3f /= 0._wp ) THEN ; z1_e3f(ji,jj) = 4._wp / ze3f + ELSE ; z1_e3f(ji,jj) = 0._wp + ENDIF + END_2D + CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + ze3f = ( (e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & + & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)) & + & + (e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & + & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk)) ) + zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & + & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) ) + IF( ze3f /= 0._wp ) THEN ; z1_e3f(ji,jj) = zmsk / ze3f + ELSE ; z1_e3f(ji,jj) = 0._wp + ENDIF + END_2D + END SELECT +#endif + ! + SELECT CASE( kvor ) !== vorticity considered ==! + ! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj,jk) = ff_f(ji,jj) * z1_e3f(ji,jj) + END_2D + CASE ( np_RVO ) !* relative vorticity + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj,jk) = ( e2v(ji+1,jj ) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & - e1u(ji ,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj)*z1_e3f(ji,jj) + END_2D + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) + END_2D + ENDIF + CASE ( np_MET ) !* metric term + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj,jk) = ( ( pv(ji+1,jj,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) ) * z1_e3f(ji,jj) + END_2D + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zwz(ji,jj,jk) = ( ff_f(ji,jj) + ( ( e2v(ji+1,jj ) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & - ( e1u(ji ,jj+1) * pu(ji,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * r1_e1e2f(ji,jj) ) * z1_e3f(ji,jj) + END_2D + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj,jk) = ( zwz(ji,jj,jk) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) + END_2D + ENDIF + CASE ( np_CME ) !* Coriolis + metric + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj,jk) = ( ff_f(ji,jj) + ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) ) * z1_e3f(ji,jj) + END_2D + CASE DEFAULT ! error + CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' ) + END SELECT + ! ! =============== + END DO ! End of slab + ! ! =============== + ! + IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) + ! + ! ! =============== + ! ! Horizontal slab + ! ! =============== +#if defined key_loop_fusion + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + ! !== horizontal fluxes ==! + zwx = e2u(ji ,jj ) * e3u(ji ,jj ,jk,Kmm) * pu(ji ,jj ,jk) + zwx_im1 = e2u(ji-1,jj ) * e3u(ji-1,jj ,jk,Kmm) * pu(ji-1,jj ,jk) + zwx_jp1 = e2u(ji ,jj+1) * e3u(ji ,jj+1,jk,Kmm) * pu(ji ,jj+1,jk) + zwx_im1_jp1 = e2u(ji-1,jj+1) * e3u(ji-1,jj+1,jk,Kmm) * pu(ji-1,jj+1,jk) + zwy = e1v(ji ,jj ) * e3v(ji ,jj ,jk,Kmm) * pv(ji ,jj ,jk) + zwy_ip1 = e1v(ji+1,jj ) * e3v(ji+1,jj ,jk,Kmm) * pv(ji+1,jj ,jk) + zwy_jm1 = e1v(ji ,jj-1) * e3v(ji ,jj-1,jk,Kmm) * pv(ji ,jj-1,jk) + zwy_ip1_jm1 = e1v(ji+1,jj-1) * e3v(ji+1,jj-1,jk,Kmm) * pv(ji+1,jj-1,jk) + ! !== compute and add the vorticity term trend =! + ztne = zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + ztnw = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + ztnw_ip1 = zwz(ji ,jj-1,jk) + zwz(ji ,jj ,jk) + zwz(ji+1,jj ,jk) + ztse = zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + ztse_jp1 = zwz(ji ,jj+1,jk) + zwz(ji ,jj ,jk) + zwz(ji-1,jj ,jk) + ztsw_jp1 = zwz(ji ,jj ,jk) + zwz(ji-1,jj ,jk) + zwz(ji-1,jj+1,jk) + ztsw_ip1 = zwz(ji+1,jj-1,jk) + zwz(ji ,jj-1,jk) + zwz(ji ,jj ,jk) + ! + zua = + r1_12 * r1_e1u(ji,jj) * ( ztne * zwy + ztnw_ip1 * zwy_ip1 & + & + ztse * zwy_jm1 + ztsw_ip1 * zwy_ip1_jm1 ) + zva = - r1_12 * r1_e2v(ji,jj) * ( ztsw_jp1 * zwx_im1_jp1 + ztse_jp1 * zwx_jp1 & + & + ztnw * zwx_im1 + ztne * zwx ) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zua + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zva + END_3D +#else + DO jk = 1, jpkm1 + ! + ! !== horizontal fluxes ==! + DO_2D( 1, 1, 1, 1 ) + zwx(ji,jj) = e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * pu(ji,jj,jk) + zwy(ji,jj) = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * pv(ji,jj,jk) + END_2D + ! + ! !== compute and add the vorticity term trend =! + DO_2D( 0, 1, 0, 1 ) + ztne(ji,jj) = zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + ztnw(ji,jj) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + ztse(ji,jj) = zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + ztsw(ji,jj) = zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + END_2D + ! + DO_2D( 0, 0, 0, 0 ) + zua = + r1_12 * r1_e1u(ji,jj) * ( ztne(ji,jj ) * zwy(ji ,jj ) + ztnw(ji+1,jj) * zwy(ji+1,jj ) & + & + ztse(ji,jj ) * zwy(ji ,jj-1) + ztsw(ji+1,jj) * zwy(ji+1,jj-1) ) + zva = - r1_12 * r1_e2v(ji,jj) * ( ztsw(ji,jj+1) * zwx(ji-1,jj+1) + ztse(ji,jj+1) * zwx(ji ,jj+1) & + & + ztnw(ji,jj ) * zwx(ji-1,jj ) + ztne(ji,jj ) * zwx(ji ,jj ) ) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zua + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zva + END_2D + END DO +#endif + ! ! =============== + ! ! End of slab + ! ! =============== + END SUBROUTINE vor_een + + + SUBROUTINE vor_eeT( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE vor_eeT *** + !! + !! ** Purpose : Compute the now total vorticity trend and add it to + !! the general trend of the momentum equation. + !! + !! ** Method : Trend evaluated using now fields (centered in time) + !! and the Arakawa and Lamb (1980) vector form formulation using + !! a modified version of Arakawa and Lamb (1980) scheme (see vor_een). + !! The change consists in + !! Add this trend to the general momentum trend (pu_rhs,pv_rhs). + !! + !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend + !! + !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ierr ! local integer + REAL(wp) :: zua, zva ! local scalars + REAL(wp) :: zmsk, z1_e3t ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zwx , zwy + REAL(wp), DIMENSION(A2D(nn_hls)) :: ztnw, ztne, ztsw, ztse + REAL(wp), DIMENSION(A2D(nn_hls),jpkm1) :: zwz ! 3D workspace, avoid lbc_lnk on jpk that is not defined + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:vor_eeT : vorticity term: energy and enstrophy conserving scheme' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ENDIF + ! + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + ! + SELECT CASE( kvor ) !== vorticity considered ==! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj,jk) = ff_f(ji,jj) + END_2D + CASE ( np_RVO ) !* relative vorticity + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zwz(ji,jj,jk) = ( (e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk)) & + & - (e1u(ji ,jj+1) * pu(ji ,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk)) ) & + & * r1_e1e2f(ji,jj) + END_2D + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) + END_2D + ENDIF + CASE ( np_MET ) !* metric term + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj,jk) = ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END_2D + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zwz(ji,jj,jk) = ( ff_f(ji,jj) + ( (e2v(ji+1,jj ) * pv(ji+1,jj ,jk) - e2v(ji,jj) * pv(ji,jj,jk)) & + & - (e1u(ji ,jj+1) * pu(ji ,jj+1,jk) - e1u(ji,jj) * pu(ji,jj,jk)) ) & + & * r1_e1e2f(ji,jj) ) + END_2D + IF( ln_dynvor_msk ) THEN ! mask the relative vorticity + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj,jk) = ( zwz(ji,jj,jk) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) + END_2D + ENDIF + CASE ( np_CME ) !* Coriolis + metric + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj,jk) = ff_f(ji,jj) + ( pv(ji+1,jj ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pu(ji ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END_2D + CASE DEFAULT ! error + CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' ) + END SELECT + ! + ! ! =============== + END DO ! End of slab + ! ! =============== + ! + IF (nn_hls==1) CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) + ! + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + ! !== horizontal fluxes ==! + DO_2D( 1, 1, 1, 1 ) + zwx(ji,jj) = e2u(ji,jj) * e3u(ji,jj,jk,Kmm) * pu(ji,jj,jk) + zwy(ji,jj) = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) * pv(ji,jj,jk) + END_2D + ! + ! !== compute and add the vorticity term trend =! + DO_2D( 0, 1, 0, 1 ) + z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) + ztne(ji,jj) = ( zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) ) * z1_e3t + ztnw(ji,jj) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) ) * z1_e3t + ztse(ji,jj) = ( zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) ) * z1_e3t + ztsw(ji,jj) = ( zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) ) * z1_e3t + END_2D + ! + DO_2D( 0, 0, 0, 0 ) + zua = + r1_12 * r1_e1u(ji,jj) * ( ztne(ji,jj ) * zwy(ji ,jj ) + ztnw(ji+1,jj) * zwy(ji+1,jj ) & + & + ztse(ji,jj ) * zwy(ji ,jj-1) + ztsw(ji+1,jj) * zwy(ji+1,jj-1) ) + zva = - r1_12 * r1_e2v(ji,jj) * ( ztsw(ji,jj+1) * zwx(ji-1,jj+1) + ztse(ji,jj+1) * zwx(ji ,jj+1) & + & + ztnw(ji,jj ) * zwx(ji-1,jj ) + ztne(ji,jj ) * zwx(ji ,jj ) ) + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zua + pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zva + END_2D + ! ! =============== + END DO ! End of slab + ! ! =============== + END SUBROUTINE vor_eeT + + + SUBROUTINE dyn_vor_init + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_vor_init *** + !! + !! ** Purpose : Control the consistency between cpp options for + !! tracer advection schemes + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ioptio, ios ! local integer + REAL(wp) :: zmsk ! local scalars + !! + NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_enT, ln_dynvor_eeT, & + & ln_dynvor_een, nn_e3f_typ , ln_dynvor_mix, ln_dynvor_msk + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_vor_init : vorticity term : read namelist and control the consistency' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + READ ( numnam_ref, namdyn_vor, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_vor in reference namelist' ) + READ ( numnam_cfg, namdyn_vor, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_vor in configuration namelist' ) + IF(lwm) WRITE ( numond, namdyn_vor ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) ' Namelist namdyn_vor : choice of the vorticity term scheme' + WRITE(numout,*) ' enstrophy conserving scheme ln_dynvor_ens = ', ln_dynvor_ens + WRITE(numout,*) ' f-point energy conserving scheme ln_dynvor_ene = ', ln_dynvor_ene + WRITE(numout,*) ' t-point energy conserving scheme ln_dynvor_enT = ', ln_dynvor_enT + WRITE(numout,*) ' energy conserving scheme (een using e3t) ln_dynvor_eeT = ', ln_dynvor_eeT + WRITE(numout,*) ' enstrophy and energy conserving scheme ln_dynvor_een = ', ln_dynvor_een + WRITE(numout,*) ' e3f = averaging /4 (=0) or /sum(tmask) (=1) nn_e3f_typ = ', nn_e3f_typ + WRITE(numout,*) ' mixed enstrophy/energy conserving scheme ln_dynvor_mix = ', ln_dynvor_mix + WRITE(numout,*) ' masked (=T) or unmasked(=F) vorticity ln_dynvor_msk = ', ln_dynvor_msk + ENDIF + +!!gm this should be removed when choosing a unique strategy for fmask at the coast + ! If energy, enstrophy or mixed advection of momentum in vector form change the value for masks + ! at angles with three ocean points and one land point + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' change fmask value in the angles (T) ln_vorlat = ', ln_vorlat + IF( ln_vorlat .AND. ( ln_dynvor_ene .OR. ln_dynvor_ens .OR. ln_dynvor_mix ) ) THEN + DO_3D( 1, 0, 1, 0, 1, jpk ) + IF( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & + & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) == 3._wp ) fmask(ji,jj,jk) = 1._wp + END_3D + ! + CALL lbc_lnk( 'dynvor', fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask + ! + ENDIF +!!gm end + + ioptio = 0 ! type of scheme for vorticity (set nvor_scheme) + IF( ln_dynvor_ens ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENS ; ENDIF + IF( ln_dynvor_ene ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENE ; ENDIF + IF( ln_dynvor_enT ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_ENT ; ENDIF + IF( ln_dynvor_eeT ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_EET ; ENDIF + IF( ln_dynvor_een ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_EEN ; ENDIF + IF( ln_dynvor_mix ) THEN ; ioptio = ioptio + 1 ; nvor_scheme = np_MIX ; ENDIF + ! + IF( ioptio /= 1 ) CALL ctl_stop( ' use ONE and ONLY one vorticity scheme' ) + ! + IF(lwp) WRITE(numout,*) ! type of calculated vorticity (set ncor, nrvm, ntot) + ncor = np_COR ! planetary vorticity + SELECT CASE( n_dynadv ) + CASE( np_LIN_dyn ) + IF(lwp) WRITE(numout,*) ' ==>>> linear dynamics : total vorticity = Coriolis' + nrvm = np_COR ! planetary vorticity + ntot = np_COR ! - - + CASE( np_VEC_c2 ) + IF(lwp) WRITE(numout,*) ' ==>>> vector form dynamics : total vorticity = Coriolis + relative vorticity' + nrvm = np_RVO ! relative vorticity + ntot = np_CRV ! relative + planetary vorticity + CASE( np_FLX_c2 , np_FLX_ubs ) + IF(lwp) WRITE(numout,*) ' ==>>> flux form dynamics : total vorticity = Coriolis + metric term' + nrvm = np_MET ! metric term + ntot = np_CME ! Coriolis + metric term + ! + SELECT CASE( nvor_scheme ) ! pre-computed gradients for the metric term: + CASE( np_ENT ) !* T-point metric term : pre-compute di(e2u)/2 and dj(e1v)/2 + ALLOCATE( di_e2u_2(jpi,jpj), dj_e1v_2(jpi,jpj) ) + DO_2D( 0, 0, 0, 0 ) + di_e2u_2(ji,jj) = ( e2u(ji,jj) - e2u(ji-1,jj ) ) * 0.5_wp + dj_e1v_2(ji,jj) = ( e1v(ji,jj) - e1v(ji ,jj-1) ) * 0.5_wp + END_2D + CALL lbc_lnk( 'dynvor', di_e2u_2, 'T', -1.0_wp , dj_e1v_2, 'T', -1.0_wp ) ! Lateral boundary conditions + ! + CASE DEFAULT !* F-point metric term : pre-compute di(e2u)/(2*e1e2f) and dj(e1v)/(2*e1e2f) + ALLOCATE( di_e2v_2e1e2f(jpi,jpj), dj_e1u_2e1e2f(jpi,jpj) ) + DO_2D( 1, 0, 1, 0 ) + di_e2v_2e1e2f(ji,jj) = ( e2v(ji+1,jj ) - e2v(ji,jj) ) * 0.5 * r1_e1e2f(ji,jj) + dj_e1u_2e1e2f(ji,jj) = ( e1u(ji ,jj+1) - e1u(ji,jj) ) * 0.5 * r1_e1e2f(ji,jj) + END_2D + CALL lbc_lnk( 'dynvor', di_e2v_2e1e2f, 'F', -1.0_wp , dj_e1u_2e1e2f, 'F', -1.0_wp ) ! Lateral boundary conditions + END SELECT + ! + END SELECT +#if defined key_qco || defined key_linssh + SELECT CASE( nvor_scheme ) ! qco or linssh cases : pre-computed a specific e3f_0 for some vorticity schemes + CASE( np_ENS , np_ENE , np_EEN , np_MIX ) + ! + ALLOCATE( e3f_0vor(jpi,jpj,jpk) ) + ! + SELECT CASE( nn_e3f_typ ) + CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) + DO_3D( 0, 0, 0, 0, 1, jpk ) + e3f_0vor(ji,jj,jk) = ( e3t_0(ji ,jj+1,jk)*tmask(ji ,jj+1,jk) & + & + e3t_0(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & + & + e3t_0(ji ,jj ,jk)*tmask(ji ,jj ,jk) & + & + e3t_0(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) * 0.25_wp + END_3D + CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) + DO_3D( 0, 0, 0, 0, 1, jpk ) + zmsk = (tmask(ji,jj+1,jk) +tmask(ji+1,jj+1,jk) & + & + tmask(ji,jj ,jk) +tmask(ji+1,jj ,jk) ) + ! + IF( zmsk /= 0._wp ) THEN + e3f_0vor(ji,jj,jk) = ( e3t_0(ji ,jj+1,jk)*tmask(ji ,jj+1,jk) & + & + e3t_0(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & + & + e3t_0(ji ,jj ,jk)*tmask(ji ,jj ,jk) & + & + e3t_0(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) / zmsk + ELSE ; e3f_0vor(ji,jj,jk) = 0._wp + ENDIF + END_3D + END SELECT + ! + CALL lbc_lnk( 'dynvor', e3f_0vor, 'F', 1._wp ) + ! ! insure e3f_0vor /= 0 + WHERE( e3f_0vor(:,:,:) == 0._wp ) e3f_0vor(:,:,:) = e3f_0(:,:,:) + ! + END SELECT + ! +#endif + IF(lwp) THEN ! Print the choice + WRITE(numout,*) + SELECT CASE( nvor_scheme ) + CASE( np_ENS ) ; WRITE(numout,*) ' ==>>> enstrophy conserving scheme (ENS)' + CASE( np_ENE ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (Coriolis at F-points) (ENE)' + CASE( np_ENT ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (Coriolis at T-points) (ENT)' + IF( ln_dynadv_vec ) CALL ctl_warn('dyn_vor_init: ENT scheme may not work in vector form') + CASE( np_EET ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (EEN scheme using e3t) (EET)' + CASE( np_EEN ) ; WRITE(numout,*) ' ==>>> energy and enstrophy conserving scheme (EEN)' + CASE( np_MIX ) ; WRITE(numout,*) ' ==>>> mixed enstrophy/energy conserving scheme (MIX)' + END SELECT + ENDIF + ! + END SUBROUTINE dyn_vor_init + + !!============================================================================== +END MODULE dynvor \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynzad.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynzad.F90 new file mode 100644 index 0000000..e32df40 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynzad.F90 @@ -0,0 +1,128 @@ +MODULE dynzad + !!====================================================================== + !! *** MODULE dynzad *** + !! Ocean dynamics : vertical advection trend + !!====================================================================== + !! History : OPA ! 1991-01 (G. Madec) Original code + !! NEMO 0.5 ! 2002-07 (G. Madec) Free form, F90 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_zad : vertical advection momentum trend + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface boundary condition: ocean + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + USE sbcwave, ONLY: wsd ! Surface Waves (add vertical Stokes-drift) + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE prtctl ! Print control + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_zad ! routine called by dynadv.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynzad.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_zad ( kt, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dynzad *** + !! + !! ** Purpose : Compute the now vertical momentum advection trend and + !! add it to the general trend of momentum equation. + !! + !! ** Method : The now vertical advection of momentum is given by: + !! w dz(u) = u(rhs) + 1/(e1e2u*e3u) mk+1[ mi(e1e2t*ww) dk(u) ] + !! w dz(v) = v(rhs) + 1/(e1e2v*e3v) mk+1[ mj(e1e2t*ww) dk(v) ] + !! Add this trend to the general trend (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)): + !! (u(rhs),v(rhs)) = (u(rhs),v(rhs)) + w dz(u,v) + !! + !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the vert. momentum adv. trends + !! - Send the trends to trddyn for diagnostics (l_trddyn=T) + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step inedx + INTEGER , INTENT( in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zua, zva ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zww + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwuw, zwvw + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_zad') + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_zad : 2nd order vertical advection scheme' + ENDIF + ENDIF + + IF( l_trddyn ) THEN ! Save puu(:,:,:,Krhs) and pvv(:,:,:,Krhs) trends + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = puu(:,:,:,Krhs) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + + DO jk = 2, jpkm1 ! Vertical momentum advection at level w and u- and v- vertical + IF( ln_vortex_force ) THEN ! vertical fluxes + DO_2D( 0, 1, 0, 1 ) + zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * ( ww(ji,jj,jk) + wsd(ji,jj,jk) ) + END_2D + ELSE + DO_2D( 0, 1, 0, 1 ) + zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) + END_2D + ENDIF + DO_2D( 0, 0, 0, 0 ) ! vertical momentum advection at w-point + zwuw(ji,jj,jk) = ( zww(ji+1,jj ) + zww(ji,jj) ) * ( puu(ji,jj,jk-1,Kmm) - puu(ji,jj,jk,Kmm) ) + zwvw(ji,jj,jk) = ( zww(ji ,jj+1) + zww(ji,jj) ) * ( pvv(ji,jj,jk-1,Kmm) - pvv(ji,jj,jk,Kmm) ) + END_2D + END DO + ! + ! Surface and bottom advective fluxes set to zero + DO_2D( 0, 0, 0, 0 ) + zwuw(ji,jj, 1 ) = 0._wp + zwvw(ji,jj, 1 ) = 0._wp + zwuw(ji,jj,jpk) = 0._wp + zwvw(ji,jj,jpk) = 0._wp + END_2D + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Vertical momentum advection at u- and v-points + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) & + & / e3u(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) & + & / e3v(ji,jj,jk,Kmm) + END_3D + + IF( l_trddyn ) THEN ! save the vertical advection trends for diagnostic + ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_zad, kt, Kmm ) + DEALLOCATE( ztrdu, ztrdv ) + ENDIF + ! ! Control print + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' zad - Ua: ', mask1=umask, & + & tab3d_2=pvv(:,:,:,Krhs), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_zad') + ! + END SUBROUTINE dyn_zad + + !!====================================================================== +END MODULE dynzad \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynzdf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynzdf.F90 new file mode 100644 index 0000000..4fd4ef4 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/dynzdf.F90 @@ -0,0 +1,454 @@ +MODULE dynzdf + !!============================================================================== + !! *** MODULE dynzdf *** + !! Ocean dynamics : vertical component of the momentum mixing trend + !!============================================================================== + !! History : 1.0 ! 2005-11 (G. Madec) Original code + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 4.0 ! 2017-06 (G. Madec) remove the explicit time-stepping option + avm at t-point + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_zdf : compute the after velocity through implicit calculation of vertical mixing + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE phycst ! physical constants + USE dom_oce ! ocean space and time domain variables + USE sbc_oce ! surface boundary condition: ocean + USE zdf_oce ! ocean vertical physics variables + USE zdfdrg ! vertical physics: top/bottom drag coef. + USE dynadv ,ONLY: ln_dynadv_vec ! dynamics: advection form +#if defined key_loop_fusion + USE dynldf_iso_lf,ONLY: akzu, akzv ! dynamics: vertical component of rotated lateral mixing +#else + USE dynldf_iso,ONLY: akzu, akzv ! dynamics: vertical component of rotated lateral mixing +#endif + USE ldfdyn ! lateral diffusion: eddy viscosity coef. and type of operator + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE prtctl ! Print control + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_zdf ! routine called by step.F90 + + REAL(wp) :: r_vvl ! non-linear free surface indicator: =0 if ln_linssh=T, =1 otherwise + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: dynzdf.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_zdf( kt, Kbb, Kmm, Krhs, puu, pvv, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_zdf *** + !! + !! ** Purpose : compute the trend due to the vert. momentum diffusion + !! together with the Leap-Frog time stepping using an + !! implicit scheme. + !! + !! ** Method : - Leap-Frog time stepping on all trends but the vertical mixing + !! u(after) = u(before) + 2*dt * u(rhs) vector form or linear free surf. + !! u(after) = ( e3u_b*u(before) + 2*dt * e3u_n*u(rhs) ) / e3u_after otherwise + !! - update the after velocity with the implicit vertical mixing. + !! This requires to solver the following system: + !! u(after) = u(after) + 1/e3u_after dk+1[ mi(avm) / e3uw_after dk[ua] ] + !! with the following surface/top/bottom boundary condition: + !! surface: wind stress input (averaged over kt-1/2 & kt+1/2) + !! top & bottom : top stress (iceshelf-ocean) & bottom stress (cf zdfdrg.F90) + !! + !! ** Action : (puu(:,:,:,Kaa),pvv(:,:,:,Kaa)) after velocity + !!--------------------------------------------------------------------- + INTEGER , INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT( in ) :: Kbb, Kmm, Krhs, Kaa ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! ocean velocities and RHS of momentum equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iku, ikv ! local integers + REAL(wp) :: zzwi, ze3ua, zdt ! local scalars + REAL(wp) :: zzws, ze3va ! - - + REAL(wp) :: z1_e3ua, z1_e3va ! - - + REAL(wp) :: zWu , zWv ! - - + REAL(wp) :: zWui, zWvi ! - - + REAL(wp) :: zWus, zWvs ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwd, zws ! 3D workspace + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv ! - - + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_zdf') + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN !* initialization + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_zdf_imp : vertical momentum diffusion implicit operator' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ ' + ! + If( ln_linssh ) THEN ; r_vvl = 0._wp ! non-linear free surface indicator + ELSE ; r_vvl = 1._wp + ENDIF + ENDIF + ENDIF + ! !* explicit top/bottom drag case + IF( .NOT.ln_drgimp ) CALL zdf_drg_exp( kt, Kmm, puu(:,:,:,Kbb), pvv(:,:,:,Kbb), puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add top/bottom friction trend to (puu(Kaa),pvv(Kaa)) + ! + ! + IF( l_trddyn ) THEN !* temporary save of ta and sa trends + ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = puu(:,:,:,Krhs) + ztrdv(:,:,:) = pvv(:,:,:,Krhs) + ENDIF + ! + ! !== RHS: Leap-Frog time stepping on all trends but the vertical mixing ==! (put in puu(:,:,:,Kaa),pvv(:,:,:,Kaa)) + ! + ! ! time stepping except vertical diffusion + IF( ln_dynadv_vec .OR. ln_linssh ) THEN ! applied on velocity + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kbb) + rDt * puu(ji,jj,jk,Krhs) ) * umask(ji,jj,jk) + pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kbb) + rDt * pvv(ji,jj,jk,Krhs) ) * vmask(ji,jj,jk) + END_3D + ELSE ! applied on thickness weighted velocity + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + puu(ji,jj,jk,Kaa) = ( e3u(ji,jj,jk,Kbb) * puu(ji,jj,jk,Kbb ) & + & + rDt * e3u(ji,jj,jk,Kmm) * puu(ji,jj,jk,Krhs) ) & + & / e3u(ji,jj,jk,Kaa) * umask(ji,jj,jk) + pvv(ji,jj,jk,Kaa) = ( e3v(ji,jj,jk,Kbb) * pvv(ji,jj,jk,Kbb ) & + & + rDt * e3v(ji,jj,jk,Kmm) * pvv(ji,jj,jk,Krhs) ) & + & / e3v(ji,jj,jk,Kaa) * vmask(ji,jj,jk) + END_3D + ENDIF + ! ! add top/bottom friction + ! With split-explicit free surface, barotropic stress is treated explicitly Update velocities at the bottom. + ! J. Chanut: The bottom stress is computed considering after barotropic velocities, which does + ! not lead to the effective stress seen over the whole barotropic loop. + ! G. Madec : in linear free surface, e3u(:,:,:,Kaa) = e3u(:,:,:,Kmm) = e3u_0, so systematic use of e3u(:,:,:,Kaa) + IF( ln_drgimp .AND. ln_dynspg_ts ) THEN + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! remove barotropic velocities + puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kaa) - uu_b(ji,jj,Kaa) ) * umask(ji,jj,jk) + pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - vv_b(ji,jj,Kaa) ) * vmask(ji,jj,jk) + END_3D + DO_2D( 0, 0, 0, 0 ) ! Add bottom/top stress due to barotropic component only + iku = mbku(ji,jj) ! ocean bottom level at u- and v-points + ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points) + ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) & + & + r_vvl * e3u(ji,jj,iku,Kaa) + ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) & + & + r_vvl * e3v(ji,jj,ikv,Kaa) + puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + rDt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * uu_b(ji,jj,Kaa) / ze3ua + pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * vv_b(ji,jj,Kaa) / ze3va + END_2D + IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! Ocean cavities (ISF) + DO_2D( 0, 0, 0, 0 ) + iku = miku(ji,jj) ! top ocean level at u- and v-points + ikv = mikv(ji,jj) ! (first wet ocean u- and v-points) + ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) & + & + r_vvl * e3u(ji,jj,iku,Kaa) + ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) & + & + r_vvl * e3v(ji,jj,ikv,Kaa) + puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + rDt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * uu_b(ji,jj,Kaa) / ze3ua + pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + rDt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * vv_b(ji,jj,Kaa) / ze3va + END_2D + END IF + ENDIF + ! + ! !== Vertical diffusion on u ==! + ! + ! !* Matrix construction + zdt = rDt * 0.5 + IF( ln_zad_Aimp ) THEN !! + SELECT CASE( nldf_dyn ) + CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) & + & + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point + zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) + akzu(ji,jj,jk ) ) & + & / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk ) + zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) ) & + & / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) + zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) / ze3ua + zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua + zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) + zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) + zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) + END_3D + CASE DEFAULT ! iso-level lateral mixing + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) & ! after scale factor at U-point + & + r_vvl * e3u(ji,jj,jk,Kaa) + zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) & + & / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk ) + zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) & + & / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) + zWui = ( wi(ji,jj,jk ) + wi(ji+1,jj,jk ) ) / ze3ua + zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua + zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) + zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) + zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) + END_3D + END SELECT + DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions + zwi(ji,jj,1) = 0._wp + ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) & + & + r_vvl * e3u(ji,jj,1,Kaa) + zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji ,jj,2) ) & + & / ( ze3ua * e3uw(ji,jj,2,Kmm) ) * wumask(ji,jj,2) + zWus = ( wi(ji ,jj,2) + wi(ji+1,jj,2) ) / ze3ua + zws(ji,jj,1 ) = zzws - zdt * MAX( zWus, 0._wp ) + zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWus, 0._wp ) ) + END_2D + ELSE + SELECT CASE( nldf_dyn ) + CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) & + & + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point + zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) + akzu(ji,jj,jk ) ) & + & / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk ) + zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) ) & + & / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) + zwi(ji,jj,jk) = zzwi + zws(ji,jj,jk) = zzws + zwd(ji,jj,jk) = 1._wp - zzwi - zzws + END_3D + CASE DEFAULT ! iso-level lateral mixing + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) & + & + r_vvl * e3u(ji,jj,jk,Kaa) ! after scale factor at U-point + zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) & + & / ( ze3ua * e3uw(ji,jj,jk ,Kmm) ) * wumask(ji,jj,jk ) + zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) & + & / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) + zwi(ji,jj,jk) = zzwi + zws(ji,jj,jk) = zzws + zwd(ji,jj,jk) = 1._wp - zzwi - zzws + END_3D + END SELECT + DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions + zwi(ji,jj,1) = 0._wp + zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) + END_2D + ENDIF + ! + ! + ! !== Apply semi-implicit bottom friction ==! + ! + ! Only needed for semi-implicit bottom friction setup. The explicit + ! bottom friction has been included in "u(v)a" which act as the R.H.S + ! column vector of the tri-diagonal matrix equation + ! + IF ( ln_drgimp ) THEN ! implicit bottom friction + DO_2D( 0, 0, 0, 0 ) + iku = mbku(ji,jj) ! ocean bottom level at u- and v-points + ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) & + & + r_vvl * e3u(ji,jj,iku,Kaa) ! after scale factor at T-point + zwd(ji,jj,iku) = zwd(ji,jj,iku) - rDt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua + END_2D + IF ( ln_isfcav.OR.ln_drgice_imp ) THEN ! top friction (always implicit) + DO_2D( 0, 0, 0, 0 ) + !!gm top Cd is masked (=0 outside cavities) no need of test on mik>=2 ==>> it has been suppressed + iku = miku(ji,jj) ! ocean top level at u- and v-points + ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) & + & + r_vvl * e3u(ji,jj,iku,Kaa) ! after scale factor at T-point + zwd(ji,jj,iku) = zwd(ji,jj,iku) - rDt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / ze3ua + END_2D + END IF + ENDIF + ! + ! Matrix inversion starting from the first level + !----------------------------------------------------------------------- + ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk ) + ! + ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 ) + ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 ) + ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 ) + ! ( ... )( ... ) ( ... ) + ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk ) + ! + ! m is decomposed in the product of an upper and a lower triangular matrix + ! The 3 diagonal terms are in 2d arrays: zwd, zws, zwi + ! The solution (the after velocity) is in puu(:,:,:,Kaa) + !----------------------------------------------------------------------- + ! + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) == + zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) + END_3D + ! + DO_2D( 0, 0, 0, 0 ) !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==! + ze3ua = ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) & + & + r_vvl * e3u(ji,jj,1,Kaa) + puu(ji,jj,1,Kaa) = puu(ji,jj,1,Kaa) + rDt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & + & / ( ze3ua * rho0 ) * umask(ji,jj,1) + END_2D + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + puu(ji,jj,jk,Kaa) = puu(ji,jj,jk,Kaa) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * puu(ji,jj,jk-1,Kaa) + END_3D + ! + DO_2D( 0, 0, 0, 0 ) !== thrid recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk ==! + puu(ji,jj,jpkm1,Kaa) = puu(ji,jj,jpkm1,Kaa) / zwd(ji,jj,jpkm1) + END_2D + DO_3DS( 0, 0, 0, 0, jpk-2, 1, -1 ) + puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kaa) - zws(ji,jj,jk) * puu(ji,jj,jk+1,Kaa) ) / zwd(ji,jj,jk) + END_3D + ! + ! !== Vertical diffusion on v ==! + ! + ! !* Matrix construction + zdt = rDt * 0.5 + IF( ln_zad_Aimp ) THEN !! + SELECT CASE( nldf_dyn ) + CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzv) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) & + & + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point + zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) + akzv(ji,jj,jk ) ) & + & / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk ) + zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) ) & + & / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) + zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) / ze3va + zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va + zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) + zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) + zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) + END_3D + CASE DEFAULT ! iso-level lateral mixing + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) & + & + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point + zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) & + & / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk ) + zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) & + & / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) + zWvi = ( wi(ji,jj,jk ) + wi(ji,jj+1,jk ) ) / ze3va + zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va + zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) + zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) + zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) + END_3D + END SELECT + DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions + zwi(ji,jj,1) = 0._wp + ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) & + & + r_vvl * e3v(ji,jj,1,Kaa) + zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) & + & / ( ze3va * e3vw(ji,jj,2,Kmm) ) * wvmask(ji,jj,2) + zWvs = ( wi(ji,jj ,2) + wi(ji,jj+1,2) ) / ze3va + zws(ji,jj,1 ) = zzws - zdt * MAX( zWvs, 0._wp ) + zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWvs, 0._wp ) ) + END_2D + ELSE + SELECT CASE( nldf_dyn ) + CASE( np_lap_i ) ! rotated lateral mixing: add its vertical mixing (akzu) + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) & + & + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point + zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) + akzv(ji,jj,jk ) ) & + & / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk ) + zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) ) & + & / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) + zwi(ji,jj,jk) = zzwi + zws(ji,jj,jk) = zzws + zwd(ji,jj,jk) = 1._wp - zzwi - zzws + END_3D + CASE DEFAULT ! iso-level lateral mixing + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) & + & + r_vvl * e3v(ji,jj,jk,Kaa) ! after scale factor at V-point + zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) & + & / ( ze3va * e3vw(ji,jj,jk ,Kmm) ) * wvmask(ji,jj,jk ) + zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) & + & / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) + zwi(ji,jj,jk) = zzwi + zws(ji,jj,jk) = zzws + zwd(ji,jj,jk) = 1._wp - zzwi - zzws + END_3D + END SELECT + DO_2D( 0, 0, 0, 0 ) !* Surface boundary conditions + zwi(ji,jj,1) = 0._wp + zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) + END_2D + ENDIF + ! + ! !== Apply semi-implicit top/bottom friction ==! + ! + ! Only needed for semi-implicit bottom friction setup. The explicit + ! bottom friction has been included in "u(v)a" which act as the R.H.S + ! column vector of the tri-diagonal matrix equation + ! + IF( ln_drgimp ) THEN + DO_2D( 0, 0, 0, 0 ) + ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points) + ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) & + & + r_vvl * e3v(ji,jj,ikv,Kaa) ! after scale factor at T-point + zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va + END_2D + IF ( ln_isfcav.OR.ln_drgice_imp ) THEN + DO_2D( 0, 0, 0, 0 ) + ikv = mikv(ji,jj) ! (first wet ocean u- and v-points) + ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) & + & + r_vvl * e3v(ji,jj,ikv,Kaa) ! after scale factor at T-point + zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - rDt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / ze3va + END_2D + ENDIF + ENDIF + + ! Matrix inversion + !----------------------------------------------------------------------- + ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk ) + ! + ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 ) + ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 ) + ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 ) + ! ( ... )( ... ) ( ... ) + ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk ) + ! + ! m is decomposed in the product of an upper and lower triangular matrix + ! The 3 diagonal terms are in 2d arrays: zwd, zws, zwi + ! The solution (after velocity) is in 2d array va + !----------------------------------------------------------------------- + ! + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) == + zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) + END_3D + ! + DO_2D( 0, 0, 0, 0 ) !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==! + ze3va = ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) & + & + r_vvl * e3v(ji,jj,1,Kaa) + pvv(ji,jj,1,Kaa) = pvv(ji,jj,1,Kaa) + rDt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & + & / ( ze3va * rho0 ) * vmask(ji,jj,1) + END_2D + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + pvv(ji,jj,jk,Kaa) = pvv(ji,jj,jk,Kaa) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * pvv(ji,jj,jk-1,Kaa) + END_3D + ! + DO_2D( 0, 0, 0, 0 ) !== third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk ==! + pvv(ji,jj,jpkm1,Kaa) = pvv(ji,jj,jpkm1,Kaa) / zwd(ji,jj,jpkm1) + END_2D + DO_3DS( 0, 0, 0, 0, jpk-2, 1, -1 ) + pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - zws(ji,jj,jk) * pvv(ji,jj,jk+1,Kaa) ) / zwd(ji,jj,jk) + END_3D + ! + IF( l_trddyn ) THEN ! save the vertical diffusive trends for further diagnostics + ztrdu(:,:,:) = ( puu(:,:,:,Kaa) - puu(:,:,:,Kbb) ) / rDt - ztrdu(:,:,:) + ztrdv(:,:,:) = ( pvv(:,:,:,Kaa) - pvv(:,:,:,Kbb) ) / rDt - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_zdf, kt, Kmm ) + DEALLOCATE( ztrdu, ztrdv ) + ENDIF + ! ! print mean trends (used for debugging) + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Kaa), clinfo1=' zdf - Ua: ', mask1=umask, & + & tab3d_2=pvv(:,:,:,Kaa), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_zdf') + ! + END SUBROUTINE dyn_zdf + + !!============================================================================== +END MODULE dynzdf \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/sshwzv.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/sshwzv.F90 new file mode 100644 index 0000000..82219d8 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/sshwzv.F90 @@ -0,0 +1,439 @@ +MODULE sshwzv + !!============================================================================== + !! *** MODULE sshwzv *** + !! Ocean dynamics : sea surface height and vertical velocity + !!============================================================================== + !! History : 3.1 ! 2009-02 (G. Madec, M. Leclair) Original code + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) modified LF-RA + !! - ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface + !! - ! 2010-09 (D.Storkey and E.O'Dea) bug fixes for BDY module + !! 3.3 ! 2011-10 (M. Leclair) split former ssh_wzv routine and remove all vvl related work + !! 4.0 ! 2018-12 (A. Coward) add mixed implicit/explicit advection + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) Rename ssh_nxt -> ssh_atf. Now only does time filtering. + !! - ! 2020-08 (S. Techene, G. Madec) add here ssh initiatlisation + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! ssh_nxt : after ssh + !! ssh_atf : time filter the ssh arrays + !! wzv : compute now vertical velocity + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE isf_oce ! ice shelf + USE dom_oce ! ocean space and time domain variables + USE sbc_oce ! surface boundary condition: ocean + USE domvvl ! Variable volume + USE divhor ! horizontal divergence + USE phycst ! physical constants + USE bdy_oce , ONLY : ln_bdy, bdytmask ! Open BounDarY + USE bdydyn2d ! bdy_ssh routine + USE wet_dry ! Wetting/Drying flux limiting +#if defined key_agrif + USE agrif_oce + USE agrif_oce_interp +#endif + ! + USE iom + USE in_out_manager ! I/O manager + USE restart ! only for lrst_oce + USE prtctl ! Print control + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC ssh_nxt ! called by step.F90 + PUBLIC wzv ! called by step.F90 + PUBLIC wAimp ! called by step.F90 + PUBLIC ssh_atf ! called by step.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sshwzv.F90 15150 2021-07-27 10:38:24Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ssh_nxt( kt, Kbb, Kmm, pssh, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ssh_nxt *** + !! + !! ** Purpose : compute the after ssh (ssh(Kaa)) + !! + !! ** Method : - Using the incompressibility hypothesis, the ssh increment + !! is computed by integrating the horizontal divergence and multiply by + !! by the time step. + !! + !! ** action : ssh(:,:,Kaa), after sea surface height + !! + !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level index + REAL(dp), DIMENSION(jpi,jpj,jpt), INTENT(inout) :: pssh ! sea-surface height + ! + INTEGER :: ji, jj, jk ! dummy loop index + REAL(wp) :: zcoef ! local scalar + REAL(wp), DIMENSION(jpi,jpj) :: zhdiv ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('ssh_nxt') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ssh_nxt : after sea surface height' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + ! + zcoef = 0.5_wp * r1_rho0 + + ! !------------------------------! + ! ! After Sea Surface Height ! + ! !------------------------------! + IF(ln_wd_il) THEN + CALL wad_lmt(pssh(:,:,Kbb), zcoef * (emp_b(:,:) + emp(:,:)), rDt, Kmm, uu, vv ) + ENDIF + + CALL div_hor( kt, Kbb, Kmm ) ! Horizontal divergence + ! + zhdiv(:,:) = 0._wp + DO_3D( 1, nn_hls, 1, nn_hls, 1, jpkm1 ) ! Horizontal divergence of barotropic transports + zhdiv(ji,jj) = zhdiv(ji,jj) + e3t(ji,jj,jk,Kmm) * hdiv(ji,jj,jk) + END_3D + ! ! Sea surface elevation time stepping + ! In time-split case we need a first guess of the ssh after (using the baroclinic timestep) in order to + ! compute the vertical velocity which can be used to compute the non-linear terms of the momentum equations. + ! + DO_2D_OVR( 1, nn_hls, 1, nn_hls ) ! Loop bounds limited by hdiv definition in div_hor + pssh(ji,jj,Kaa) = ( pssh(ji,jj,Kbb) - rDt * ( zcoef * ( emp_b(ji,jj) + emp(ji,jj) ) + zhdiv(ji,jj) ) ) * ssmask(ji,jj) + END_2D + ! pssh must be defined everywhere (true for dyn_spg_ts, not for dyn_spg_exp) + IF ( .NOT. ln_dynspg_ts .AND. nn_hls == 2 ) CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1.0_dp ) + ! +#if defined key_agrif + Kbb_a = Kbb ; Kmm_a = Kmm ; Krhs_a = Kaa + CALL agrif_ssh( kt ) +#endif + ! + IF ( .NOT.ln_dynspg_ts ) THEN + IF( ln_bdy ) THEN + IF (nn_hls==1) CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1.0_dp ) ! Not sure that's necessary + CALL bdy_ssh( pssh(:,:,Kaa) ) ! Duplicate sea level across open boundaries + ENDIF + ENDIF + ! !------------------------------! + ! ! outputs ! + ! !------------------------------! + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pssh(:,:,Kaa), clinfo1=' pssh(:,:,Kaa) - : ', mask1=tmask ) + ! + IF( ln_timing ) CALL timing_stop('ssh_nxt') + ! + END SUBROUTINE ssh_nxt + + + SUBROUTINE wzv( kt, Kbb, Kmm, Kaa, pww ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wzv *** + !! + !! ** Purpose : compute the now vertical velocity + !! + !! ** Method : - Using the incompressibility hypothesis, the vertical + !! velocity is computed by integrating the horizontal divergence + !! from the bottom to the surface minus the scale factor evolution. + !! The boundary conditions are w=0 at the bottom (no flux) and. + !! + !! ** action : pww : now vertical velocity + !! + !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! time step + INTEGER , INTENT(in) :: Kbb, Kmm, Kaa ! time level indices + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pww ! vertical velocity at Kmm + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zhdiv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('wzv') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'wzv : now vertical velocity ' + IF(lwp) WRITE(numout,*) '~~~~~ ' + ! + pww(:,:,jpk) = 0._wp ! bottom boundary condition: w=0 (set once for all) + ENDIF + ! !------------------------------! + ! ! Now Vertical Velocity ! + ! !------------------------------! + ! + ! !===============================! + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN !== z_tilde and layer cases ==! + ! !===============================! + ALLOCATE( zhdiv(jpi,jpj,jpk) ) + ! + DO jk = 1, jpkm1 + ! horizontal divergence of thickness diffusion transport ( velocity multiplied by e3t) + ! - ML - note: computation already done in dom_vvl_sf_nxt. Could be optimized (not critical and clearer this way) + DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls ) + zhdiv(ji,jj,jk) = r1_e1e2t(ji,jj) * ( un_td(ji,jj,jk) - un_td(ji-1,jj,jk) + vn_td(ji,jj,jk) - vn_td(ji,jj-1,jk) ) + END_2D + END DO + IF( nn_hls == 1) CALL lbc_lnk('sshwzv', zhdiv, 'T', 1.0_wp) ! - ML - Perhaps not necessary: not used for horizontal "connexions" + ! ! Is it problematic to have a wrong vertical velocity in boundary cells? + ! ! Same question holds for hdiv. Perhaps just for security + ! ! clem: yes it is a problem because ww is used in many other places where we need the halos + ! + DO_3DS( nn_hls-1, nn_hls, nn_hls-1, nn_hls, jpkm1, 1, -1 ) ! integrate from the bottom the hor. divergence + ! computation of w + pww(ji,jj,jk) = pww(ji,jj,jk+1) - ( e3t(ji,jj,jk,Kmm) * hdiv(ji,jj,jk) & + & + zhdiv(ji,jj,jk) & + & + r1_Dt * ( e3t(ji,jj,jk,Kaa) & + & - e3t(ji,jj,jk,Kbb) ) ) * tmask(ji,jj,jk) + END_3D + ! IF( ln_vvl_layer ) pww(:,:,:) = 0.e0 + DEALLOCATE( zhdiv ) + ! !=================================! + ELSEIF( ln_linssh ) THEN !== linear free surface cases ==! + ! !=================================! + DO_3DS( nn_hls-1, nn_hls, nn_hls-1, nn_hls, jpkm1, 1, -1 ) ! integrate from the bottom the hor. divergence + pww(ji,jj,jk) = pww(ji,jj,jk+1) - ( e3t(ji,jj,jk,Kmm) * hdiv(ji,jj,jk) ) * tmask(ji,jj,jk) + END_3D + ! !==========================================! + ELSE !== Quasi-Eulerian vertical coordinate ==! ('key_qco') + ! !==========================================! + DO_3DS( nn_hls-1, nn_hls, nn_hls-1, nn_hls, jpkm1, 1, -1 ) ! integrate from the bottom the hor. divergence + pww(ji,jj,jk) = pww(ji,jj,jk+1) - ( e3t(ji,jj,jk,Kmm) * hdiv(ji,jj,jk) & + & + r1_Dt * ( e3t(ji,jj,jk,Kaa) & + & - e3t(ji,jj,jk,Kbb) ) ) * tmask(ji,jj,jk) + END_3D + ENDIF + + IF( ln_bdy ) THEN + DO jk = 1, jpkm1 + DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls ) + pww(ji,jj,jk) = pww(ji,jj,jk) * bdytmask(ji,jj) + END_2D + END DO + ENDIF + ! +#if defined key_agrif + IF( .NOT. AGRIF_Root() ) THEN + ! + ! Mask vertical velocity at first/last columns/row + ! inside computational domain (cosmetic) + DO jk = 1, jpkm1 + IF( lk_west ) THEN ! --- West --- ! + DO ji = mi0(2+nn_hls), mi1(2+nn_hls) + DO jj = 1, jpj + pww(ji,jj,jk) = 0._wp + END DO + END DO + ENDIF + IF( lk_east ) THEN ! --- East --- ! + DO ji = mi0(jpiglo-1-nn_hls), mi1(jpiglo-1-nn_hls) + DO jj = 1, jpj + pww(ji,jj,jk) = 0._wp + END DO + END DO + ENDIF + IF( lk_south ) THEN ! --- South --- ! + DO jj = mj0(2+nn_hls), mj1(2+nn_hls) + DO ji = 1, jpi + pww(ji,jj,jk) = 0._wp + END DO + END DO + ENDIF + IF( lk_north ) THEN ! --- North --- ! + DO jj = mj0(jpjglo-1-nn_hls), mj1(jpjglo-1-nn_hls) + DO ji = 1, jpi + pww(ji,jj,jk) = 0._wp + END DO + END DO + ENDIF + ! + END DO + ! + ENDIF +#endif + ! + IF( ln_timing ) CALL timing_stop('wzv') + ! + END SUBROUTINE wzv + + + SUBROUTINE ssh_atf( kt, Kbb, Kmm, Kaa, pssh ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ssh_atf *** + !! + !! ** Purpose : Apply Asselin time filter to now SSH. + !! + !! ** Method : - apply Asselin time fiter to now ssh (excluding the forcing + !! from the filter, see Leclair and Madec 2010) and swap : + !! pssh(:,:,Kmm) = pssh(:,:,Kaa) + rn_atfp * ( pssh(:,:,Kbb) -2 pssh(:,:,Kmm) + pssh(:,:,Kaa) ) + !! - rn_atfp * rn_Dt * ( emp_b - emp ) / rho0 + !! + !! ** action : - pssh(:,:,Kmm) time filtered + !! + !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpt), INTENT(inout) :: pssh ! SSH field + ! + REAL(wp) :: zcoef ! local scalar + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('ssh_atf') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ssh_atf : Asselin time filter of sea surface height' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + ! + IF( .NOT.l_1st_euler ) THEN ! Apply Asselin time filter on Kmm field (not on euler 1st) + ! + IF( ln_linssh ) THEN ! filtered "now" field + pssh(:,:,Kmm) = pssh(:,:,Kmm) + rn_atfp * ( pssh(:,:,Kbb) - 2 * pssh(:,:,Kmm) + pssh(:,:,Kaa) ) + ! + ELSE ! filtered "now" field with forcing removed + zcoef = rn_atfp * rn_Dt * r1_rho0 + pssh(:,:,Kmm) = pssh(:,:,Kmm) + rn_atfp * ( pssh(:,:,Kbb) - 2 * pssh(:,:,Kmm) + pssh(:,:,Kaa) ) & + & - zcoef * ( emp_b(:,:) - emp(:,:) & + & - rnf_b(:,:) + rnf(:,:) & + & - fwfisf_cav_b(:,:) + fwfisf_cav(:,:) & + & - fwfisf_par_b(:,:) + fwfisf_par(:,:) ) * ssmask(:,:) + + ! ice sheet coupling + IF( ln_isf .AND. ln_isfcpl .AND. kt == nit000+1 ) & + & pssh(:,:,Kbb) = pssh(:,:,Kbb) - rn_atfp * rn_Dt * ( risfcpl_ssh(:,:) - 0._wp ) * ssmask(:,:) + + ENDIF + ENDIF + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pssh(:,:,Kmm), clinfo1=' atf - pssh(:,:,Kmm): ', mask1=tmask ) + ! + IF( ln_timing ) CALL timing_stop('ssh_atf') + ! + END SUBROUTINE ssh_atf + + + SUBROUTINE wAimp( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wAimp *** + !! + !! ** Purpose : compute the Courant number and partition vertical velocity + !! if a proportion needs to be treated implicitly + !! + !! ** Method : - + !! + !! ** action : ww : now vertical velocity (to be handled explicitly) + !! : wi : now vertical velocity (for implicit treatment) + !! + !! Reference : Shchepetkin, A. F. (2015): An adaptive, Courant-number-dependent + !! implicit scheme for vertical advection in oceanic modeling. + !! Ocean Modelling, 91, 38-69. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step + INTEGER, INTENT(in) :: Kmm ! time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zCu, zcff, z1_e3t, zdt ! local scalars + REAL(wp) , PARAMETER :: Cu_min = 0.15_wp ! local parameters + REAL(wp) , PARAMETER :: Cu_max = 0.30_wp ! local parameters + REAL(wp) , PARAMETER :: Cu_cut = 2._wp*Cu_max - Cu_min ! local parameters + REAL(wp) , PARAMETER :: Fcu = 4._wp*Cu_max*(Cu_max-Cu_min) ! local parameters + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('wAimp') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'wAimp : Courant number-based partitioning of now vertical velocity ' + IF(lwp) WRITE(numout,*) '~~~~~ ' + ENDIF + ! + ! Calculate Courant numbers + zdt = 2._wp * rn_Dt ! 2*rn_Dt and not rDt (for restartability) + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN + DO_3D( nn_hls-1, nn_hls, nn_hls-1, nn_hls, 1, jpkm1 ) + z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) + Cu_adv(ji,jj,jk) = zdt * & + & ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) ) & + & + ( MAX( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) & + & * uu (ji ,jj,jk,Kmm) + un_td(ji ,jj,jk), 0._wp ) - & + & MIN( e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) & + & * uu (ji-1,jj,jk,Kmm) + un_td(ji-1,jj,jk), 0._wp ) ) & + & * r1_e1e2t(ji,jj) & + & + ( MAX( e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) & + & * vv (ji,jj ,jk,Kmm) + vn_td(ji,jj ,jk), 0._wp ) - & + & MIN( e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) & + & * vv (ji,jj-1,jk,Kmm) + vn_td(ji,jj-1,jk), 0._wp ) ) & + & * r1_e1e2t(ji,jj) & + & ) * z1_e3t + END_3D + ELSE + DO_3D( nn_hls-1, nn_hls, nn_hls-1, nn_hls, 1, jpkm1 ) + z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) + Cu_adv(ji,jj,jk) = zdt * & + & ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) ) & + & + ( MAX( e2u(ji ,jj)*e3u(ji ,jj,jk,Kmm)*uu(ji ,jj,jk,Kmm), 0._wp ) - & + & MIN( e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kmm)*uu(ji-1,jj,jk,Kmm), 0._wp ) ) & + & * r1_e1e2t(ji,jj) & + & + ( MAX( e1v(ji,jj )*e3v(ji,jj ,jk,Kmm)*vv(ji,jj ,jk,Kmm), 0._wp ) - & + & MIN( e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kmm)*vv(ji,jj-1,jk,Kmm), 0._wp ) ) & + & * r1_e1e2t(ji,jj) & + & ) * z1_e3t + END_3D + ENDIF + CALL iom_put("Courant",Cu_adv) + ! + IF( MAXVAL( Cu_adv(:,:,:) ) > Cu_min ) THEN ! Quick check if any breaches anywhere + DO_3DS( nn_hls-1, nn_hls, nn_hls-1, nn_hls, jpkm1, 2, -1 ) ! or scan Courant criterion and partition ! w where necessary + ! + zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) ) +! alt: +! IF ( ww(ji,jj,jk) > 0._wp ) THEN +! zCu = Cu_adv(ji,jj,jk) +! ELSE +! zCu = Cu_adv(ji,jj,jk-1) +! ENDIF + ! + IF( zCu <= Cu_min ) THEN !<-- Fully explicit + zcff = 0._wp + ELSEIF( zCu < Cu_cut ) THEN !<-- Mixed explicit + zcff = ( zCu - Cu_min )**2 + zcff = zcff / ( Fcu + zcff ) + ELSE !<-- Mostly implicit + zcff = ( zCu - Cu_max )/ zCu + ENDIF + zcff = MIN(1._wp, zcff) + ! + wi(ji,jj,jk) = zcff * ww(ji,jj,jk) + ww(ji,jj,jk) = ( 1._wp - zcff ) * ww(ji,jj,jk) + ! + Cu_adv(ji,jj,jk) = zcff ! Reuse array to output coefficient below and in stp_ctl + END_3D + Cu_adv(:,:,1) = 0._wp + ELSE + ! Fully explicit everywhere + Cu_adv(:,:,:) = 0._wp ! Reuse array to output coefficient below and in stp_ctl + wi (:,:,:) = 0._wp + ENDIF + CALL iom_put("wimp",wi) + CALL iom_put("wi_cff",Cu_adv) + CALL iom_put("wexp",ww) + ! + IF( ln_timing ) CALL timing_stop('wAimp') + ! + END SUBROUTINE wAimp + + !!====================================================================== +END MODULE sshwzv diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/wet_dry.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/wet_dry.F90 new file mode 100644 index 0000000..b21148a --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/DYN/wet_dry.F90 @@ -0,0 +1,396 @@ +MODULE wet_dry + + !! includes updates to namelist namwad for diagnostic outputs of ROMS wetting and drying + + !!============================================================================== + !! *** MODULE wet_dry *** + !! Wetting and drying includes initialisation routine and routines to + !! compute and apply flux limiters and preserve water depth positivity + !! only effects if wetting/drying is on (ln_wd_il == .true. or ln_wd_dl==.true. ) + !!============================================================================== + !! History : 3.6 ! 2014-09 ((H.Liu) Original code + !! ! will add the runoff and periodic BC case later + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! wad_init : initialisation of wetting and drying + !! wad_lmt : horizontal flux limiter and limited velocity when wetting and drying happens + !! wad_lmt_bt : same as wad_lmt for the barotropic stepping (dynspg_ts) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce , ONLY: ln_rnf ! surface boundary condition: ocean + USE sbcrnf ! river runoff + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + USE timing ! timing of the main modules + + IMPLICIT NONE + PRIVATE + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! critical depths,filters, limiters,and masks for Wetting and Drying + !! --------------------------------------------------------------------- + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wdmask !: u- and v- limiter + ! ! (can include negative depths) + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wdramp, wdrampu, wdrampv !: for hpg limiting + + LOGICAL, PUBLIC :: ln_wd_il !: Wetting/drying il activation switch (T:on,F:off) + LOGICAL, PUBLIC :: ln_wd_dl !: Wetting/drying dl activation switch (T:on,F:off) + REAL(wp), PUBLIC :: rn_wdmin0 !: depth at which wetting/drying starts + REAL(wp), PUBLIC :: rn_wdmin1 !: minimum water depth on dried cells + REAL(wp), PUBLIC :: r_rn_wdmin1 !: 1/minimum water depth on dried cells + REAL(wp), PUBLIC :: rn_wdmin2 !: tolerance of minimum water depth on dried cells + REAL(wp), PUBLIC :: rn_wd_sbcdep !: Depth at which to taper sbc fluxes + REAL(wp), PUBLIC :: rn_wd_sbcfra !: Fraction of SBC at taper depth + REAL(wp), PUBLIC :: rn_wdld !: land elevation below which wetting/drying will be considered + INTEGER , PUBLIC :: nn_wdit !: maximum number of iteration for W/D limiter + LOGICAL, PUBLIC :: ln_wd_dl_bc !: DL scheme: True implies 3D velocities are set to the barotropic values at points + !: where the flow is from wet points on less than half the barotropic sub-steps + LOGICAL, PUBLIC :: ln_wd_dl_rmp !: use a ramp for the dl flux limiter between 2 rn_wdmin1 and rn_wdmin1 (rather than a cut-off at rn_wdmin1) + REAL(wp), PUBLIC :: ssh_ref !: height of z=0 with respect to the geoid; + + LOGICAL, PUBLIC :: ll_wd = .FALSE. !: Wetting/drying activation switch (ln_wd_il or ln_wd_dl) <- default def if wad_init not called + + PUBLIC wad_init ! initialisation routine called by step.F90 + PUBLIC wad_lmt ! routine called by sshwzv.F90 + PUBLIC wad_lmt_bt ! routine called by dynspg_ts.F90 + + !! * Substitutions + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE wad_init + !!---------------------------------------------------------------------- + !! *** ROUTINE wad_init *** + !! + !! ** Purpose : read wetting and drying namelist and print the variables. + !! + !! ** input : - namwad namelist + !!---------------------------------------------------------------------- + INTEGER :: ios, ierr ! Local integer + !! + NAMELIST/namwad/ ln_wd_il, ln_wd_dl , rn_wdmin0, rn_wdmin1, rn_wdmin2, rn_wdld, & + & nn_wdit , ln_wd_dl_bc, ln_wd_dl_rmp, rn_wd_sbcdep,rn_wd_sbcfra + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namwad, IOSTAT = ios, ERR = 905) +905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namwad in reference namelist' ) + READ ( numnam_cfg, namwad, IOSTAT = ios, ERR = 906) +906 IF( ios > 0 ) CALL ctl_nam ( ios , 'namwad in configuration namelist' ) + IF(lwm) WRITE ( numond, namwad ) + ! + IF( rn_wd_sbcfra>=1 ) CALL ctl_stop( 'STOP', 'rn_wd_sbcfra >=1 : must be < 1' ) + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'wad_init : Wetting and drying initialization through namelist read' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) ' Namelist namwad' + WRITE(numout,*) ' Logical for Iter Lim wd option ln_wd_il = ', ln_wd_il + WRITE(numout,*) ' Logical for Dir. Lim wd option ln_wd_dl = ', ln_wd_dl + WRITE(numout,*) ' Depth at which wet/drying starts rn_wdmin0 = ', rn_wdmin0 + WRITE(numout,*) ' Minimum wet depth on dried cells rn_wdmin1 = ', rn_wdmin1 + WRITE(numout,*) ' Tolerance of min wet depth rn_wdmin2 = ', rn_wdmin2 + WRITE(numout,*) ' land elevation threshold rn_wdld = ', rn_wdld + WRITE(numout,*) ' Max iteration for W/D limiter nn_wdit = ', nn_wdit + WRITE(numout,*) ' T => baroclinic u,v=0 at dry pts: ln_wd_dl_bc = ', ln_wd_dl_bc + WRITE(numout,*) ' use a ramp for rwd limiter: ln_wd_dl_rwd_rmp = ', ln_wd_dl_rmp + WRITE(numout,*) ' cut off depth sbc for wd rn_wd_sbcdep = ', rn_wd_sbcdep + WRITE(numout,*) ' fraction to start sbc wgt rn_wd_sbcfra = ', rn_wd_sbcfra + ENDIF + IF( .NOT. ln_read_cfg ) THEN + IF(lwp) WRITE(numout,*) ' No configuration file so seting ssh_ref to zero ' + ssh_ref=0._wp + ENDIF + + r_rn_wdmin1 = 1 / rn_wdmin1 + IF( ln_wd_il .OR. ln_wd_dl ) THEN + ll_wd = .TRUE. + ALLOCATE( wdmask(jpi,jpj), STAT=ierr ) + ALLOCATE( wdramp(jpi,jpj), wdrampu(jpi,jpj), wdrampv(jpi,jpj), STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop('STOP', 'wad_init : Array allocation error') + ENDIF + + IF( ln_tile .AND. ln_wd_il ) CALL ctl_warn('Tiling has not been tested with ln_wd_il = T') + ! + END SUBROUTINE wad_init + + + SUBROUTINE wad_lmt( psshb1, psshemp, z2dt, Kmm, puu, pvv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wad_lmt *** + !! + !! ** Purpose : generate flux limiters for wetting/drying + !! + !! ** Method : - Prevent negative depth occurring (Not ready for Agrif) + !! + !! ** Action : - calculate flux limiter and W/D flag + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:) , INTENT(inout) :: psshb1 + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: psshemp + REAL(wp) , INTENT(in ) :: z2dt + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocity arrays + ! + INTEGER :: ji, jj, jk, jk1 ! dummy loop indices + INTEGER :: jflag ! local scalar + REAL(wp) :: zcoef, zdep1, zdep2 ! local scalars + REAL(wp) :: zzflxp, zzflxn ! local scalars + REAL(wp) :: zdepwd ! local scalar, always wet cell depth + REAL(wp) :: ztmp ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zwdlmtu, zwdlmtv ! W/D flux limiters + REAL(wp), DIMENSION(jpi,jpj) :: zflxp , zflxn ! local 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zflxu , zflxv ! local 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zflxu1 , zflxv1 ! local 2D workspace + !!---------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('wad_lmt') ! + ! + DO jk = 1, jpkm1 + puu(:,:,jk,Kmm) = puu(:,:,jk,Kmm) * zwdlmtu(:,:) + pvv(:,:,jk,Kmm) = pvv(:,:,jk,Kmm) * zwdlmtv(:,:) + END DO + jflag = 0 + zdepwd = 50._wp ! maximum depth on which that W/D could possibly happen + ! + zflxp(:,:) = 0._wp + zflxn(:,:) = 0._wp + zflxu(:,:) = 0._wp + zflxv(:,:) = 0._wp + ! + zwdlmtu(:,:) = 1._wp + zwdlmtv(:,:) = 1._wp + ! + DO jk = 1, jpkm1 ! Horizontal Flux in u and v direction + zflxu(:,:) = zflxu(:,:) + e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk) + zflxv(:,:) = zflxv(:,:) + e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) + END DO + zflxu(:,:) = zflxu(:,:) * e2u(:,:) + zflxv(:,:) = zflxv(:,:) * e1v(:,:) + ! + wdmask(:,:) = 1._wp + DO_2D( 0, 1, 0, 1 ) + ! + IF( tmask(ji,jj,1) < 0.5_wp ) CYCLE ! we don't care about land cells + IF( ht_0(ji,jj) - ssh_ref > zdepwd ) CYCLE ! and cells which are unlikely to dry + ! + zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj ) , 0._wp ) & + & + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji, jj-1) , 0._wp ) + zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj ) , 0._wp ) & + & + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji, jj-1) , 0._wp ) + ! + zdep2 = ht_0(ji,jj) + psshb1(ji,jj) - rn_wdmin1 + IF( zdep2 <= 0._wp ) THEN ! add more safty, but not necessary + psshb1(ji,jj) = rn_wdmin1 - ht_0(ji,jj) + IF(zflxu(ji, jj) > 0._wp) zwdlmtu(ji ,jj) = 0._wp + IF(zflxu(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = 0._wp + IF(zflxv(ji, jj) > 0._wp) zwdlmtv(ji ,jj) = 0._wp + IF(zflxv(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = 0._wp + wdmask(ji,jj) = 0._wp + END IF + END_2D + ! + ! ! HPG limiter from jholt + wdramp(:,:) = min((ht_0(:,:) + psshb1(:,:) - rn_wdmin1)/(rn_wdmin0 - rn_wdmin1),1.0_wp) + !jth assume don't need a lbc_lnk here + DO_2D( 1, 0, 1, 0 ) + wdrampu(ji,jj) = MIN( wdramp(ji,jj) , wdramp(ji+1,jj) ) + wdrampv(ji,jj) = MIN( wdramp(ji,jj) , wdramp(ji,jj+1) ) + END_2D + ! ! end HPG limiter + ! + ! + DO jk1 = 1, nn_wdit + 1 !== start limiter iterations ==! + ! + zflxu1(:,:) = zflxu(:,:) * zwdlmtu(:,:) + zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:) + jflag = 0 ! flag indicating if any further iterations are needed + ! + DO_2D( 0, 1, 0, 1 ) + IF( tmask(ji, jj, 1) < 0.5_wp ) CYCLE + IF( ht_0(ji,jj) > zdepwd ) CYCLE + ! + ztmp = e1e2t(ji,jj) + ! + zzflxp = MAX( zflxu1(ji,jj) , 0._wp ) - MIN( zflxu1(ji-1,jj ) , 0._wp) & + & + MAX( zflxv1(ji,jj) , 0._wp ) - MIN( zflxv1(ji, jj-1) , 0._wp) + zzflxn = MIN( zflxu1(ji,jj) , 0._wp ) - MAX( zflxu1(ji-1,jj ) , 0._wp) & + & + MIN( zflxv1(ji,jj) , 0._wp ) - MAX( zflxv1(ji, jj-1) , 0._wp) + ! + zdep1 = (zzflxp + zzflxn) * z2dt / ztmp + zdep2 = ht_0(ji,jj) + psshb1(ji,jj) - rn_wdmin1 - z2dt * psshemp(ji,jj) + ! + IF( zdep1 > zdep2 ) THEN + wdmask(ji, jj) = 0._wp + zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) + !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) + ! flag if the limiter has been used but stop flagging if the only + ! changes have zeroed the coefficient since further iterations will + ! not change anything + IF( zcoef > 0._wp ) THEN ; jflag = 1 + ELSE ; zcoef = 0._wp + ENDIF + IF( jk1 > nn_wdit ) zcoef = 0._wp + IF( zflxu1(ji ,jj ) > 0._wp ) zwdlmtu(ji ,jj ) = zcoef + IF( zflxu1(ji-1,jj ) < 0._wp ) zwdlmtu(ji-1,jj ) = zcoef + IF( zflxv1(ji ,jj ) > 0._wp ) zwdlmtv(ji ,jj ) = zcoef + IF( zflxv1(ji ,jj-1) < 0._wp ) zwdlmtv(ji ,jj-1) = zcoef + ENDIF + END_2D + CALL lbc_lnk( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) + ! + CALL mpp_max('wet_dry', jflag) !max over the global domain + ! + IF( jflag == 0 ) EXIT + ! + END DO ! jk1 loop + ! + DO jk = 1, jpkm1 + puu(:,:,jk,Kmm) = puu(:,:,jk,Kmm) * zwdlmtu(:,:) + pvv(:,:,jk,Kmm) = pvv(:,:,jk,Kmm) * zwdlmtv(:,:) + END DO + uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * zwdlmtu(:, :) + vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * zwdlmtv(:, :) + ! +!!gm TO BE SUPPRESSED ? these lbc_lnk are useless since zwdlmtu and zwdlmtv are defined everywhere ! + CALL lbc_lnk( 'wet_dry', puu(:,:,:,Kmm) , 'U', -1.0_dp, pvv(:,:,:,Kmm) , 'V', -1.0_dp ) + CALL lbc_lnk( 'wet_dry', uu_b(:,:,Kmm), 'U', -1.0_wp, vv_b(:,:,Kmm), 'V', -1.0_wp ) +!!gm + ! + IF(jflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt!!!' + ! + !IF( ln_rnf ) CALL sbc_rnf_div( hdiv ) ! runoffs (update hdiv field) + ! + IF( ln_timing ) CALL timing_stop('wad_lmt') ! + ! + END SUBROUTINE wad_lmt + + + SUBROUTINE wad_lmt_bt( zflxu, zflxv, sshn_e, zssh_frc, rDt_e ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wad_lmt *** + !! + !! ** Purpose : limiting flux in the barotropic stepping (dynspg_ts) + !! + !! ** Method : - Prevent negative depth occurring (Not ready for Agrif) + !! + !! ** Action : - calculate flux limiter and W/D flag + !!---------------------------------------------------------------------- + REAL(dp) , INTENT(in ) :: rDt_e ! ocean time-step index + REAL(wp), DIMENSION(:,:), INTENT(inout) :: zflxv + REAL(dp), DIMENSION(:,:), INTENT(inout) :: zflxu, sshn_e, zssh_frc + ! + INTEGER :: ji, jj, jk, jk1 ! dummy loop indices + INTEGER :: jflag ! local integer + REAL(wp) :: z2dt + REAL(wp) :: zcoef, zdep1, zdep2 ! local scalars + REAL(wp) :: zzflxp, zzflxn ! local scalars + REAL(wp) :: zdepwd ! local scalar, always wet cell depth + REAL(wp) :: ztmp ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zwdlmtu, zwdlmtv !: W/D flux limiters + REAL(wp), DIMENSION(jpi,jpj) :: zflxp, zflxn ! local 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zflxu1, zflxv1 ! local 2D workspace + !!---------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('wad_lmt_bt') ! + ! + jflag = 0 + zdepwd = 50._wp ! maximum depth that ocean cells can have W/D processes + ! + z2dt = rDt_e + ! + zflxp(:,:) = 0._wp + zflxn(:,:) = 0._wp + zwdlmtu(:,:) = 1._wp + zwdlmtv(:,:) = 1._wp + ! + DO_2D( 0, 1, 0, 1 ) ! Horizontal Flux in u and v direction + ! + IF( tmask(ji, jj, 1 ) < 0.5_wp) CYCLE ! we don't care about land cells + IF( ht_0(ji,jj) > zdepwd ) CYCLE ! and cells which are unlikely to dry + ! + zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj ) , 0._wp ) & + & + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji, jj-1) , 0._wp ) + zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj ) , 0._wp ) & + & + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji, jj-1) , 0._wp ) + ! + zdep2 = ht_0(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 + IF( zdep2 <= 0._wp ) THEN !add more safety, but not necessary + sshn_e(ji,jj) = rn_wdmin1 - ht_0(ji,jj) + IF( zflxu(ji ,jj ) > 0._wp) zwdlmtu(ji ,jj ) = 0._wp + IF( zflxu(ji-1,jj ) < 0._wp) zwdlmtu(ji-1,jj ) = 0._wp + IF( zflxv(ji ,jj ) > 0._wp) zwdlmtv(ji ,jj ) = 0._wp + IF( zflxv(ji ,jj-1) < 0._wp) zwdlmtv(ji ,jj-1) = 0._wp + ENDIF + END_2D + ! + DO jk1 = 1, nn_wdit + 1 !! start limiter iterations + ! + zflxu1(:,:) = zflxu(:,:) * zwdlmtu(:,:) + zflxv1(:,:) = zflxv(:,:) * zwdlmtv(:,:) + jflag = 0 ! flag indicating if any further iterations are needed + ! + DO_2D( 0, 1, 0, 1 ) + ! + IF( tmask(ji, jj, 1 ) < 0.5_wp ) CYCLE + IF( ht_0(ji,jj) > zdepwd ) CYCLE + ! + ztmp = e1e2t(ji,jj) + ! + zzflxp = max(zflxu1(ji,jj), 0._wp) - min(zflxu1(ji-1,jj), 0._wp) & + & + max(zflxv1(ji,jj), 0._wp) - min(zflxv1(ji, jj-1), 0._wp) + zzflxn = min(zflxu1(ji,jj), 0._wp) - max(zflxu1(ji-1,jj), 0._wp) & + & + min(zflxv1(ji,jj), 0._wp) - max(zflxv1(ji, jj-1), 0._wp) + + zdep1 = (zzflxp + zzflxn) * z2dt / ztmp + zdep2 = ht_0(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 - z2dt * zssh_frc(ji,jj) + + IF(zdep1 > zdep2) THEN + zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) + !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) + ! flag if the limiter has been used but stop flagging if the only + ! changes have zeroed the coefficient since further iterations will + ! not change anything + IF( zcoef > 0._wp ) THEN + jflag = 1 + ELSE + zcoef = 0._wp + ENDIF + IF(jk1 > nn_wdit) zcoef = 0._wp + IF(zflxu1(ji, jj) > 0._wp) zwdlmtu(ji ,jj) = zcoef + IF(zflxu1(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = zcoef + IF(zflxv1(ji, jj) > 0._wp) zwdlmtv(ji ,jj) = zcoef + IF(zflxv1(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = zcoef + END IF + END_2D + ! + CALL lbc_lnk( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) + ! + CALL mpp_max('wet_dry', jflag) !max over the global domain + ! + IF(jflag == 0) EXIT + ! + END DO ! jk1 loop + ! + zflxu(:,:) = zflxu(:,:) * zwdlmtu(:, :) + zflxv(:,:) = zflxv(:,:) * zwdlmtv(:, :) + ! +!!gm THIS lbc_lnk is useless since it is already done at the end of the jk1-loop + CALL lbc_lnk( 'wet_dry', zflxu, 'U', -1.0_dp) + CALL lbc_lnk( 'wet_dry', zflxv, 'V', -1.0_wp) +!!gm end + ! + IF( jflag == 1 .AND. lwp ) WRITE(numout,*) 'Need more iterations in wad_lmt_bt!!!' + ! + !IF( ln_rnf ) CALL sbc_rnf_div( hdiv ) ! runoffs (update hdiv field) + ! + IF( ln_timing ) CALL timing_stop('wad_lmt_bt') ! + ! + END SUBROUTINE wad_lmt_bt + + !!============================================================================== +END MODULE wet_dry diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flo4rk.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flo4rk.F90 new file mode 100644 index 0000000..7ffe48f --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flo4rk.F90 @@ -0,0 +1,450 @@ +MODULE flo4rk + !!====================================================================== + !! *** MODULE flo4rk *** + !! Ocean floats : trajectory computation using a 4th order Runge-Kutta + !!====================================================================== + !! + !!---------------------------------------------------------------------- + !! flo_4rk : Compute the geographical position of floats + !! flo_interp : interpolation + !!---------------------------------------------------------------------- + USE flo_oce ! ocean drifting floats + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC flo_4rk ! routine called by floats.F90 + + ! ! RK4 and Lagrange interpolation coefficients + REAL(wp), DIMENSION (4) :: tcoef1 = (/ 1.0 , 0.5 , 0.5 , 0.0 /) ! + REAL(wp), DIMENSION (4) :: tcoef2 = (/ 0.0 , 0.5 , 0.5 , 1.0 /) ! + REAL(wp), DIMENSION (4) :: scoef2 = (/ 1.0 , 2.0 , 2.0 , 1.0 /) ! + REAL(wp), DIMENSION (4) :: rcoef = (/-1./6. , 1./2. ,-1./2. , 1./6. /) ! + REAL(wp), DIMENSION (3) :: scoef1 = (/ 0.5 , 0.5 , 1.0 /) ! + +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: flo4rk.F90 13237 2020-07-03 09:12:53Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE flo_4rk( kt, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE flo_4rk *** + !! + !! ** Purpose : Compute the geographical position (lat,lon,depth) + !! of each float at each time step. + !! + !! ** Method : The position of a float is computed with a 4th order + !! Runge-Kutta scheme and and Lagrange interpolation. + !! We need to know the velocity field, the old positions of the + !! floats and the grid defined on the domain. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + !! + INTEGER :: jfl, jind ! dummy loop indices + INTEGER :: ierror ! error value + + REAL(wp), DIMENSION(jpnfl) :: zgifl , zgjfl , zgkfl ! index RK positions + REAL(wp), DIMENSION(jpnfl) :: zufl , zvfl , zwfl ! interpolated velocity at the float position + REAL(wp), DIMENSION(jpnfl,4) :: zrkxfl, zrkyfl, zrkzfl ! RK coefficients + !!--------------------------------------------------------------------- + ! + IF( ierror /= 0 ) THEN + WRITE(numout,*) 'flo_4rk: allocation of workspace arrays failed' + ENDIF + + + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'flo_4rk : compute Runge Kutta trajectories for floats ' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + + ! Verification of the floats positions. If one of them leave the domain + ! domain we replace the float near the border. + DO jfl = 1, jpnfl + ! i-direction + IF( tpifl(jfl) <= 1.5 ) THEN + IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!' + IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the WEST border.' + tpifl(jfl) = tpifl(jfl) + 1. + IF(lwp)WRITE(numout,*)'New initialisation for this float at i=',tpifl(jfl) + ENDIF + + IF( tpifl(jfl) >= jpi-.5 ) THEN + IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!' + IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the EAST border.' + tpifl(jfl) = tpifl(jfl) - 1. + IF(lwp)WRITE(numout,*)'New initialisation for this float at i=', tpifl(jfl) + ENDIF + ! j-direction + IF( tpjfl(jfl) <= 1.5 ) THEN + IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!' + IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the SOUTH border.' + tpjfl(jfl) = tpjfl(jfl) + 1. + IF(lwp)WRITE(numout,*)'New initialisation for this float at j=', tpjfl(jfl) + ENDIF + + IF( tpjfl(jfl) >= jpj-.5 ) THEN + IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!' + IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the NORTH border.' + tpjfl(jfl) = tpjfl(jfl) - 1. + IF(lwp)WRITE(numout,*)'New initialisation for this float at j=', tpjfl(jfl) + ENDIF + ! k-direction + IF( tpkfl(jfl) <= .5 ) THEN + IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!' + IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the TOP border.' + tpkfl(jfl) = tpkfl(jfl) + 1. + IF(lwp)WRITE(numout,*)'New initialisation for this float at k=', tpkfl(jfl) + ENDIF + + IF( tpkfl(jfl) >= jpk-.5 ) THEN + IF(lwp)WRITE(numout,*)'!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!' + IF(lwp)WRITE(numout,*)'The float',jfl,'is out of the domain at the BOTTOM border.' + tpkfl(jfl) = tpkfl(jfl) - 1. + IF(lwp)WRITE(numout,*)'New initialisation for this float at k=', tpkfl(jfl) + ENDIF + END DO + + ! 4 steps of Runge-Kutta algorithme + ! initialisation of the positions + + DO jfl = 1, jpnfl + zgifl(jfl) = tpifl(jfl) + zgjfl(jfl) = tpjfl(jfl) + zgkfl(jfl) = tpkfl(jfl) + END DO + + DO jind = 1, 4 + + ! for each step we compute the compute the velocity with Lagrange interpolation + CALL flo_interp( Kbb, Kmm, zgifl, zgjfl, zgkfl, zufl, zvfl, zwfl, jind ) + + ! computation of Runge-Kutta factor + DO jfl = 1, jpnfl + zrkxfl(jfl,jind) = rn_Dt*zufl(jfl) + zrkyfl(jfl,jind) = rn_Dt*zvfl(jfl) + zrkzfl(jfl,jind) = rn_Dt*zwfl(jfl) + END DO + IF( jind /= 4 ) THEN + DO jfl = 1, jpnfl + zgifl(jfl) = (tpifl(jfl)) + scoef1(jind)*zrkxfl(jfl,jind) + zgjfl(jfl) = (tpjfl(jfl)) + scoef1(jind)*zrkyfl(jfl,jind) + zgkfl(jfl) = (tpkfl(jfl)) + scoef1(jind)*zrkzfl(jfl,jind) + END DO + ENDIF + END DO + DO jind = 1, 4 + DO jfl = 1, jpnfl + tpifl(jfl) = tpifl(jfl) + scoef2(jind)*zrkxfl(jfl,jind)/6. + tpjfl(jfl) = tpjfl(jfl) + scoef2(jind)*zrkyfl(jfl,jind)/6. + tpkfl(jfl) = tpkfl(jfl) + scoef2(jind)*zrkzfl(jfl,jind)/6. + END DO + END DO + ! + ! + END SUBROUTINE flo_4rk + + + SUBROUTINE flo_interp( Kbb, Kmm, & + & pxt , pyt , pzt , & + & pufl, pvfl, pwfl, ki ) + !!---------------------------------------------------------------------- + !! *** ROUTINE flointerp *** + !! + !! ** Purpose : Interpolation of the velocity on the float position + !! + !! ** Method : Lagrange interpolation with the 64 neighboring + !! points. This routine is call 4 time at each time step to + !! compute velocity at the date and the position we need to + !! integrated with RK method. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp) , DIMENSION(jpnfl), INTENT(in ) :: pxt , pyt , pzt ! position of the float + REAL(wp) , DIMENSION(jpnfl), INTENT( out) :: pufl, pvfl, pwfl ! velocity at this position + INTEGER , INTENT(in ) :: ki ! + !! + INTEGER :: jfl, jind1, jind2, jind3 ! dummy loop indices + REAL(wp) :: zsumu, zsumv, zsumw ! local scalar + INTEGER , DIMENSION(jpnfl) :: iilu, ijlu, iklu ! nearest neighbour INDEX-u + INTEGER , DIMENSION(jpnfl) :: iilv, ijlv, iklv ! nearest neighbour INDEX-v + INTEGER , DIMENSION(jpnfl) :: iilw, ijlw, iklw ! nearest neighbour INDEX-w + INTEGER , DIMENSION(jpnfl,4) :: iidu, ijdu, ikdu ! 64 nearest neighbour INDEX-u + INTEGER , DIMENSION(jpnfl,4) :: iidv, ijdv, ikdv ! 64 nearest neighbour INDEX-v + INTEGER , DIMENSION(jpnfl,4) :: iidw, ijdw, ikdw ! 64 nearest neighbour INDEX-w + REAL(wp) , DIMENSION(jpnfl,4) :: zlagxu, zlagyu, zlagzu ! Lagrange coefficients + REAL(wp) , DIMENSION(jpnfl,4) :: zlagxv, zlagyv, zlagzv ! - - + REAL(wp) , DIMENSION(jpnfl,4) :: zlagxw, zlagyw, zlagzw ! - - + REAL(wp) , DIMENSION(jpnfl,4,4,4) :: ztufl , ztvfl , ztwfl ! velocity at choosen time step + !!--------------------------------------------------------------------- + + ! Interpolation of U velocity + + ! nearest neightboring point for computation of u + DO jfl = 1, jpnfl + iilu(jfl) = INT(pxt(jfl)-.5) + ijlu(jfl) = INT(pyt(jfl)-.5) + iklu(jfl) = INT(pzt(jfl)) + END DO + + ! 64 neightboring points for computation of u + DO jind1 = 1, 4 + DO jfl = 1, jpnfl + ! i-direction + IF( iilu(jfl) <= 2 ) THEN ; iidu(jfl,jind1) = jind1 + ELSE + IF( iilu(jfl) >= jpi-1 ) THEN ; iidu(jfl,jind1) = jpi + jind1 - 4 + ELSE ; iidu(jfl,jind1) = iilu(jfl) + jind1 - 2 + ENDIF + ENDIF + ! j-direction + IF( ijlu(jfl) <= 2 ) THEN ; ijdu(jfl,jind1) = jind1 + ELSE + IF( ijlu(jfl) >= jpj-1 ) THEN ; ijdu(jfl,jind1) = jpj + jind1 - 4 + ELSE ; ijdu(jfl,jind1) = ijlu(jfl) + jind1 - 2 + ENDIF + ENDIF + ! k-direction + IF( iklu(jfl) <= 2 ) THEN ; ikdu(jfl,jind1) = jind1 + ELSE + IF( iklu(jfl) >= jpk-1 ) THEN ; ikdu(jfl,jind1) = jpk + jind1 - 4 + ELSE ; ikdu(jfl,jind1) = iklu(jfl) + jind1 - 2 + ENDIF + ENDIF + END DO + END DO + + ! Lagrange coefficients + DO jfl = 1, jpnfl + DO jind1 = 1, 4 + zlagxu(jfl,jind1) = 1. + zlagyu(jfl,jind1) = 1. + zlagzu(jfl,jind1) = 1. + END DO + END DO + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jfl= 1, jpnfl + IF( jind1 /= jind2 ) THEN + zlagxu(jfl,jind1) = zlagxu(jfl,jind1) * ( pxt(jfl)-(float(iidu(jfl,jind2))+.5) ) + zlagyu(jfl,jind1) = zlagyu(jfl,jind1) * ( pyt(jfl)-(float(ijdu(jfl,jind2))) ) + zlagzu(jfl,jind1) = zlagzu(jfl,jind1) * ( pzt(jfl)-(float(ikdu(jfl,jind2))) ) + ENDIF + END DO + END DO + END DO + + ! velocity when we compute at middle time step + + DO jfl = 1, jpnfl + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jind3 = 1, 4 + ztufl(jfl,jind1,jind2,jind3) = & + & ( tcoef1(ki) * uu(iidu(jfl,jind1),ijdu(jfl,jind2),ikdu(jfl,jind3),Kbb) + & + & tcoef2(ki) * uu(iidu(jfl,jind1),ijdu(jfl,jind2),ikdu(jfl,jind3),Kmm) ) & + & / e1u(iidu(jfl,jind1),ijdu(jfl,jind2)) + END DO + END DO + END DO + + zsumu = 0. + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jind3 = 1, 4 + zsumu = zsumu + ztufl(jfl,jind1,jind2,jind3) * zlagxu(jfl,jind1) * zlagyu(jfl,jind2) & + & * zlagzu(jfl,jind3) * rcoef(jind1)*rcoef(jind2)*rcoef(jind3) + END DO + END DO + END DO + pufl(jfl) = zsumu + END DO + + ! Interpolation of V velocity + + ! nearest neightboring point for computation of v + DO jfl = 1, jpnfl + iilv(jfl) = INT(pxt(jfl)-.5) + ijlv(jfl) = INT(pyt(jfl)-.5) + iklv(jfl) = INT(pzt(jfl)) + END DO + + ! 64 neightboring points for computation of v + DO jind1 = 1, 4 + DO jfl = 1, jpnfl + ! i-direction + IF( iilv(jfl) <= 2 ) THEN ; iidv(jfl,jind1) = jind1 + ELSE + IF( iilv(jfl) >= jpi-1 ) THEN ; iidv(jfl,jind1) = jpi + jind1 - 4 + ELSE ; iidv(jfl,jind1) = iilv(jfl) + jind1 - 2 + ENDIF + ENDIF + ! j-direction + IF( ijlv(jfl) <= 2 ) THEN ; ijdv(jfl,jind1) = jind1 + ELSE + IF( ijlv(jfl) >= jpj-1 ) THEN ; ijdv(jfl,jind1) = jpj + jind1 - 4 + ELSE ; ijdv(jfl,jind1) = ijlv(jfl) + jind1 - 2 + ENDIF + ENDIF + ! k-direction + IF( iklv(jfl) <= 2 ) THEN ; ikdv(jfl,jind1) = jind1 + ELSE + IF( iklv(jfl) >= jpk-1 ) THEN ; ikdv(jfl,jind1) = jpk + jind1 - 4 + ELSE ; ikdv(jfl,jind1) = iklv(jfl) + jind1 - 2 + ENDIF + ENDIF + END DO + END DO + + ! Lagrange coefficients + + DO jfl = 1, jpnfl + DO jind1 = 1, 4 + zlagxv(jfl,jind1) = 1. + zlagyv(jfl,jind1) = 1. + zlagzv(jfl,jind1) = 1. + END DO + END DO + + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jfl = 1, jpnfl + IF( jind1 /= jind2 ) THEN + zlagxv(jfl,jind1)= zlagxv(jfl,jind1)*(pxt(jfl) - (float(iidv(jfl,jind2)) ) ) + zlagyv(jfl,jind1)= zlagyv(jfl,jind1)*(pyt(jfl) - (float(ijdv(jfl,jind2))+.5) ) + zlagzv(jfl,jind1)= zlagzv(jfl,jind1)*(pzt(jfl) - (float(ikdv(jfl,jind2)) ) ) + ENDIF + END DO + END DO + END DO + + ! velocity when we compute at middle time step + + DO jfl = 1, jpnfl + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jind3 = 1 ,4 + ztvfl(jfl,jind1,jind2,jind3)= & + & ( tcoef1(ki) * vv(iidv(jfl,jind1),ijdv(jfl,jind2),ikdv(jfl,jind3),Kbb) + & + & tcoef2(ki) * vv(iidv(jfl,jind1),ijdv(jfl,jind2),ikdv(jfl,jind3),Kmm) ) & + & / e2v(iidv(jfl,jind1),ijdv(jfl,jind2)) + END DO + END DO + END DO + + zsumv=0. + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jind3 = 1, 4 + zsumv = zsumv + ztvfl(jfl,jind1,jind2,jind3) * zlagxv(jfl,jind1) * zlagyv(jfl,jind2) & + & * zlagzv(jfl,jind3) * rcoef(jind1)*rcoef(jind2)*rcoef(jind3) + END DO + END DO + END DO + pvfl(jfl) = zsumv + END DO + + ! Interpolation of W velocity + + ! nearest neightboring point for computation of w + DO jfl = 1, jpnfl + iilw(jfl) = INT( pxt(jfl) ) + ijlw(jfl) = INT( pyt(jfl) ) + iklw(jfl) = INT( pzt(jfl)+.5) + END DO + + ! 64 neightboring points for computation of w + DO jind1 = 1, 4 + DO jfl = 1, jpnfl + ! i-direction + IF( iilw(jfl) <= 2 ) THEN ; iidw(jfl,jind1) = jind1 + ELSE + IF( iilw(jfl) >= jpi-1 ) THEN ; iidw(jfl,jind1) = jpi + jind1 - 4 + ELSE ; iidw(jfl,jind1) = iilw(jfl) + jind1 - 2 + ENDIF + ENDIF + ! j-direction + IF( ijlw(jfl) <= 2 ) THEN ; ijdw(jfl,jind1) = jind1 + ELSE + IF( ijlw(jfl) >= jpj-1 ) THEN ; ijdw(jfl,jind1) = jpj + jind1 - 4 + ELSE ; ijdw(jfl,jind1) = ijlw(jfl) + jind1 - 2 + ENDIF + ENDIF + ! k-direction + IF( iklw(jfl) <= 2 ) THEN ; ikdw(jfl,jind1) = jind1 + ELSE + IF( iklw(jfl) >= jpk-1 ) THEN ; ikdw(jfl,jind1) = jpk + jind1 - 4 + ELSE ; ikdw(jfl,jind1) = iklw(jfl) + jind1 - 2 + ENDIF + ENDIF + END DO + END DO + DO jind1 = 1, 4 + DO jfl = 1, jpnfl + IF( iklw(jfl) <= 2 ) THEN ; ikdw(jfl,jind1) = jind1 + ELSE + IF( iklw(jfl) >= jpk-1 ) THEN ; ikdw(jfl,jind1) = jpk + jind1 - 4 + ELSE ; ikdw(jfl,jind1) = iklw(jfl) + jind1 - 2 + ENDIF + ENDIF + END DO + END DO + + ! Lagrange coefficients for w interpolation + DO jfl = 1, jpnfl + DO jind1 = 1, 4 + zlagxw(jfl,jind1) = 1. + zlagyw(jfl,jind1) = 1. + zlagzw(jfl,jind1) = 1. + END DO + END DO + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jfl = 1, jpnfl + IF( jind1 /= jind2 ) THEN + zlagxw(jfl,jind1) = zlagxw(jfl,jind1) * (pxt(jfl) - (float(iidw(jfl,jind2)) ) ) + zlagyw(jfl,jind1) = zlagyw(jfl,jind1) * (pyt(jfl) - (float(ijdw(jfl,jind2)) ) ) + zlagzw(jfl,jind1) = zlagzw(jfl,jind1) * (pzt(jfl) - (float(ikdw(jfl,jind2))-.5) ) + ENDIF + END DO + END DO + END DO + + ! velocity w when we compute at middle time step + DO jfl = 1, jpnfl + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jind3 = 1, 4 + ztwfl(jfl,jind1,jind2,jind3)= & + & ( tcoef1(ki) * wb(iidw(jfl,jind1),ijdw(jfl,jind2),ikdw(jfl,jind3))+ & + & tcoef2(ki) * ww(iidw(jfl,jind1),ijdw(jfl,jind2),ikdw(jfl,jind3)) ) & + & / e3w(iidw(jfl,jind1),ijdw(jfl,jind2),ikdw(jfl,jind3),Kmm) + END DO + END DO + END DO + + zsumw = 0.e0 + DO jind1 = 1, 4 + DO jind2 = 1, 4 + DO jind3 = 1, 4 + zsumw = zsumw + ztwfl(jfl,jind1,jind2,jind3) * zlagxw(jfl,jind1) * zlagyw(jfl,jind2) & + & * zlagzw(jfl,jind3) * rcoef(jind1)*rcoef(jind2)*rcoef(jind3) + END DO + END DO + END DO + pwfl(jfl) = zsumw + END DO + ! + ! + END SUBROUTINE flo_interp + + !!====================================================================== +END MODULE flo4rk \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flo_oce.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flo_oce.F90 new file mode 100644 index 0000000..911f878 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flo_oce.F90 @@ -0,0 +1,66 @@ +MODULE flo_oce + !!====================================================================== + !! *** MODULE flo_oce *** + !! lagrangian floats : define in memory all floats parameters and variables + !!====================================================================== + !! History : OPA ! 1999-10 (CLIPPER projet) + !! NEMO 1.0 ! 2002-11 (G. Madec, A. Bozec) F90: Free form and module + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PUBLIC + + PUBLIC flo_oce_alloc ! Routine called in floats.F90 + + !! float parameters + !! ---------------- + LOGICAL, PUBLIC :: ln_floats !: Activate floats or not + INTEGER, PUBLIC :: jpnfl = 0 !: total number of floats during the run + INTEGER, PUBLIC :: jpnnewflo !: number of floats added in a new run + INTEGER, PUBLIC :: jpnrstflo !: number of floats for the restart + + !! float variables + !! --------------- + INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) :: nisobfl !: =0 for a isobar float , =1 for a float following the w velocity + INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) :: ngrpfl !: number to identify searcher group + INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) :: nfloat !: number to identify searcher group + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: flxx , flyy , flzz !: long, lat, depth of float (decimal degree, m >0) + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: tpifl, tpjfl, tpkfl !: (i,j,k) indices of float position + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wb !: vertical velocity at previous time step (m s-1). + + ! !! * namelist namflo : langrangian floats * + LOGICAL, PUBLIC :: ln_rstflo !: T/F float restart + LOGICAL, PUBLIC :: ln_argo !: T/F argo type floats + LOGICAL, PUBLIC :: ln_flork4 !: T/F 4th order Runge-Kutta + LOGICAL, PUBLIC :: ln_ariane !: handle ariane input/output convention + LOGICAL, PUBLIC :: ln_flo_ascii !: write in ascii (T) or in Netcdf (F) + + INTEGER, PUBLIC :: nn_writefl !: frequency of float output file + INTEGER, PUBLIC :: nn_stockfl !: frequency of float restart file + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: flo_oce.F90 13558 2020-10-02 15:30:22Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION flo_oce_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION flo_oce_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( wb(jpi,jpj,jpk) , nfloat(jpnfl) , nisobfl(jpnfl) , ngrpfl(jpnfl) , & + & flxx(jpnfl) , flyy(jpnfl) , flzz(jpnfl) , & + & tpifl(jpnfl) , tpjfl(jpnfl) , tpkfl(jpnfl) , STAT=flo_oce_alloc ) + ! + CALL mpp_sum ( 'flo_oce', flo_oce_alloc ) + IF( flo_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'flo_oce_alloc: failed to allocate arrays' ) + END FUNCTION flo_oce_alloc + + !!====================================================================== +END MODULE flo_oce \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/floats.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/floats.F90 new file mode 100644 index 0000000..4e7d4b5 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/floats.F90 @@ -0,0 +1,141 @@ +MODULE floats + !!====================================================================== + !! *** MODULE floats *** + !! Ocean floats : floats + !!====================================================================== + !! History : OPA ! (CLIPPER) original Code + !! NEMO 1.0 ! 2002-06 (A. Bozec) F90, Free form and module + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + !! flo_stp : float trajectories computation + !! flo_init : initialization of float trajectories computation + !!---------------------------------------------------------------------- + USE oce ! ocean variables + USE flo_oce ! floats variables + USE lib_mpp ! distributed memory computing + USE flodom ! initialisation Module + USE flowri ! float output (flo_wri routine) + USE florst ! float restart (flo_rst routine) + USE flo4rk ! Trajectories, Runge Kutta scheme (flo_4rk routine) + USE floblk ! Trajectories, Blanke scheme (flo_blk routine) + ! + USE in_out_manager ! I/O manager + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + PUBLIC flo_stp ! routine called by step.F90 + PUBLIC flo_init ! routine called by nemogcm.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: floats.F90 12377 2020-02-12 14:39:06Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE flo_stp( kt, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE flo_stp *** + !! + !! ** Purpose : Compute the geographical position (lat., long., depth) + !! of each float at each time step with one of the algorithm. + !! + !! ** Method : The position of a float is computed with Bruno Blanke + !! algorithm by default and with a 4th order Runge-Kutta scheme + !! if ln_flork4 =T + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time step + INTEGER, INTENT( in ) :: Kbb, Kmm ! ocean time level indices + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('flo_stp') + ! + IF( ln_flork4 ) THEN ; CALL flo_4rk( kt, Kbb, Kmm ) ! Trajectories using a 4th order Runge Kutta scheme + ELSE ; CALL flo_blk( kt, Kbb, Kmm ) ! Trajectories using Blanke' algorithme + ENDIF + ! + IF( lk_mpp ) CALL mppsync ! synchronization of all the processor + ! + CALL flo_wri( kt, Kmm ) ! trajectories ouput + ! + CALL flo_rst( kt ) ! trajectories restart + ! + wb(:,:,:) = ww(:,:,:) ! Save the old vertical velocity field + ! + IF( ln_timing ) CALL timing_stop('flo_stp') + ! + END SUBROUTINE flo_stp + + + SUBROUTINE flo_init( Kmm ) + !!---------------------------------------------------------------- + !! *** ROUTINE flo_init *** + !! + !! ** Purpose : Read the namelist of floats + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + INTEGER :: jfl + INTEGER :: ios ! Local integer output status for namelist read + ! + NAMELIST/namflo/ ln_floats, jpnfl, jpnnewflo, ln_rstflo, nn_writefl, nn_stockfl, ln_argo, ln_flork4, ln_ariane, ln_flo_ascii + !!--------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'flo_stp : call floats routine ' + IF(lwp) WRITE(numout,*) '~~~~~~~' + + READ ( numnam_ref, namflo, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namflo in reference namelist' ) + + READ ( numnam_cfg, namflo, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namflo in configuration namelist' ) + IF(lwm) WRITE ( numond, namflo ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' Namelist floats :' + WRITE(numout,*) ' Activate floats or not ln_floats = ', ln_floats + WRITE(numout,*) ' number of floats jpnfl = ', jpnfl + WRITE(numout,*) ' number of new floats jpnflnewflo = ', jpnnewflo + WRITE(numout,*) ' restart ln_rstflo = ', ln_rstflo + WRITE(numout,*) ' frequency of float output file nn_writefl = ', nn_writefl + WRITE(numout,*) ' frequency of float restart file nn_stockfl = ', nn_stockfl + WRITE(numout,*) ' Argo type floats ln_argo = ', ln_argo + WRITE(numout,*) ' Computation of T trajectories ln_flork4 = ', ln_flork4 + WRITE(numout,*) ' Use of ariane convention ln_ariane = ', ln_ariane + WRITE(numout,*) ' ascii output (T) or netcdf output (F) ln_flo_ascii = ', ln_flo_ascii + + ENDIF + ! + IF( ln_floats ) THEN + ! ! allocate floats arrays + IF( flo_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_init : unable to allocate arrays' ) + ! + ! ! allocate flodom arrays + IF( flo_dom_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_dom : unable to allocate arrays' ) + ! + ! ! allocate flowri arrays + IF( flo_wri_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_wri : unable to allocate arrays' ) + ! + ! ! allocate florst arrays + IF( flo_rst_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'flo_rst : unable to allocate arrays' ) + ! + jpnrstflo = jpnfl-jpnnewflo ! memory allocation + ! + DO jfl = 1, jpnfl ! vertical axe for netcdf IOM ouput + nfloat(jfl) = jfl + END DO + ! + CALL flo_dom( Kmm ) ! compute/read initial position of floats + ! + wb(:,:,:) = ww(:,:,:) ! set wb for computation of floats trajectories at the first time step + ! + ENDIF + END SUBROUTINE flo_init + + !!====================================================================== + END MODULE floats \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/floblk.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/floblk.F90 new file mode 100644 index 0000000..75ea92e --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/floblk.F90 @@ -0,0 +1,386 @@ +MODULE floblk + !!====================================================================== + !! *** MODULE floblk *** + !! Ocean floats : trajectory computation + !!====================================================================== + !! + !!---------------------------------------------------------------------- + !! flotblk : compute float trajectories with Blanke algorithme + !!---------------------------------------------------------------------- + USE flo_oce ! ocean drifting floats + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC flo_blk ! routine called by floats.F90 + +# include "domzgr_substitute.h90" + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: floblk.F90 14229 2020-12-20 12:45:55Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE flo_blk( kt, Kbb, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE flo_blk *** + !! + !! ** Purpose : Compute the geographical position,latitude, longitude + !! and depth of each float at each time step. + !! + !! ** Method : The position of a float is computed with Bruno Blanke + !! algorithm. We need to know the velocity field, the old positions + !! of the floats and the grid defined on the domain. + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time step + INTEGER, INTENT( in ) :: Kbb, Kmm ! ocean time level indices + !! +#ifndef key_agrif + +!RB super quick fix to compile with agrif + + INTEGER :: jfl ! dummy loop arguments + INTEGER :: ind, ifin, iloop + REAL(wp) :: & + zuinfl,zvinfl,zwinfl, & ! transport across the input face + zuoutfl,zvoutfl,zwoutfl, & ! transport across the ouput face + zvol, & ! volume of the mesh + zsurfz, & ! surface of the face of the mesh + zind + + REAL(wp), DIMENSION ( 2 ) :: zsurfx, zsurfy ! surface of the face of the mesh + + INTEGER , DIMENSION ( jpnfl ) :: iil, ijl, ikl ! index of nearest mesh + INTEGER , DIMENSION ( jpnfl ) :: iiloc , ijloc + INTEGER , DIMENSION ( jpnfl ) :: iiinfl, ijinfl, ikinfl ! index of input mesh of the float. + INTEGER , DIMENSION ( jpnfl ) :: iioutfl, ijoutfl, ikoutfl ! index of output mesh of the float. + REAL(wp) , DIMENSION ( jpnfl ) :: zgifl, zgjfl, zgkfl ! position of floats, index on + ! ! velocity mesh. + REAL(wp) , DIMENSION ( jpnfl ) :: ztxfl, ztyfl, ztzfl ! time for a float to quit the mesh + ! ! across one of the face x,y and z + REAL(wp) , DIMENSION ( jpnfl ) :: zttfl ! time for a float to quit the mesh + REAL(wp) , DIMENSION ( jpnfl ) :: zagefl ! time during which, trajectorie of + ! ! the float has been computed + REAL(wp) , DIMENSION ( jpnfl ) :: zagenewfl ! new age of float after calculation + ! ! of new position + REAL(wp) , DIMENSION ( jpnfl ) :: zufl, zvfl, zwfl ! interpolated vel. at float position + REAL(wp) , DIMENSION ( jpnfl ) :: zudfl, zvdfl, zwdfl ! velocity diff input/output of mesh + REAL(wp) , DIMENSION ( jpnfl ) :: zgidfl, zgjdfl, zgkdfl ! direction index of float + !!--------------------------------------------------------------------- + + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'flo_blk : compute Blanke trajectories for floats ' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + + ! Initialisation of parameters + + DO jfl = 1, jpnfl + ! ages of floats are put at zero + zagefl(jfl) = 0. + ! index on the velocity grid + ! We considere k coordinate negative, with this transformation + ! the computation in the 3 direction is the same. + zgifl(jfl) = tpifl(jfl) - 0.5 + zgjfl(jfl) = tpjfl(jfl) - 0.5 + zgkfl(jfl) = MIN(-1.,-(tpkfl(jfl))) + ! surface drift every 10 days + IF( ln_argo ) THEN + IF( MOD(kt,150) >= 146 .OR. MOD(kt,150) == 0 ) zgkfl(jfl) = -1. + ENDIF + ! index of T mesh + iil(jfl) = 1 + INT(zgifl(jfl)) + ijl(jfl) = 1 + INT(zgjfl(jfl)) + ikl(jfl) = INT(zgkfl(jfl)) + END DO + + iloop = 0 +222 DO jfl = 1, jpnfl +# if ! defined key_mpi_off + IF( iil(jfl) >= mig(Nis0) .AND. iil(jfl) <= mig(Nie0) .AND. & + ijl(jfl) >= mjg(Njs0) .AND. ijl(jfl) <= mjg(Nje0) ) THEN + iiloc(jfl) = iil(jfl) - mig(1) + 1 + ijloc(jfl) = ijl(jfl) - mjg(1) + 1 +# else + iiloc(jfl) = iil(jfl) + ijloc(jfl) = ijl(jfl) +# endif + + ! compute the transport across the mesh where the float is. +!!bug (gm) change e3t into e3. but never checked + zsurfx(1) = & + & e2u(iiloc(jfl)-1,ijloc(jfl) ) & + & * e3u(iiloc(jfl)-1,ijloc(jfl) ,-ikl(jfl),Kmm) + zsurfx(2) = & + & e2u(iiloc(jfl) ,ijloc(jfl) ) & + & * e3u(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl),Kmm) + zsurfy(1) = & + & e1v(iiloc(jfl) ,ijloc(jfl)-1) & + & * e3v(iiloc(jfl) ,ijloc(jfl)-1,-ikl(jfl),Kmm) + zsurfy(2) = & + & e1v(iiloc(jfl) ,ijloc(jfl) ) & + & * e3v(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl),Kmm) + + ! for a isobar float zsurfz is put to zero. The vertical velocity will be zero too. + zsurfz = e1e2t(iiloc(jfl),ijloc(jfl)) + zvol = zsurfz * e3t(iiloc(jfl),ijloc(jfl),-ikl(jfl),Kmm) + + ! + zuinfl =( uu(iiloc(jfl)-1,ijloc(jfl),-ikl(jfl),Kbb) + uu(iiloc(jfl)-1,ijloc(jfl),-ikl(jfl),Kmm) )/2.*zsurfx(1) + zuoutfl=( uu(iiloc(jfl) ,ijloc(jfl),-ikl(jfl),Kbb) + uu(iiloc(jfl) ,ijloc(jfl),-ikl(jfl),Kmm) )/2.*zsurfx(2) + zvinfl =( vv(iiloc(jfl),ijloc(jfl)-1,-ikl(jfl),Kbb) + vv(iiloc(jfl),ijloc(jfl)-1,-ikl(jfl),Kmm) )/2.*zsurfy(1) + zvoutfl=( vv(iiloc(jfl),ijloc(jfl) ,-ikl(jfl),Kbb) + vv(iiloc(jfl),ijloc(jfl) ,-ikl(jfl),Kmm) )/2.*zsurfy(2) + zwinfl =-(wb(iiloc(jfl),ijloc(jfl),-(ikl(jfl)-1)) & + & + ww(iiloc(jfl),ijloc(jfl),-(ikl(jfl)-1)) )/2. * zsurfz*nisobfl(jfl) + zwoutfl=-(wb(iiloc(jfl),ijloc(jfl),- ikl(jfl) ) & + & + ww(iiloc(jfl),ijloc(jfl),- ikl(jfl) ) )/2. * zsurfz*nisobfl(jfl) + + ! interpolation of velocity field on the float initial position + zufl(jfl)= zuinfl + ( zgifl(jfl) - float(iil(jfl)-1) ) * ( zuoutfl - zuinfl) + zvfl(jfl)= zvinfl + ( zgjfl(jfl) - float(ijl(jfl)-1) ) * ( zvoutfl - zvinfl) + zwfl(jfl)= zwinfl + ( zgkfl(jfl) - float(ikl(jfl)-1) ) * ( zwoutfl - zwinfl) + + ! faces of input and output + ! u-direction + IF( zufl(jfl) < 0. ) THEN + iioutfl(jfl) = iil(jfl) - 1. + iiinfl (jfl) = iil(jfl) + zind = zuinfl + zuinfl = zuoutfl + zuoutfl= zind + ELSE + iioutfl(jfl) = iil(jfl) + iiinfl (jfl) = iil(jfl) - 1 + ENDIF + ! v-direction + IF( zvfl(jfl) < 0. ) THEN + ijoutfl(jfl) = ijl(jfl) - 1. + ijinfl (jfl) = ijl(jfl) + zind = zvinfl + zvinfl = zvoutfl + zvoutfl = zind + ELSE + ijoutfl(jfl) = ijl(jfl) + ijinfl (jfl) = ijl(jfl) - 1. + ENDIF + ! w-direction + IF( zwfl(jfl) < 0. ) THEN + ikoutfl(jfl) = ikl(jfl) - 1. + ikinfl (jfl) = ikl(jfl) + zind = zwinfl + zwinfl = zwoutfl + zwoutfl = zind + ELSE + ikoutfl(jfl) = ikl(jfl) + ikinfl (jfl) = ikl(jfl) - 1. + ENDIF + + ! compute the time to go out the mesh across a face + ! u-direction + zudfl (jfl) = zuoutfl - zuinfl + zgidfl(jfl) = float(iioutfl(jfl) - iiinfl(jfl)) + IF( zufl(jfl)*zuoutfl <= 0. ) THEN + ztxfl(jfl) = HUGE(1._wp) + ELSE + IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN + ztxfl(jfl)= zgidfl(jfl)/zudfl(jfl) * LOG(zuoutfl/zufl (jfl)) + ELSE + ztxfl(jfl)=(float(iioutfl(jfl))-zgifl(jfl))/zufl(jfl) + ENDIF + IF( (ABS(zgifl(jfl)-float(iiinfl (jfl))) <= 1.E-7) .OR. & + (ABS(zgifl(jfl)-float(iioutfl(jfl))) <= 1.E-7) ) THEN + ztxfl(jfl)=(zgidfl(jfl))/zufl(jfl) + ENDIF + ENDIF + ! v-direction + zvdfl (jfl) = zvoutfl - zvinfl + zgjdfl(jfl) = float(ijoutfl(jfl)-ijinfl(jfl)) + IF( zvfl(jfl)*zvoutfl <= 0. ) THEN + ztyfl(jfl) = HUGE(1._wp) + ELSE + IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN + ztyfl(jfl) = zgjdfl(jfl)/zvdfl(jfl) * LOG(zvoutfl/zvfl (jfl)) + ELSE + ztyfl(jfl) = (float(ijoutfl(jfl)) - zgjfl(jfl))/zvfl(jfl) + ENDIF + IF( (ABS(zgjfl(jfl)-float(ijinfl (jfl))) <= 1.E-7) .OR. & + (ABS(zgjfl(jfl)-float(ijoutfl(jfl))) <= 1.E-7) ) THEN + ztyfl(jfl) = (zgjdfl(jfl)) / zvfl(jfl) + ENDIF + ENDIF + ! w-direction + IF( nisobfl(jfl) == 1. ) THEN + zwdfl (jfl) = zwoutfl - zwinfl + zgkdfl(jfl) = float(ikoutfl(jfl) - ikinfl(jfl)) + IF( zwfl(jfl)*zwoutfl <= 0. ) THEN + ztzfl(jfl) = HUGE(1._wp) + ELSE + IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN + ztzfl(jfl) = zgkdfl(jfl)/zwdfl(jfl) * LOG(zwoutfl/zwfl (jfl)) + ELSE + ztzfl(jfl) = (float(ikoutfl(jfl)) - zgkfl(jfl))/zwfl(jfl) + ENDIF + IF( (ABS(zgkfl(jfl)-float(ikinfl (jfl))) <= 1.E-7) .OR. & + (ABS(zgkfl(jfl)-float(ikoutfl(jfl))) <= 1.E-7) ) THEN + ztzfl(jfl) = (zgkdfl(jfl)) / zwfl(jfl) + ENDIF + ENDIF + ENDIF + + ! the time to go leave the mesh is the smallest time + + IF( nisobfl(jfl) == 1. ) THEN + zttfl(jfl) = MIN(ztxfl(jfl),ztyfl(jfl),ztzfl(jfl)) + ELSE + zttfl(jfl) = MIN(ztxfl(jfl),ztyfl(jfl)) + ENDIF + ! new age of the FLOAT + zagenewfl(jfl) = zagefl(jfl) + zttfl(jfl)*zvol + ! test to know if the "age" of the float is not bigger than the + ! time step + IF( zagenewfl(jfl) > rn_Dt ) THEN + zttfl(jfl) = (rn_Dt-zagefl(jfl)) / zvol + zagenewfl(jfl) = rn_Dt + ENDIF + + ! In the "minimal" direction we compute the index of new mesh + ! on i-direction + IF( ztxfl(jfl) <= zttfl(jfl) ) THEN + zgifl(jfl) = float(iioutfl(jfl)) + ind = iioutfl(jfl) + IF( iioutfl(jfl) >= iiinfl(jfl) ) THEN + iioutfl(jfl) = iioutfl(jfl) + 1 + ELSE + iioutfl(jfl) = iioutfl(jfl) - 1 + ENDIF + iiinfl(jfl) = ind + ELSE + IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN + zgifl(jfl) = zgifl(jfl) + zgidfl(jfl)*zufl(jfl) & + & * ( EXP( zudfl(jfl)/zgidfl(jfl)*zttfl(jfl) ) - 1. ) / zudfl(jfl) + ELSE + zgifl(jfl) = zgifl(jfl) + zufl(jfl) * zttfl(jfl) + ENDIF + ENDIF + ! on j-direction + IF( ztyfl(jfl) <= zttfl(jfl) ) THEN + zgjfl(jfl) = float(ijoutfl(jfl)) + ind = ijoutfl(jfl) + IF( ijoutfl(jfl) >= ijinfl(jfl) ) THEN + ijoutfl(jfl) = ijoutfl(jfl) + 1 + ELSE + ijoutfl(jfl) = ijoutfl(jfl) - 1 + ENDIF + ijinfl(jfl) = ind + ELSE + IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN + zgjfl(jfl) = zgjfl(jfl)+zgjdfl(jfl)*zvfl(jfl) & + & * ( EXP(zvdfl(jfl)/zgjdfl(jfl)*zttfl(jfl)) - 1. ) / zvdfl(jfl) + ELSE + zgjfl(jfl) = zgjfl(jfl)+zvfl(jfl)*zttfl(jfl) + ENDIF + ENDIF + ! on k-direction + IF( nisobfl(jfl) == 1. ) THEN + IF( ztzfl(jfl) <= zttfl(jfl) ) THEN + zgkfl(jfl) = float(ikoutfl(jfl)) + ind = ikoutfl(jfl) + IF( ikoutfl(jfl) >= ikinfl(jfl) ) THEN + ikoutfl(jfl) = ikoutfl(jfl)+1 + ELSE + ikoutfl(jfl) = ikoutfl(jfl)-1 + ENDIF + ikinfl(jfl) = ind + ELSE + IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN + zgkfl(jfl) = zgkfl(jfl)+zgkdfl(jfl)*zwfl(jfl) & + & * ( EXP(zwdfl(jfl)/zgkdfl(jfl)*zttfl(jfl)) - 1. ) / zwdfl(jfl) + ELSE + zgkfl(jfl) = zgkfl(jfl)+zwfl(jfl)*zttfl(jfl) + ENDIF + ENDIF + ENDIF + + ! coordinate of the new point on the temperature grid + + iil(jfl) = MAX(iiinfl(jfl),iioutfl(jfl)) + ijl(jfl) = MAX(ijinfl(jfl),ijoutfl(jfl)) + IF( nisobfl(jfl) == 1 ) ikl(jfl) = MAX(ikinfl(jfl),ikoutfl(jfl)) +!!Alexcadm write(*,*)'PE ',narea, +!!Alexcadm . iiinfl(jfl),iioutfl(jfl),ijinfl(jfl) +!!Alexcadm . ,ijoutfl(jfl),ikinfl(jfl), +!!Alexcadm . ikoutfl(jfl),ztxfl(jfl),ztyfl(jfl) +!!Alexcadm . ,ztzfl(jfl),zgifl(jfl), +!!Alexcadm . zgjfl(jfl) +!!Alexcadm IF (jfl == 910) write(*,*)'Flotteur 910', +!!Alexcadm . iiinfl(jfl),iioutfl(jfl),ijinfl(jfl) +!!Alexcadm . ,ijoutfl(jfl),ikinfl(jfl), +!!Alexcadm . ikoutfl(jfl),ztxfl(jfl),ztyfl(jfl) +!!Alexcadm . ,ztzfl(jfl),zgifl(jfl), +!!Alexcadm . zgjfl(jfl) + ! reinitialisation of the age of FLOAT + zagefl(jfl) = zagenewfl(jfl) +# if ! defined key_mpi_off + ELSE + ! we put zgifl, zgjfl, zgkfl, zagefl + zgifl (jfl) = 0. + zgjfl (jfl) = 0. + zgkfl (jfl) = 0. + zagefl(jfl) = 0. + iil(jfl) = 0 + ijl(jfl) = 0 + ENDIF +# endif + END DO + + ! synchronisation + CALL mpp_sum( 'floblk', zgifl , jpnfl ) ! sums over the global domain + CALL mpp_sum( 'floblk', zgjfl , jpnfl ) + CALL mpp_sum( 'floblk', zgkfl , jpnfl ) + CALL mpp_sum( 'floblk', zagefl, jpnfl ) + CALL mpp_sum( 'floblk', iil , jpnfl ) + CALL mpp_sum( 'floblk', ijl , jpnfl ) + + ! Test to know if a float hasn't integrated enought time + IF( ln_argo ) THEN + ifin = 1 + DO jfl = 1, jpnfl + IF( zagefl(jfl) < rn_Dt ) ifin = 0 + tpifl(jfl) = zgifl(jfl) + 0.5 + tpjfl(jfl) = zgjfl(jfl) + 0.5 + END DO + ELSE + ifin = 1 + DO jfl = 1, jpnfl + IF( zagefl(jfl) < rn_Dt ) ifin = 0 + tpifl(jfl) = zgifl(jfl) + 0.5 + tpjfl(jfl) = zgjfl(jfl) + 0.5 + IF( nisobfl(jfl) == 1 ) tpkfl(jfl) = -(zgkfl(jfl)) + END DO + ENDIF +!!Alexcadm IF (lwp) write(numout,*) '---------' +!!Alexcadm IF (lwp) write(numout,*) 'before Erika:',tpifl(880),tpjfl(880), +!!Alexcadm . tpkfl(880),zufl(880),zvfl(880),zwfl(880) +!!Alexcadm IF (lwp) write(numout,*) 'first Erika:',tpifl(900),tpjfl(900), +!!Alexcadm . tpkfl(900),zufl(900),zvfl(900),zwfl(900) +!!Alexcadm IF (lwp) write(numout,*) 'last Erika:',tpifl(jpnfl),tpjfl(jpnfl), +!!Alexcadm . tpkfl(jpnfl),zufl(jpnfl),zvfl(jpnfl),zwfl(jpnfl) + IF( ifin == 0 ) THEN + iloop = iloop + 1 + GO TO 222 + ENDIF +#endif + ! + ! + END SUBROUTINE flo_blk + + !!====================================================================== +END MODULE floblk \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flodom.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flodom.F90 new file mode 100644 index 0000000..3ccef91 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flodom.F90 @@ -0,0 +1,467 @@ +MODULE flodom + !!====================================================================== + !! *** MODULE flodom *** + !! Ocean floats : domain + !!====================================================================== + !! History : OPA ! 1998-07 (Y.Drillet, CLIPPER) Original code + !! NEMO 3.3 ! 2011-09 (C.Bricaud,S.Law-Chune Mercator-Ocean): add ARIANE convention + comsecitc changes + !!---------------------------------------------------------------------- + !! flo_dom : initialization of floats + !! add_new_floats : add new floats (long/lat/depth) + !! add_new_ariane_floats : add new floats with araine convention (i/j/k) + !! findmesh : compute index of position + !! dstnce : compute distance between face mesh and floats + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE flo_oce ! ocean drifting floats + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC flo_dom ! routine called by floats.F90 + PUBLIC flo_dom_alloc ! Routine called in floats.F90 + + CHARACTER (len=21) :: clname1 = 'init_float' ! floats initialisation filename + CHARACTER (len=21) :: clname2 = 'init_float_ariane' ! ariane floats initialisation filename + + + INTEGER , ALLOCATABLE, DIMENSION(:) :: iimfl, ijmfl, ikmfl ! index mesh of floats + INTEGER , ALLOCATABLE, DIMENSION(:) :: idomfl, ivtest, ihtest ! - + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zgifl, zgjfl, zgkfl ! distances in indexes + + !! * Substitutions +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: flodom.F90 15235 2021-09-08 14:07:36Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE flo_dom( Kmm ) + !! --------------------------------------------------------------------- + !! *** ROUTINE flo_dom *** + !! + !! ** Purpose : Initialisation of floats + !! + !! ** Method : We put the floats in the domain with the latitude, + !! the longitude (degree) and the depth (m). + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + INTEGER :: jfl ! dummy loop + INTEGER :: inum ! logical unit for file read + !!--------------------------------------------------------------------- + + ! Initialisation with the geographical position or restart + + IF(lwp) WRITE(numout,*) 'flo_dom : compute initial position of floats' + IF(lwp) WRITE(numout,*) '~~~~~~~~' + IF(lwp) WRITE(numout,*) ' jpnfl = ',jpnfl + + !-------------------------! + ! FLOAT RESTART FILE READ ! + !-------------------------! + IF( ln_rstflo )THEN + + IF(lwp) WRITE(numout,*) ' float restart file read' + + ! open the restart file + !---------------------- + CALL ctl_opn( inum, 'restart_float', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) + + ! read of the restart file + READ(inum,*) ( tpifl (jfl), jfl=1, jpnrstflo), & + ( tpjfl (jfl), jfl=1, jpnrstflo), & + ( tpkfl (jfl), jfl=1, jpnrstflo), & + ( nisobfl(jfl), jfl=1, jpnrstflo), & + ( ngrpfl (jfl), jfl=1, jpnrstflo) + CLOSE(inum) + + ! if we want a surface drift ( like PROVOR floats ) + IF( ln_argo ) nisobfl(1:jpnrstflo) = 0 + + ! It is possible to add new floats. + !--------------------------------- + IF( jpnfl > jpnrstflo )THEN + + IF(lwp) WRITE(numout,*) ' add new floats' + + IF( ln_ariane )THEN !Add new floats with ariane convention + CALL flo_add_new_ariane_floats(jpnrstflo+1,jpnfl) + ELSE !Add new floats with long/lat convention + CALL flo_add_new_floats(Kmm,jpnrstflo+1,jpnfl) + ENDIF + ENDIF + + !--------------------------------------! + ! FLOAT INITILISATION: NO RESTART FILE ! + !--------------------------------------! + ELSE !ln_rstflo + + IF( ln_ariane )THEN !Add new floats with ariane convention + CALL flo_add_new_ariane_floats(1,jpnfl) + ELSE !Add new floats with long/lat convention + CALL flo_add_new_floats(Kmm,1,jpnfl) + ENDIF + + ENDIF + + END SUBROUTINE flo_dom + + SUBROUTINE flo_add_new_floats(Kmm, kfl_start, kfl_end) + !! ------------------------------------------------------------- + !! *** SUBROUTINE add_new_arianefloats *** + !! + !! ** Purpose : + !! + !! First initialisation of floats + !! the initials positions of floats are written in a file + !! with a variable to know if it is a isobar float a number + !! to identified who want the trajectories of this float and + !! an index for the number of the float + !! open the init file + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm + INTEGER, INTENT(in) :: kfl_start, kfl_end + !! + INTEGER :: inum ! file unit + INTEGER :: jfl,ji, jj, jk ! dummy loop indices + INTEGER :: itrash ! trash var for reading + INTEGER :: ifl ! number of floats to read + REAL(wp) :: zdxab, zdyad + LOGICAL :: llinmesh + CHARACTER(len=80) :: cltmp + !!--------------------------------------------------------------------- + ifl = kfl_end-kfl_start+1 + + ! we get the init values + !----------------------- + CALL ctl_opn( inum , clname1, 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) + DO jfl = kfl_start,kfl_end + READ(inum,*) flxx(jfl),flyy(jfl),flzz(jfl), nisobfl(jfl),ngrpfl(jfl),itrash + if(lwp)write(numout,*)'read:',jfl,flxx(jfl),flyy(jfl),flzz(jfl), nisobfl(jfl),ngrpfl(jfl),itrash ; call flush(numout) + END DO + CLOSE(inum) + + ! Test to find the grid point coordonate with the geographical position + !---------------------------------------------------------------------- + DO jfl = kfl_start,kfl_end + ihtest(jfl) = 0 + ivtest(jfl) = 0 + ikmfl(jfl) = 0 +# if ! defined key_mpi_off + DO ji = MAX(Nis0,2), Nie0 + DO jj = MAX(Njs0,2), Nje0 ! NO vector opt. +# else + DO ji = 2, jpi + DO jj = 2, jpj ! NO vector opt. +# endif + ! For each float we find the indexes of the mesh + CALL flo_findmesh(glamf(ji-1,jj-1),gphif(ji-1,jj-1), & + glamf(ji-1,jj ),gphif(ji-1,jj ), & + glamf(ji ,jj ),gphif(ji ,jj ), & + glamf(ji ,jj-1),gphif(ji ,jj-1), & + flxx(jfl) ,flyy(jfl) , & + glamt(ji ,jj ),gphit(ji ,jj ), llinmesh) + IF( llinmesh )THEN + iimfl(jfl) = ji + ijmfl(jfl) = jj + ihtest(jfl) = ihtest(jfl)+1 + DO jk = 1, jpk-1 + IF( (gdepw(ji,jj,jk,Kmm) <= flzz(jfl)) .AND. (gdepw(ji,jj,jk+1,Kmm) > flzz(jfl)) ) THEN + ikmfl(jfl) = jk + ivtest(jfl) = ivtest(jfl) + 1 + ENDIF + END DO + ENDIF + END DO + END DO + + ! If the float is in a mesh computed by an other processor we put iimfl=ijmfl=-1 + IF( ihtest(jfl) == 0 ) THEN + iimfl(jfl) = -1 + ijmfl(jfl) = -1 + ENDIF + END DO + + !Test if each float is in one and only one proc + !---------------------------------------------- + IF( lk_mpp ) THEN + CALL mpp_sum('flodom', ihtest,jpnfl) + CALL mpp_sum('flodom', ivtest,jpnfl) + ENDIF + DO jfl = kfl_start,kfl_end + + IF( (ihtest(jfl) > 1 ) .OR. ( ivtest(jfl) > 1) ) THEN + WRITE(cltmp,'(A10,i4.4,A20)' )'THE FLOAT',jfl,' IS NOT IN ONLY ONE MESH' + CALL ctl_stop('STOP',TRIM(cltmp) ) + ENDIF + IF( (ihtest(jfl) == 0) ) THEN + WRITE(cltmp,'(A10,i4.4,A20)' )'THE FLOAT',jfl,' IS IN NO MESH' + CALL ctl_stop('STOP',TRIM(cltmp) ) + ENDIF + END DO + + ! We compute the distance between the float and the face of the mesh + !------------------------------------------------------------------- + DO jfl = kfl_start,kfl_end + + ! Made only if the float is in the domain of the processor + IF( (iimfl(jfl) >= 0) .AND. (ijmfl(jfl) >= 0) ) THEN + + ! TEST TO KNOW IF THE FLOAT IS NOT INITIALISED IN THE COAST + idomfl(jfl) = 0 + IF( tmask(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)) == 0. ) idomfl(jfl) = 1 + + ! Computation of the distance between the float and the faces of the mesh + ! zdxab + ! . + ! B----.---------C + ! | . | + ! |<------>flo | + ! | ^ | + ! | |.....|....zdyad + ! | | | + ! A--------|-----D + ! + zdxab = flo_dstnce( flxx(jfl), flyy(jfl), glamf(iimfl(jfl)-1,ijmfl(jfl)-1), flyy(jfl) ) + zdyad = flo_dstnce( flxx(jfl), flyy(jfl), flxx(jfl), gphif(iimfl(jfl)-1,ijmfl(jfl)-1) ) + + ! Translation of this distances (in meter) in indexes + zgifl(jfl)= (iimfl(jfl)-0.5) + zdxab/e1u(iimfl(jfl)-1,ijmfl(jfl)) + (mig(1)-1) + zgjfl(jfl)= (ijmfl(jfl)-0.5) + zdyad/e2v(iimfl(jfl),ijmfl(jfl)-1) + (mjg(1)-1) + zgkfl(jfl) = (( gdepw(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1,Kmm) - flzz(jfl) )* ikmfl(jfl)) & + & / ( gdepw(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1,Kmm) & + & - gdepw(iimfl(jfl),ijmfl(jfl),ikmfl(jfl) ,Kmm) ) & + & + (( flzz(jfl)-gdepw(iimfl(jfl),ijmfl(jfl),ikmfl(jfl),Kmm) ) *(ikmfl(jfl)+1)) & + & / ( gdepw(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1,Kmm) & + & - gdepw(iimfl(jfl),ijmfl(jfl),ikmfl(jfl),Kmm) ) + ELSE + zgifl(jfl) = 0.e0 + zgjfl(jfl) = 0.e0 + zgkfl(jfl) = 0.e0 + ENDIF + + END DO + + ! The sum of all the arrays zgifl, zgjfl, zgkfl give 3 arrays with the positions of all the floats. + IF( lk_mpp ) THEN + CALL mpp_sum( 'flodom', zgjfl, ifl ) ! sums over the global domain + CALL mpp_sum( 'flodom', zgkfl, ifl ) + ENDIF + + DO jfl = kfl_start,kfl_end + tpifl(jfl) = zgifl(jfl) + tpjfl(jfl) = zgjfl(jfl) + tpkfl(jfl) = zgkfl(jfl) + END DO + + ! WARNING : initial position not in the sea + IF( .NOT. ln_rstflo ) THEN + DO jfl = kfl_start,kfl_end + IF( idomfl(jfl) == 1 ) THEN + IF(lwp) WRITE(numout,*)'*****************************' + IF(lwp) WRITE(numout,*)'!!!!!!! WARNING !!!!!!!!!!' + IF(lwp) WRITE(numout,*)'*****************************' + IF(lwp) WRITE(numout,*)'The float number',jfl,'is out of the sea.' + IF(lwp) WRITE(numout,*)'geographical position',flxx(jfl),flyy(jfl),flzz(jfl) + IF(lwp) WRITE(numout,*)'index position',tpifl(jfl),tpjfl(jfl),tpkfl(jfl) + ENDIF + END DO + ENDIF + + END SUBROUTINE flo_add_new_floats + + SUBROUTINE flo_add_new_ariane_floats(kfl_start, kfl_end) + !! ------------------------------------------------------------- + !! *** SUBROUTINE add_new_arianefloats *** + !! + !! ** Purpose : + !! First initialisation of floats with ariane convention + !! + !! The indexes are read directly from file (warning ariane + !! convention, are refered to + !! U,V,W grids - and not T-) + !! The isobar advection is managed with the sign of tpkfl ( >0 -> 3D + !! advection, <0 -> 2D) + !! Some variables are not read, as - gl : time index; 4th + !! column + !! - transport : transport ; 5th + !! column + !! and paste in the jtrash var + !! At the end, ones need to replace the indexes on T grid + !! RMQ : there is no float groups identification ! + !! + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kfl_start, kfl_end + !! + INTEGER :: inum ! file unit + INTEGER :: ierr, ifl + INTEGER :: jfl, jfl1 ! dummy loop indices + INTEGER :: itrash ! trash var for reading + CHARACTER(len=80) :: cltmp + + !!---------------------------------------------------------------------- + nisobfl(kfl_start:kfl_end) = 1 ! we assume that by default we want 3D advection + + ifl = kfl_end - kfl_start + 1 ! number of floats to read + + ! we check that the number of floats in the init_file are consistant with the namelist + IF( lwp ) THEN + + jfl1=0 + ierr=0 + CALL ctl_opn( inum, clname2, 'OLD', 'FORMATTED', 'SEQUENTIAL', 1, numout, .TRUE., 1 ) + DO WHILE (ierr .EQ. 0) + jfl1=jfl1+1 + READ(inum,*, iostat=ierr) + END DO + CLOSE(inum) + IF( (jfl1-1) .NE. ifl )THEN + WRITE(cltmp,'(A25,A20,A3,i4.4,A10,i4.4)')"the number of floats in ",TRIM(clname2), & + " = ",jfl1," is not equal to jfl= ",ifl + CALL ctl_stop('STOP',TRIM(cltmp) ) + ENDIF + + ENDIF + + ! we get the init values + CALL ctl_opn( inum, clname2, 'OLD', 'FORMATTED', 'SEQUENTIAL', 1, numout, .TRUE., 1 ) + DO jfl = kfl_start, kfl_end + READ(inum,*) tpifl(jfl),tpjfl(jfl),tpkfl(jfl),itrash, itrash + + IF ( tpkfl(jfl) .LT. 0. ) nisobfl(jfl) = 0 !set the 2D advection according to init_float + ngrpfl(jfl)=jfl + END DO + + ! conversion from ariane index to T grid index + tpkfl(kfl_start:kfl_end) = abs(tpkfl)-0.5 ! reversed vertical axis + tpifl(kfl_start:kfl_end) = tpifl+0.5 + tpjfl(kfl_start:kfl_end) = tpjfl+0.5 + + + END SUBROUTINE flo_add_new_ariane_floats + + + SUBROUTINE flo_findmesh( pax, pay, pbx, pby, & + pcx, pcy, pdx, pdy, & + px ,py ,ptx, pty, ldinmesh ) + !! ------------------------------------------------------------- + !! *** ROUTINE findmesh *** + !! + !! ** Purpose : Find the index of mesh for the point spx spy + !! + !! ** Method : + !!---------------------------------------------------------------------- + REAL(wp) :: & + pax, pay, pbx, pby, & ! ??? + pcx, pcy, pdx, pdy, & ! ??? + px, py, & ! longitude and latitude + ptx, pty ! ??? + LOGICAL :: ldinmesh ! ??? + !! + REAL(wp) :: zabt, zbct, zcdt, zdat, zabpt, zbcpt, zcdpt, zdapt + !!--------------------------------------------------------------------- + + ! 4 semi plane defined by the 4 points and including the T point + zabt = fsline(pax,pay,pbx,pby,ptx,pty) + zbct = fsline(pbx,pby,pcx,pcy,ptx,pty) + zcdt = fsline(pcx,pcy,pdx,pdy,ptx,pty) + zdat = fsline(pdx,pdy,pax,pay,ptx,pty) + + ! 4 semi plane defined by the 4 points and including the extrememity + zabpt = fsline(pax,pay,pbx,pby,px,py) + zbcpt = fsline(pbx,pby,pcx,pcy,px,py) + zcdpt = fsline(pcx,pcy,pdx,pdy,px,py) + zdapt = fsline(pdx,pdy,pax,pay,px,py) + + ! We compare the semi plane T with the semi plane including the point + ! to know if it is in this mesh. + ! For numerical reasons it is possible that for a point which is on + ! the line we don't have exactly zero with fsline function. We want + ! that a point can't be in 2 mesh in the same time, so we put the + ! coefficient to zero if it is smaller than 1.E-12 + + IF( ABS(zabpt) <= 1.E-12 ) zabpt = 0. + IF( ABS(zbcpt) <= 1.E-12 ) zbcpt = 0. + IF( ABS(zcdpt) <= 1.E-12 ) zcdpt = 0. + IF( ABS(zdapt) <= 1.E-12 ) zdapt = 0. + IF( (zabt*zabpt > 0.) .AND. (zbct*zbcpt >= 0. ) .AND. ( zcdt*zcdpt >= 0. ) .AND. ( zdat*zdapt > 0. ) & + .AND. ( px <= MAX(pcx,pdx) ) .AND. ( px >= MIN(pax,pbx) ) & + .AND. ( py <= MAX(pby,pcy) ) .AND. ( py >= MIN(pay,pdy) ) ) THEN + ldinmesh=.TRUE. + ELSE + ldinmesh=.FALSE. + ENDIF + ! + END SUBROUTINE flo_findmesh + + FUNCTION fsline( psax, psay, psbx, psby, psx, psy ) + !! --------------------------------------------------------------------- + !! *** Function fsline *** + !! + !! ** Purpose : + !! ** Method : + !!---------------------------------------------------------------------- + REAL(wp) :: fsline + REAL(wp), INTENT(in) :: psax, psay, psbx, psby, psx, psy + !!--------------------------------------------------------------------- + fsline = psy * ( psbx - psax ) & + & - psx * ( psby - psay ) & + & + psax * psby - psay * psbx + ! + END FUNCTION fsline + + FUNCTION flo_dstnce( pla1, phi1, pla2, phi2 ) + !! ------------------------------------------------------------- + !! *** Function dstnce *** + !! + !! ** Purpose : returns distance (in m) between two geographical + !! points + !! ** Method : + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pla1, phi1, pla2, phi2 ! ??? + !! + REAL(wp) :: dly1, dly2, dlx1, dlx2, dlx, dls, dld, dpi + REAL(wp) :: flo_dstnce + !!--------------------------------------------------------------------- + ! + dpi = 2._wp * ASIN(1._wp) + dls = dpi / 180._wp + dly1 = phi1 * dls + dly2 = phi2 * dls + dlx1 = pla1 * dls + dlx2 = pla2 * dls + ! + dlx = SIN(dly1) * SIN(dly2) + COS(dly1) * COS(dly2) * COS(dlx2-dlx1) + ! + IF( ABS(dlx) > 1.0_wp ) dlx = 1.0_wp + ! + dld = ATAN(SQRT( 1._wp * ( 1._wp-dlx )/( 1._wp+dlx ) )) * 222.24_wp / dls + flo_dstnce = dld * 1000._wp + ! + END FUNCTION flo_dstnce + + INTEGER FUNCTION flo_dom_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION flo_dom_alloc *** + !!---------------------------------------------------------------------- + + ALLOCATE( iimfl(jpnfl) , ijmfl(jpnfl) , ikmfl(jpnfl) , & + idomfl(jpnfl), ivtest(jpnfl), ihtest(jpnfl), & + zgifl(jpnfl) , zgjfl(jpnfl) , zgkfl(jpnfl) , STAT=flo_dom_alloc ) + ! + CALL mpp_sum ( 'flodom', flo_dom_alloc ) + IF( flo_dom_alloc /= 0 ) CALL ctl_stop( 'STOP', 'flo_dom_alloc: failed to allocate arrays' ) + END FUNCTION flo_dom_alloc + + !!====================================================================== +END MODULE flodom \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/florst.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/florst.F90 new file mode 100644 index 0000000..5fe115e --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/florst.F90 @@ -0,0 +1,124 @@ +MODULE florst + !!====================================================================== + !! *** MODULE florst *** + !! Ocean floats : write floats restart files + !!====================================================================== + !! History : OPA ! 1999-09 (Y. Drillet) : Original code + !! - ! 2000-06 (J.-M. Molines) : Profiling floats for CLS + !! NEMO 1.0 ! 2002-10 (A. Bozec) F90 : Free form and module + !! 3.2 ! 2010-08 (slaw, cbricaud): netcdf outputs and others + !!---------------------------------------------------------------------- + USE flo_oce ! ocean drifting floats + USE dom_oce ! ocean space and time domain + USE lib_mpp ! distribued memory computing library + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC flo_rst ! routine called by floats.F90 + PUBLIC flo_rst_alloc ! routine called by floats.F90 + + INTEGER, ALLOCATABLE, DIMENSION(:) :: iperproc ! 1D workspace + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: florst.F90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION flo_rst_alloc() + !!------------------------------------------------------------------- + !! *** FUNCTION flo_rst_alloc *** + !!------------------------------------------------------------------- + ALLOCATE( iperproc(jpnij), STAT=flo_rst_alloc ) + ! + CALL mpp_sum ( 'florst', flo_rst_alloc ) + IF( flo_rst_alloc /= 0 ) CALL ctl_stop( 'STOP', 'flo_rst_alloc: failed to allocate arrays.' ) + END FUNCTION flo_rst_alloc + + + SUBROUTINE flo_rst( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE flo_rst *** + !! + !! ** Purpose : + !! + !! + !! ** Method : The frequency of ??? is nwritefl + !! + !!---------------------------------------------------------------------- + INTEGER :: kt ! time step + ! + CHARACTER (len=80) :: clname ! restart filename + INTEGER :: ic , jc , jpn ,jfl ! temporary integer + INTEGER :: inum ! temporary logical unit for restart file + !!---------------------------------------------------------------------- + + IF( ( MOD(kt,nn_stockfl) == 0 ) .OR. ( kt == nitend ) )THEN + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'flo_rst : write in restart_float file ' + WRITE(numout,*) '~~~~~~~ ' + ENDIF + + ! file is opened and closed every time it is used. + + clname = 'restart.float.' + ic = 1 + DO jc = 1, 16 + IF( cexper(jc:jc) /= ' ' ) ic = jc + END DO + clname = clname(1:14)//cexper(1:ic) + ic = 1 + DO jc = 1, 48 + IF( clname(jc:jc) /= ' ' ) ic = jc + END DO + + inum=0 + IF( lwp )THEN + CALL ctl_opn( inum, clname, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + REWIND inum + ENDIF + ! + DO jpn = 1, jpnij + iperproc(jpn) = 0 + END DO + ! + IF(lwp) THEN + REWIND(inum) + WRITE (inum,*) tpifl,tpjfl,tpkfl,nisobfl,ngrpfl + CLOSE (inum) + ENDIF + ! + ! Compute the number of trajectories for each processor + ! + IF( lk_mpp ) THEN + DO jfl = 1, jpnfl + IF( (INT(tpifl(jfl)) >= mig(Nis0)) .AND. & + &(INT(tpifl(jfl)) <= mig(Nie0)) .AND. & + &(INT(tpjfl(jfl)) >= mjg(Njs0)) .AND. & + &(INT(tpjfl(jfl)) <= mjg(Nje0)) ) THEN + iperproc(narea) = iperproc(narea)+1 + ENDIF + END DO + CALL mpp_sum( 'florst', iperproc, jpnij ) + ! + IF(lwp) THEN + WRITE(numout,*) 'DATE',adatrj + DO jpn = 1, jpnij + IF( iperproc(jpn) /= 0 ) THEN + WRITE(numout,*)'PROCESSOR',jpn-1,'compute',iperproc(jpn), 'trajectories.' + ENDIF + END DO + ENDIF + ENDIF + ! + ENDIF + ! + END SUBROUTINE flo_rst + + !!======================================================================= +END MODULE florst \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flowri.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flowri.F90 new file mode 100644 index 0000000..8eb4022 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/FLO/flowri.F90 @@ -0,0 +1,278 @@ +MODULE flowri + !!====================================================================== + !! *** MODULE flowri *** + !! + !! Ocean floats: write floats trajectory in ascii ln_flo_ascii = T + !! or in netcdf ( IOM or IOSPSL ) ln_flo_ascii = F + !!====================================================================== + !! History : OPA ! 1999-09 (Y. Drillet) : Original code + !! - ! 2000-06 (J.-M. Molines) : Profiling floats for CLS + !! NEMO 1.0 ! 2002-10 (A. Bozec) F90 : Free form and module + !! 3.2 ! 2010-08 (slaw, cbricaud): netcdf outputs and others + !!---------------------------------------------------------------------- + USE flo_oce ! ocean drifting floats + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE lib_mpp ! distribued memory computing library + USE in_out_manager ! I/O manager + USE phycst ! physic constants + USE dianam ! build name of file (routine) + USE ioipsl + USE iom ! I/O library + + IMPLICIT NONE + PRIVATE + + PUBLIC flo_wri ! routine called by floats.F90 + PUBLIC flo_wri_alloc ! routine called by floats.F90 + + INTEGER :: jfl ! number of floats + CHARACTER (len=80) :: clname ! netcdf output filename + + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zlon , zlat, zdep ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:) :: ztem , zsal, zrho ! 2D workspace + + !! * Substitutions +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: flowri.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION flo_wri_alloc() + !!------------------------------------------------------------------- + !! *** FUNCTION flo_wri_alloc *** + !!------------------------------------------------------------------- + ALLOCATE( ztem(jpnfl) , zsal(jpnfl) , zrho(jpnfl) , & + zlon(jpnfl) , zlat(jpnfl) , zdep(jpnfl) , STAT=flo_wri_alloc) + ! + CALL mpp_sum ( 'flowri', flo_wri_alloc ) + IF( flo_wri_alloc /= 0 ) CALL ctl_stop( 'STOP', 'flo_wri_alloc: failed to allocate arrays.' ) + END FUNCTION flo_wri_alloc + + SUBROUTINE flo_wri( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE flo_wri *** + !! + !! ** Purpose : Write position of floats in "trajec_float.nc",according + !! to ARIANE TOOLS (http://stockage.univ-brest.fr/~grima/Ariane/ ) n + !! nomenclature + !! + !! + !! ** Method : The frequency of ??? is nwritefl + !! + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(in) :: kt ! time step + INTEGER, INTENT(in) :: Kmm ! time level index + + !! * Local declarations + INTEGER :: iafl , ibfl , icfl ! temporary integer + INTEGER :: ia1fl, ib1fl, ic1fl ! " + INTEGER :: iafloc,ibfloc,ia1floc,ib1floc ! " + INTEGER :: irec, irecflo + + REAL(wp) :: zafl,zbfl,zcfl ! temporary real + REAL(wp) :: ztime ! " + + INTEGER, DIMENSION(2) :: icount + INTEGER, DIMENSION(2) :: istart + INTEGER, DIMENSION(1) :: ish + INTEGER, DIMENSION(2) :: ish2 + !!---------------------------------------------------------------------- + + !----------------------------------------------------- + ! I- Save positions, temperature, salinty and density + !----------------------------------------------------- + zlon(:)=0.0 ; zlat(:)=0.0 ; zdep(:)=0.0 + ztem(:)=0.0 ; zsal(:)=0.0 ; zrho(:)=0.0 + + DO jfl = 1, jpnfl + + iafl = INT (tpifl(jfl)) ! I-index of the nearest point before + ibfl = INT (tpjfl(jfl)) ! J-index of the nearest point before + icfl = INT (tpkfl(jfl)) ! K-index of the nearest point before + ia1fl = iafl + 1 ! I-index of the nearest point after + ib1fl = ibfl + 1 ! J-index of the nearest point after + ic1fl = icfl + 1 ! K-index of the nearest point after + zafl = tpifl(jfl) - REAL(iafl,wp) ! distance ????? + zbfl = tpjfl(jfl) - REAL(ibfl,wp) ! distance ????? + zcfl = tpkfl(jfl) - REAL(icfl,wp) ! distance ????? + + IF( lk_mpp ) THEN + + iafloc = mi1( iafl ) + ibfloc = mj1( ibfl ) + + IF( Nis0 <= iafloc .AND. iafloc <= Nie0 .AND. & + & Njs0 <= ibfloc .AND. ibfloc <= Nje0 ) THEN + + !the float is inside of current proc's area + ia1floc = iafloc + 1 + ib1floc = ibfloc + 1 + + !save position of the float + zlat(jfl) = (1.-zafl)*(1.-zbfl)*gphit(iafloc ,ibfloc ) + (1.-zafl) * zbfl * gphit(iafloc ,ib1floc) & + + zafl *(1.-zbfl)*gphit(ia1floc,ibfloc ) + zafl * zbfl * gphit(ia1floc,ib1floc) + zlon(jfl) = (1.-zafl)*(1.-zbfl)*glamt(iafloc ,ibfloc ) + (1.-zafl) * zbfl * glamt(iafloc ,ib1floc) & + + zafl *(1.-zbfl)*glamt(ia1floc,ibfloc ) + zafl * zbfl * glamt(ia1floc,ib1floc) + zdep(jfl) = (1.-zcfl)*gdepw(iafloc,ibfloc,icfl ,Kmm) + zcfl * gdepw(iafloc,ibfloc,ic1fl,Kmm) + + !save temperature, salinity and density at this position + ztem(jfl) = ts(iafloc,ibfloc,icfl,jp_tem,Kmm) + zsal (jfl) = ts(iafloc,ibfloc,icfl,jp_sal,Kmm) + zrho (jfl) = (rhd(iafloc,ibfloc,icfl)+1)*rho0 + + ENDIF + + ELSE ! mono proc case + + iafloc = iafl + ibfloc = ibfl + ia1floc = iafloc + 1 + ib1floc = ibfloc + 1 + + !save position of the float + zlat(jfl) = (1.-zafl)*(1.-zbfl)*gphit(iafloc ,ibfloc ) + (1.-zafl) * zbfl * gphit(iafloc ,ib1floc) & + + zafl *(1.-zbfl)*gphit(ia1floc,ibfloc ) + zafl * zbfl * gphit(ia1floc,ib1floc) + zlon(jfl) = (1.-zafl)*(1.-zbfl)*glamt(iafloc ,ibfloc ) + (1.-zafl) * zbfl * glamt(iafloc ,ib1floc) & + + zafl *(1.-zbfl)*glamt(ia1floc,ibfloc ) + zafl * zbfl * glamt(ia1floc,ib1floc) + zdep(jfl) = (1.-zcfl)*gdepw(iafloc,ibfloc,icfl ,Kmm) + zcfl * gdepw(iafloc,ibfloc,ic1fl,Kmm) + + ztem(jfl) = ts(iafloc,ibfloc,icfl,jp_tem,Kmm) + zsal(jfl) = ts(iafloc,ibfloc,icfl,jp_sal,Kmm) + zrho(jfl) = (rhd(iafloc,ibfloc,icfl)+1)*rho0 + + ENDIF + + END DO ! loop on float + + !Only proc 0 writes all positions : SUM of positions on all procs + IF( lk_mpp ) THEN + CALL mpp_sum( 'flowri', zlon, jpnfl ) ! sums over the global domain + CALL mpp_sum( 'flowri', zlat, jpnfl ) ! sums over the global domain + CALL mpp_sum( 'flowri', zdep, jpnfl ) ! sums over the global domain + CALL mpp_sum( 'flowri', ztem, jpnfl ) ! sums over the global domain + CALL mpp_sum( 'flowri', zsal, jpnfl ) ! sums over the global domain + CALL mpp_sum( 'flowri', zrho, jpnfl ) ! sums over the global domain + ENDIF + + + !-------------------------------------! + ! II- WRITE WRITE WRITE WRITE WRITE ! + !-------------------------------------! + + !--------------------------! + ! II-1 Write in ascii file ! + !--------------------------! + + IF( ln_flo_ascii )THEN + + IF( ( kt == nn_it000 .OR. MOD( kt,nn_writefl)== 0 ) .AND. lwp )THEN + + !II-1-a Open ascii file + !---------------------- + IF( kt == nn_it000 ) THEN + CALL ctl_opn( numflo, 'trajec_float', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + irecflo = NINT( (nitend-nn_it000) / FLOAT(nn_writefl) ) + WRITE(numflo,*) cexper, irecflo, jpnfl, nn_writefl + ENDIF + + !II-1-b Write in ascii file + !----------------------------- + WRITE(numflo,*) zlon,zlat,zdep,nisobfl,ngrpfl,ztem,zsal, FLOAT(ndastp) + + + !II-1-c Close netcdf file + !------------------------- + IF( kt == nitend ) CLOSE( numflo ) + + ENDIF + + !----------------------------------------------------- + ! II-2 Write in netcdf file + !----------------------------------------------------- + + ELSE + + !II-2-a Write with IOM + !---------------------- + +#if defined key_xios + CALL iom_put( "traj_lon" , zlon ) + CALL iom_put( "traj_lat" , zlat ) + CALL iom_put( "traj_dep" , zdep ) + CALL iom_put( "traj_temp" , ztem ) + CALL iom_put( "traj_salt" , zsal ) + CALL iom_put( "traj_dens" , zrho ) + CALL iom_put( "traj_group" , REAL(ngrpfl,wp) ) +#else + + !II-2-b Write with IOIPSL + !------------------------ + + IF( ( kt == nn_it000 .OR. MOD( kt,nn_writefl)== 0 ) .AND. lwp )THEN + + + !II-2-b-1 Open netcdf file + !------------------------- + IF( kt==nn_it000 )THEN ! Create and open + + CALL dia_nam( clname, nn_writefl, 'trajec_float' ) + clname=TRIM(clname)//".nc" + + CALL fliocrfd( clname , (/'ntraj' , ' t' /), (/ jpnfl , -1/) , numflo ) + + CALL fliodefv( numflo, 'traj_lon' , (/1,2/), v_t=flio_r8, long_name="Longitude" , units="degrees_east" ) + CALL fliodefv( numflo, 'traj_lat' , (/1,2/), v_t=flio_r8, long_name="Latitude" , units="degrees_north" ) + CALL fliodefv( numflo, 'traj_depth' , (/1,2/), v_t=flio_r8, long_name="Depth" , units="meters" ) + CALL fliodefv( numflo, 'time_counter', (/2/) , v_t=flio_r8, long_name="Time axis" & + & , units="seconds since start of the run " ) + CALL fliodefv( numflo, 'traj_temp' , (/1,2/), v_t=flio_r8, long_name="Temperature" , units="C" ) + CALL fliodefv( numflo, 'traj_salt' , (/1,2/), v_t=flio_r8, long_name="Salinity" , units="PSU" ) + CALL fliodefv( numflo, 'traj_dens' , (/1,2/), v_t=flio_r8, long_name="Density" , units="kg/m3" ) + CALL fliodefv( numflo, 'traj_group' , (/1/) , v_t=flio_r8, long_name="number of the group" , units="no unit" ) + + CALL flioputv( numflo , 'traj_group' , REAL(ngrpfl,wp) ) + + ELSE ! Re-open + + CALL flioopfd( TRIM(clname), numflo , "WRITE" ) + + ENDIF + + !II-2-b-2 Write in netcdf file + !------------------------------- + irec = INT( (kt-nn_it000+1)/nn_writefl ) +1 + ztime = ( kt-nn_it000 + 1 ) * rn_Dt + + CALL flioputv( numflo , 'time_counter', ztime , start=(/irec/) ) + + DO jfl = 1, jpnfl + + istart = (/jfl,irec/) + + CALL flioputv( numflo , 'traj_lon' , zlon(jfl), start=istart ) + CALL flioputv( numflo , 'traj_lat' , zlat(jfl), start=istart ) + CALL flioputv( numflo , 'traj_depth' , zdep(jfl), start=istart ) + CALL flioputv( numflo , 'traj_temp' , ztem(jfl), start=istart ) + CALL flioputv( numflo , 'traj_salt' , zsal(jfl), start=istart ) + CALL flioputv( numflo , 'traj_dens' , zrho(jfl), start=istart ) + + ENDDO + + !II-2-b-3 Close netcdf file + !--------------------------- + CALL flioclo( numflo ) + + ENDIF + +#endif + ENDIF ! netcdf writing + + END SUBROUTINE flo_wri + + !!======================================================================= +END MODULE flowri \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icb_oce.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icb_oce.F90 new file mode 100644 index 0000000..39a204e --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icb_oce.F90 @@ -0,0 +1,215 @@ +MODULE icb_oce + !!====================================================================== + !! *** MODULE icb_oce *** + !! Icebergs: declare variables for iceberg tracking + !!====================================================================== + !! History : 3.3 ! 2010-01 (T. Martin & A. Adcroft) Original code + !! - ! 2011-03 (G. Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (S. Alderson) Extensive rewrite ; Split into separate modules + !!---------------------------------------------------------------------- + !! + !! Track Icebergs as Lagrangian objects within the model domain + !! Interaction with the other model variables through 'icebergs_gridded' + !! + !! A single iceberg is held as an instance of type 'iceberg' + !! This type defines a linked list, so each instance contains a pointer + !! to the previous and next icebergs in the list + !! + !! Type 'icebergs' is a convenience container for all relevant arrays + !! It contains one pointer to an 'iceberg' instance representing all icebergs in the processor + !! + !! Each iceberg has a position represented as a real cartesian coordinate which is + !! fractional grid cell, centred on T-points; so an iceberg position of (1.0,1.0) lies + !! exactly on the first T-point and the T-cell spans 0.5 to 1.5 in each direction + !! + !! Each iceberg is assigned a unique id even in MPI + !! This consists of an array of integers: the first element is used to label, the second + !! and subsequent elements are used to count the number of times the first element wraps + !! around all possible values within the valid size for this datatype. + !! Labelling is done by starting the first label in each processor (even when only one) + !! as narea, and then incrementing by jpnij (i.e. the total number of processors. + !! This means that the source processor for each iceberg can be identified by arithmetic + !! modulo jpnij. + !! + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE lib_mpp ! MPP library + + IMPLICIT NONE + PUBLIC + + PUBLIC icb_alloc ! routine called by icb_init in icbini.F90 module + + INTEGER, PUBLIC, PARAMETER :: nclasses = 10 !: Number of icebergs classes + INTEGER, PUBLIC, PARAMETER :: nkounts = 3 !: Number of integers combined for unique naming + + TYPE, PUBLIC :: icebergs_gridded !: various icebergs properties on model grid + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: calving ! Calving mass rate (into stored ice) [kg/s] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: calving_hflx ! Calving heat flux [heat content of calving] [W/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: floating_melt ! Net melting rate to icebergs + bits [kg/s/m^2] + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: maxclass ! maximum class number at calving source point + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: tmp ! Temporary work space + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: stored_ice ! Accumulated ice mass flux at calving locations [kg] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: stored_heat ! Heat content of stored ice [J] + END TYPE icebergs_gridded + + TYPE, PUBLIC :: point !: properties of an individual iceberg (position, mass, size, etc...) + INTEGER :: year + REAL(wp) :: xi , yj , zk ! iceberg coordinates in the (i,j) referential (global) and deepest level affected + REAL(wp) :: e1 , e2 ! horizontal scale factors at the iceberg position + REAL(wp) :: lon, lat, day ! geographic position + REAL(wp) :: mass, thickness, width, length, uvel, vvel ! iceberg physical properties + REAL(wp) :: ssu, ssv, ui, vi, ua, va, ssh_x, ssh_y, sst, sss, cn, hi ! properties of iceberg environment + REAL(wp) :: mass_of_bits, heat_density + INTEGER :: kb ! icb bottom level + END TYPE point + + TYPE, PUBLIC :: iceberg !: linked list defining all the icebergs present in the model domain + TYPE(iceberg), POINTER :: prev=>NULL(), next=>NULL() ! pointers to previous and next unique icebergs in linked list + INTEGER, DIMENSION(nkounts) :: number ! variables which do not change for this iceberg + REAL(wp) :: mass_scaling ! - - - - + TYPE(point), POINTER :: current_point => NULL() ! variables which change with time are held in a separate type + END TYPE iceberg + + + TYPE(icebergs_gridded), POINTER :: berg_grid !: master instance of gridded iceberg type + TYPE(iceberg) , POINTER :: first_berg => NULL() !: master instance of linked list iceberg type + + ! !!! parameters controlling iceberg characteristics and modelling + REAL(wp) :: berg_dt !: Time-step between iceberg CALLs (should make adaptive?) + REAL(wp), DIMENSION(:), ALLOCATABLE :: first_width, first_length !: + LOGICAL :: l_restarted_bergs=.FALSE. ! Indicate whether we read state from a restart or not + ! ! arbitrary numbers for diawri entry + REAL(wp), DIMENSION(nclasses), PUBLIC :: class_num=(/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 /) + + ! Extra arrays with bigger halo, needed when interpolating forcing onto iceberg position + ! particularly for MPP when iceberg can lie inside T grid but outside U, V, or f grid + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ssu_e, ssv_e + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: sst_e, sss_e, fr_e + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ua_e, va_e + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ssh_e + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: tmask_e, umask_e, vmask_e + REAl(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: rlon_e, rlat_e, ff_e + REAl(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: uoce_e, voce_e, toce_e, e3t_e + ! +#if defined key_si3 || defined key_cice + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: hi_e, ui_e, vi_e +#endif + + !!gm almost all those PARAM ARE defined in NEMO + REAL(wp), PUBLIC, PARAMETER :: pp_rho_ice = 916.7_wp !: Density of fresh ice @ 0oC [kg/m^3] + REAL(wp), PUBLIC, PARAMETER :: pp_rho_water = 999.8_wp !: Density of fresh water @ 0oC [kg/m^3] + REAL(wp), PUBLIC, PARAMETER :: pp_rho_air = 1.1_wp !: Density of air @ 0oC [kg/m^3] + REAL(wp), PUBLIC, PARAMETER :: pp_rho_seawater = 1025._wp !: Approx. density of surface sea water @ 0oC [kg/m^3] + !!gm end + REAL(wp), PUBLIC, PARAMETER :: pp_Cd_av = 1.3_wp !: (Vertical) Drag coefficient between bergs and atmos + REAL(wp), PUBLIC, PARAMETER :: pp_Cd_ah = 0.0055_wp !: (lateral ) Drag coefficient between bergs and atmos + REAL(wp), PUBLIC, PARAMETER :: pp_Cd_wv = 0.9_wp !: (Vertical) Drag coefficient between bergs and ocean + REAL(wp), PUBLIC, PARAMETER :: pp_Cd_wh = 0.0012_wp !: (lateral ) Drag coefficient between bergs and ocean + REAL(wp), PUBLIC, PARAMETER :: pp_Cd_iv = 0.9_wp !: (Vertical) Drag coefficient between bergs and sea-ice +!TOM> no horizontal drag for sea ice! real, PARAMETER :: pp_Cd_ih=0.0012 ! (lateral) Drag coeff. between bergs and sea-ice + + ! !!* namberg namelist parameters (and defaults) ** + LOGICAL , PUBLIC :: ln_bergdia !: Calculate budgets + INTEGER , PUBLIC :: nn_verbose_level !: Turn on debugging when level > 0 + INTEGER , PUBLIC :: nn_test_icebergs !: Create icebergs in absence of a restart file from the supplied class nb + REAL(wp), PUBLIC, DIMENSION(4) :: rn_test_box !: lon1,lon2,lat1,lat2 box to create them in + LOGICAL , PUBLIC :: ln_use_calving !: Force use of calving data even with nn_test_icebergs > 0 + ! (default is not to use calving data with test bergs) + INTEGER , PUBLIC :: nn_sample_rate !: Timesteps between sampling of position for trajectory storage + INTEGER , PUBLIC :: nn_verbose_write !: timesteps between verbose messages + REAL(wp), PUBLIC :: rn_rho_bergs !: Density of icebergs + REAL(wp), PUBLIC :: rho_berg_1_oce !: convertion factor (thickness to draft) (rn_rho_bergs/pp_rho_seawater) + REAL(wp), PUBLIC :: rn_LoW_ratio !: Initial ratio L/W for newly calved icebergs + REAL(wp), PUBLIC :: rn_bits_erosion_fraction !: Fraction of erosion melt flux to divert to bergy bits + REAL(wp), PUBLIC :: rn_sicn_shift !: Shift of sea-ice concentration in erosion flux modulation (0 0 ) CALL ctl_warn('icb_alloc: allocation of arrays failed') + ! + END FUNCTION icb_alloc + + !!====================================================================== +END MODULE icb_oce \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbclv.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbclv.F90 new file mode 100644 index 0000000..e73441a --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbclv.F90 @@ -0,0 +1,179 @@ +MODULE icbclv + !!====================================================================== + !! *** MODULE icbclv *** + !! Icebergs: calving routines for iceberg calving + !!====================================================================== + !! History : 3.3.1 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! 2011-05 (Alderson) budgets into separate module + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_clv_flx : transfer input flux of ice into iceberg classes + !! icb_clv : calve icebergs from stored ice + !!---------------------------------------------------------------------- + USE par_oce ! NEMO parameters + USE dom_oce ! NEMO ocean domain + USE phycst ! NEMO physical constants + USE lib_mpp ! NEMO MPI library, lk_mpp in particular + USE lbclnk ! NEMO boundary exchanges for gridded data + + USE icbdia ! iceberg diagnostics + USE icbutl ! iceberg utility routines + USE icb_oce ! iceberg parameters + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_clv_flx ! routine called in icbstp.F90 module + PUBLIC icb_clv ! routine called in icbstp.F90 module + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbclv.F90 15088 2021-07-06 13:03:34Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_clv_flx( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_clv_flx *** + !! + !! ** Purpose : accumulate ice available for calving into class arrays + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + ! + REAL(wp) :: zcalving_used, zdist, zfact + INTEGER :: jn, ji, jj ! loop counters + INTEGER :: imx ! temporary integer for max berg class + LOGICAL, SAVE :: ll_first_call = .TRUE. + !!---------------------------------------------------------------------- + ! + ! Adapt calving flux and calving heat flux from coupler for use here + ! Use interior mask: so no bergs in overlap areas and convert from km^3/year to kg/s + ! this assumes that input is given as equivalent water flux so that pure water density is appropriate + + zfact = ( (1000._wp)**3 / ( NINT(rday) * nyear_len(1) ) ) * rn_rho_bergs + berg_grid%calving(:,:) = src_calving(:,:) * zfact * tmask_i(:,:) * tmask(:,:,1) + + ! Heat in units of W/m2, and mask (just in case) + berg_grid%calving_hflx(:,:) = src_calving_hflx(:,:) * tmask_i(:,:) * tmask(:,:,1) + + IF( ll_first_call .AND. .NOT. l_restarted_bergs ) THEN ! This is a hack to simplify initialization + ll_first_call = .FALSE. + !do jn=1, nclasses + ! where (berg_grid%calving==0.) berg_grid%stored_ice(:,:,jn)=0. + !end do + DO_2D( 0, 0, 0, 0 ) + IF( berg_grid%calving(ji,jj) /= 0._wp ) & ! Need units of J + berg_grid%stored_heat(ji,jj) = SUM( berg_grid%stored_ice(ji,jj,:) ) * & ! initial stored ice in kg + & berg_grid%calving_hflx(ji,jj) * e1e2t(ji,jj) / berg_grid%calving(ji,jj) ! J/s/m2 x m^2 + ! ! = J/s/calving in kg/s + END_2D + ENDIF + + ! assume that all calving flux must be distributed even if distribution array does not sum + ! to one - this may not be what is intended, but it's what you've got + DO_2D( 1, 1, 1, 1 ) + imx = berg_grid%maxclass(ji,jj) + zdist = SUM( rn_distribution(1:nclasses) ) / SUM( rn_distribution(1:imx) ) + DO jn = 1, imx + berg_grid%stored_ice(ji,jj,jn) = berg_grid%stored_ice(ji,jj,jn) & + & + berg_dt * berg_grid%calving(ji,jj) * rn_distribution(jn) * zdist + END DO + END_2D + + ! before changing the calving, save the amount we're about to use and do budget + zcalving_used = SUM( berg_grid%calving(:,:) ) + berg_grid%tmp(:,:) = berg_dt * berg_grid%calving_hflx(:,:) * e1e2t(:,:) * tmask_i(:,:) + berg_grid%stored_heat (:,:) = berg_grid%stored_heat (:,:) + berg_grid%tmp(:,:) + CALL icb_dia_income( kt, zcalving_used, berg_grid%tmp ) + ! + END SUBROUTINE icb_clv_flx + + + SUBROUTINE icb_clv( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_clv *** + !! + !! ** Purpose : This routine takes a stored ice field and calves to the ocean, + !! so the gridded array stored_ice has only non-zero entries at selected + !! wet points adjacent to known land based calving points + !! + !! ** method : - Look at each grid point and see if there's enough for each size class to calve + !! If there is, a new iceberg is calved. This happens in the order determined by + !! the class definition arrays (which in the default case is smallest first) + !! Note that only the non-overlapping part of the processor where icebergs are allowed + !! is considered + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + INTEGER :: ji, jj, jn ! dummy loop indices + INTEGER :: icnt, icntmax + TYPE(iceberg) :: newberg + TYPE(point) :: newpt + REAL(wp) :: zday, zcalved_to_berg, zheat_to_berg + !!---------------------------------------------------------------------- + ! + icntmax = 0 + zday = REAL(nday_year,wp) + REAL(nsec_day,wp)/86400.0_wp + ! + DO jn = 1, nclasses + DO jj = nicbdj, nicbej + DO ji = nicbdi, nicbei + ! + icnt = 0 + ! + DO WHILE (berg_grid%stored_ice(ji,jj,jn) >= rn_initial_mass(jn) * rn_mass_scaling(jn) ) + ! + newpt%lon = glamt(ji,jj) ! at t-point (centre of the cell) + newpt%lat = gphit(ji,jj) + newpt%xi = REAL( mig(ji), wp ) - ( nn_hls - 1 ) + newpt%yj = REAL( mjg(jj), wp ) - ( nn_hls - 1 ) + ! + newpt%uvel = 0._wp ! initially at rest + newpt%vvel = 0._wp + ! ! set berg characteristics + newpt%mass = rn_initial_mass (jn) + newpt%thickness = rn_initial_thickness(jn) + newpt%kb = 1 ! compute correctly in icbthm if needed + newpt%width = first_width (jn) + newpt%length = first_length (jn) + newberg%mass_scaling = rn_mass_scaling (jn) + newpt%mass_of_bits = 0._wp ! no bergy + ! + newpt%year = nyear + newpt%day = zday + newpt%heat_density = berg_grid%stored_heat(ji,jj) / berg_grid%stored_ice(ji,jj,jn) ! This is in J/kg + ! + CALL icb_utl_incr() + newberg%number(:) = num_bergs(:) + ! + CALL icb_utl_add( newberg, newpt ) + ! + zcalved_to_berg = rn_initial_mass(jn) * rn_mass_scaling(jn) ! Units of kg + ! ! Heat content + zheat_to_berg = zcalved_to_berg * newpt%heat_density ! Units of J + berg_grid%stored_heat(ji,jj) = berg_grid%stored_heat(ji,jj) - zheat_to_berg + ! ! Stored mass + berg_grid%stored_ice(ji,jj,jn) = berg_grid%stored_ice(ji,jj,jn) - zcalved_to_berg + ! + icnt = icnt + 1 + ! + CALL icb_dia_calve(ji, jj, jn, zcalved_to_berg, zheat_to_berg ) + END DO + icntmax = MAX( icntmax, icnt ) + END DO + END DO + END DO + ! + IF( nn_verbose_level > 0 .AND. icntmax > 1 ) WRITE(numicb,*) 'icb_clv: icnt=', icnt,' on', narea + ! + END SUBROUTINE icb_clv + + !!====================================================================== +END MODULE icbclv \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbdia.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbdia.F90 new file mode 100644 index 0000000..34840b0 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbdia.F90 @@ -0,0 +1,621 @@ +MODULE icbdia + !!====================================================================== + !! *** MODULE icbdia *** + !! Icebergs: initialise variables for iceberg budgets and diagnostics + !!====================================================================== + !! History : 3.3 ! 2010-01 (Martin, Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! 2011-05 (Alderson) Budgets are now all here with lots + !! - ! of silly routines to call to get values in + !! - ! from the right points in the code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_dia_init : initialise iceberg budgeting + !! icb_dia : global iceberg diagnostics + !! icb_dia_step : reset at the beginning of each timestep + !! icb_dia_put : output (via iom_put) iceberg fields + !! icb_dia_calve : + !! icb_dia_income: + !! icb_dia_size : + !! icb_dia_speed : + !! icb_dia_melt : + !! report_state : + !! report_consistant : + !! report_budget : + !! report_istate : + !! report_ibudget: + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE dom_oce ! ocean domain + USE in_out_manager ! nemo IO + USE lib_mpp ! MPP library + USE iom ! I/O library + USE icb_oce ! iceberg variables + USE icbutl ! iceberg utility routines + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_dia_init ! routine called in icbini.F90 module + PUBLIC icb_dia ! routine called in icbstp.F90 module + PUBLIC icb_dia_step ! routine called in icbstp.F90 module + PUBLIC icb_dia_put ! routine called in icbstp.F90 module + PUBLIC icb_dia_melt ! routine called in icbthm.F90 module + PUBLIC icb_dia_size ! routine called in icbthm.F90 module + PUBLIC icb_dia_speed ! routine called in icbdyn.F90 module + PUBLIC icb_dia_calve ! routine called in icbclv.F90 module + PUBLIC icb_dia_income ! routine called in icbclv.F90 module + + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: berg_melt ! Melting+erosion rate of icebergs [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: berg_melt_hcflx ! Heat flux to ocean due to heat content of melting icebergs [J/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: berg_melt_qlat ! Heat flux to ocean due to latent heat of melting icebergs [J/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: buoy_melt ! Buoyancy component of melting rate [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: eros_melt ! Erosion component of melting rate [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: conv_melt ! Convective component of melting rate [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: bits_src ! Mass flux from berg erosion into bergy bits [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: bits_melt ! Melting rate of bergy bits [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: bits_mass ! Mass distribution of bergy bits [kg/s/m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: virtual_area ! Virtual surface coverage by icebergs [m2] + REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PUBLIC :: berg_mass ! Mass distribution [kg/m2] + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, PUBLIC :: real_calving ! Calving rate into iceberg class at + ! ! calving locations [kg/s] + + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: tmpc ! Temporary work space + REAL(wp), DIMENSION(:) , ALLOCATABLE :: rsumbuf ! Temporary work space to reduce mpp exchanges + INTEGER , DIMENSION(:) , ALLOCATABLE :: nsumbuf ! Temporary work space to reduce mpp exchanges + + REAL(wp) :: berg_melt_net + REAL(wp) :: bits_src_net + REAL(wp) :: bits_melt_net + REAL(wp) :: bits_mass_start , bits_mass_end + REAL(wp) :: floating_heat_start , floating_heat_end + REAL(wp) :: floating_mass_start , floating_mass_end + REAL(wp) :: bergs_mass_start , bergs_mass_end + REAL(wp) :: stored_start , stored_heat_start + REAL(wp) :: stored_end , stored_heat_end + REAL(wp) :: calving_src_net , calving_out_net + REAL(wp) :: calving_src_heat_net, calving_out_heat_net + REAL(wp) :: calving_src_heat_used_net + REAL(wp) :: calving_rcv_net , calving_ret_net , calving_used_net + REAL(wp) :: heat_to_bergs_net, heat_to_ocean_net, melt_net + REAL(wp) :: calving_to_bergs_net + + INTEGER :: nbergs_start, nbergs_end, nbergs_calved + INTEGER :: nbergs_melted + INTEGER :: nspeeding_tickets, nspeeding_tickets_all + INTEGER , DIMENSION(nclasses) :: nbergs_calved_by_class + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbdia.F90 14773 2021-04-30 10:23:51Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_dia_init( ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + + ALLOCATE( berg_melt (jpi,jpj) ) ; berg_melt (:,:) = 0._wp + ALLOCATE( berg_melt_hcflx(jpi,jpj) ) ; berg_melt_hcflx(:,:) = 0._wp + ALLOCATE( berg_melt_qlat(jpi,jpj) ) ; berg_melt_qlat(:,:) = 0._wp + ALLOCATE( buoy_melt (jpi,jpj) ) ; buoy_melt (:,:) = 0._wp + ALLOCATE( eros_melt (jpi,jpj) ) ; eros_melt (:,:) = 0._wp + ALLOCATE( conv_melt (jpi,jpj) ) ; conv_melt (:,:) = 0._wp + ALLOCATE( bits_src (jpi,jpj) ) ; bits_src (:,:) = 0._wp + ALLOCATE( bits_melt (jpi,jpj) ) ; bits_melt (:,:) = 0._wp + ALLOCATE( bits_mass (jpi,jpj) ) ; bits_mass (:,:) = 0._wp + ALLOCATE( virtual_area (jpi,jpj) ) ; virtual_area(:,:) = 0._wp + ALLOCATE( berg_mass (jpi,jpj) ) ; berg_mass (:,:) = 0._wp + ALLOCATE( real_calving (jpi,jpj,nclasses) ) ; real_calving(:,:,:) = 0._wp + ALLOCATE( tmpc(jpi,jpj) ) ; tmpc (:,:) = 0._wp + + nbergs_start = 0 + nbergs_end = 0 + stored_end = 0._wp + nbergs_start = 0._wp + stored_start = 0._wp + nbergs_melted = 0 + nbergs_calved = 0 + nbergs_calved_by_class(:) = 0 + nspeeding_tickets = 0 + nspeeding_tickets_all = 0 + stored_heat_end = 0._wp + floating_heat_end = 0._wp + floating_mass_end = 0._wp + bergs_mass_end = 0._wp + bits_mass_end = 0._wp + stored_heat_start = 0._wp + floating_heat_start = 0._wp + floating_mass_start = 0._wp + bergs_mass_start = 0._wp + bits_mass_start = 0._wp + bits_mass_end = 0._wp + calving_used_net = 0._wp + calving_to_bergs_net = 0._wp + heat_to_bergs_net = 0._wp + heat_to_ocean_net = 0._wp + calving_rcv_net = 0._wp + calving_ret_net = 0._wp + calving_src_net = 0._wp + calving_out_net = 0._wp + calving_src_heat_net = 0._wp + calving_src_heat_used_net = 0._wp + calving_out_heat_net = 0._wp + melt_net = 0._wp + berg_melt_net = 0._wp + bits_melt_net = 0._wp + bits_src_net = 0._wp + + floating_mass_start = icb_utl_mass( first_berg ) + bergs_mass_start = icb_utl_mass( first_berg, justbergs=.TRUE. ) + bits_mass_start = icb_utl_mass( first_berg, justbits =.TRUE. ) + IF( lk_mpp ) THEN + ALLOCATE( rsumbuf(23) ) ; rsumbuf(:) = 0._wp + ALLOCATE( nsumbuf(4+nclasses) ) ; nsumbuf(:) = 0 + rsumbuf(1) = floating_mass_start + rsumbuf(2) = bergs_mass_start + rsumbuf(3) = bits_mass_start + CALL mpp_sum( 'icbdia', rsumbuf(1:3), 3 ) + floating_mass_start = rsumbuf(1) + bergs_mass_start = rsumbuf(2) + bits_mass_start = rsumbuf(3) + ENDIF + ! + END SUBROUTINE icb_dia_init + + + SUBROUTINE icb_dia( ld_budge ) + !!---------------------------------------------------------------------- + !! sum all the things we've accumulated so far in the current processor + !! in MPP case then add these sums across all processors + !! for this we pack variables into buffer so we only need one mpp_sum + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in) :: ld_budge ! + ! + INTEGER :: ik + REAL(wp):: zunused_calving, ztmpsum, zgrdd_berg_mass, zgrdd_bits_mass + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + + zunused_calving = SUM( berg_grid%calving(:,:) ) + ztmpsum = SUM( berg_grid%floating_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + melt_net = melt_net + ztmpsum * berg_dt + calving_out_net = calving_out_net + ( zunused_calving + ztmpsum ) * berg_dt + ztmpsum = SUM( berg_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + berg_melt_net = berg_melt_net + ztmpsum * berg_dt + ztmpsum = SUM( bits_src(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + bits_src_net = bits_src_net + ztmpsum * berg_dt + ztmpsum = SUM( bits_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + bits_melt_net = bits_melt_net + ztmpsum * berg_dt + ztmpsum = SUM( src_calving(:,:) * tmask_i(:,:) ) + calving_ret_net = calving_ret_net + ztmpsum * berg_dt + ztmpsum = SUM( berg_grid%calving_hflx(:,:) * e1e2t(:,:) * tmask_i(:,:) ) + calving_out_heat_net = calving_out_heat_net + ztmpsum * berg_dt ! Units of J + ! + IF( ld_budge ) THEN + stored_end = SUM( berg_grid%stored_ice(:,:,:) ) + stored_heat_end = SUM( berg_grid%stored_heat(:,:) ) + floating_mass_end = icb_utl_mass( first_berg ) + bergs_mass_end = icb_utl_mass( first_berg,justbergs=.TRUE. ) + bits_mass_end = icb_utl_mass( first_berg,justbits =.TRUE. ) + floating_heat_end = icb_utl_heat( first_berg ) + ! + nbergs_end = icb_utl_count() + zgrdd_berg_mass = SUM( berg_mass(:,:)*e1e2t(:,:)*tmask_i(:,:) ) + zgrdd_bits_mass = SUM( bits_mass(:,:)*e1e2t(:,:)*tmask_i(:,:) ) + ! + IF( lk_mpp ) THEN + rsumbuf( 1) = stored_end + rsumbuf( 2) = stored_heat_end + rsumbuf( 3) = floating_mass_end + rsumbuf( 4) = bergs_mass_end + rsumbuf( 5) = bits_mass_end + rsumbuf( 6) = floating_heat_end + rsumbuf( 7) = calving_ret_net + rsumbuf( 8) = calving_out_net + rsumbuf( 9) = calving_rcv_net + rsumbuf(10) = calving_src_net + rsumbuf(11) = calving_src_heat_net + rsumbuf(12) = calving_src_heat_used_net + rsumbuf(13) = calving_out_heat_net + rsumbuf(14) = calving_used_net + rsumbuf(15) = calving_to_bergs_net + rsumbuf(16) = heat_to_bergs_net + rsumbuf(17) = heat_to_ocean_net + rsumbuf(18) = melt_net + rsumbuf(19) = berg_melt_net + rsumbuf(20) = bits_src_net + rsumbuf(21) = bits_melt_net + rsumbuf(22) = zgrdd_berg_mass + rsumbuf(23) = zgrdd_bits_mass + ! + CALL mpp_sum( 'icbdia', rsumbuf(1:23), 23) + ! + stored_end = rsumbuf( 1) + stored_heat_end = rsumbuf( 2) + floating_mass_end = rsumbuf( 3) + bergs_mass_end = rsumbuf( 4) + bits_mass_end = rsumbuf( 5) + floating_heat_end = rsumbuf( 6) + calving_ret_net = rsumbuf( 7) + calving_out_net = rsumbuf( 8) + calving_rcv_net = rsumbuf( 9) + calving_src_net = rsumbuf(10) + calving_src_heat_net = rsumbuf(11) + calving_src_heat_used_net = rsumbuf(12) + calving_out_heat_net = rsumbuf(13) + calving_used_net = rsumbuf(14) + calving_to_bergs_net = rsumbuf(15) + heat_to_bergs_net = rsumbuf(16) + heat_to_ocean_net = rsumbuf(17) + melt_net = rsumbuf(18) + berg_melt_net = rsumbuf(19) + bits_src_net = rsumbuf(20) + bits_melt_net = rsumbuf(21) + zgrdd_berg_mass = rsumbuf(22) + zgrdd_bits_mass = rsumbuf(23) + ! + nsumbuf(1) = nbergs_end + nsumbuf(2) = nbergs_calved + nsumbuf(3) = nbergs_melted + nsumbuf(4) = nspeeding_tickets + DO ik = 1, nclasses + nsumbuf(4+ik) = nbergs_calved_by_class(ik) + END DO + CALL mpp_sum( 'icbdia', nsumbuf(1:nclasses+4), nclasses+4 ) + ! + nbergs_end = nsumbuf(1) + nbergs_calved = nsumbuf(2) + nbergs_melted = nsumbuf(3) + nspeeding_tickets_all = nsumbuf(4) + DO ik = 1,nclasses + nbergs_calved_by_class(ik)= nsumbuf(4+ik) + END DO + ! + ENDIF + ! + CALL report_state ( 'stored ice','kg','',stored_start,'',stored_end,'') + CALL report_state ( 'floating','kg','',floating_mass_start,'',floating_mass_end,'',nbergs_end ) + CALL report_state ( 'icebergs','kg','',bergs_mass_start,'',bergs_mass_end,'') + CALL report_state ( 'bits','kg','',bits_mass_start,'',bits_mass_end,'') + CALL report_istate ( 'berg #','',nbergs_start,'',nbergs_end,'') + CALL report_ibudget( 'berg #','calved',nbergs_calved, & + & 'melted',nbergs_melted, & + & '#',nbergs_start,nbergs_end) + CALL report_budget( 'stored mass','kg','calving used',calving_used_net, & + & 'bergs',calving_to_bergs_net, & + & 'stored mass',stored_start,stored_end) + CALL report_budget( 'floating mass','kg','calving used',calving_to_bergs_net, & + & 'bergs',melt_net, & + & 'stored mass',floating_mass_start,floating_mass_end) + CALL report_budget( 'berg mass','kg','calving',calving_to_bergs_net, & + & 'melt+eros',berg_melt_net, & + & 'berg mass',bergs_mass_start,bergs_mass_end) + CALL report_budget( 'bits mass','kg','eros used',bits_src_net, & + & 'bergs',bits_melt_net, & + & 'stored mass',bits_mass_start,bits_mass_end) + CALL report_budget( 'net mass','kg','recvd',calving_rcv_net, & + & 'rtrnd',calving_ret_net, & + & 'net mass',stored_start+floating_mass_start, & + & stored_end+floating_mass_end) + CALL report_consistant( 'iceberg mass','kg','gridded',zgrdd_berg_mass,'bergs',bergs_mass_end) + CALL report_consistant( 'bits mass','kg','gridded',zgrdd_bits_mass,'bits',bits_mass_end) + CALL report_state( 'net heat','J','',stored_heat_start+floating_heat_start,'', & + & stored_heat_end+floating_heat_end,'') + CALL report_state( 'stored heat','J','',stored_heat_start,'',stored_heat_end,'') + CALL report_state( 'floating heat','J','',floating_heat_start,'',floating_heat_end,'') + CALL report_budget( 'net heat','J','net heat',calving_src_heat_net, & + & 'net heat',calving_out_heat_net, & + & 'net heat',stored_heat_start+floating_heat_start, & + & stored_heat_end+floating_heat_end) + CALL report_budget( 'stored heat','J','calving used',calving_src_heat_used_net, & + & 'bergs',heat_to_bergs_net, & + & 'net heat',stored_heat_start,stored_heat_end) + CALL report_budget( 'flting heat','J','calved',heat_to_bergs_net, & + & 'melt',heat_to_ocean_net, & + & 'net heat',floating_heat_start,floating_heat_end) + IF (nn_verbose_level >= 1) THEN + CALL report_consistant( 'top interface','kg','from SIS',calving_src_net, & + & 'received',calving_rcv_net) + CALL report_consistant( 'bot interface','kg','sent',calving_out_net, & + & 'returned',calving_ret_net) + ENDIF + IF (nn_verbose_level > 0) THEN + WRITE( numicb, '("calved by class = ",i6,20(",",i6))') (nbergs_calved_by_class(ik),ik=1,nclasses) + IF( nspeeding_tickets_all > 0 ) THEN + WRITE( numicb, '("speeding tickets issued (this domain) = ",i6)') nspeeding_tickets + WRITE( numicb, '("speeding tickets issued (all domains) = ",i6)') nspeeding_tickets_all + END IF + ENDIF + ! + nbergs_start = nbergs_end + stored_start = stored_end + nbergs_melted = 0 + nbergs_calved = 0 + nbergs_calved_by_class(:) = 0 + nspeeding_tickets = 0 + nspeeding_tickets_all = 0 + stored_heat_start = stored_heat_end + floating_heat_start = floating_heat_end + floating_mass_start = floating_mass_end + bergs_mass_start = bergs_mass_end + bits_mass_start = bits_mass_end + calving_used_net = 0._wp + calving_to_bergs_net = 0._wp + heat_to_bergs_net = 0._wp + heat_to_ocean_net = 0._wp + calving_rcv_net = 0._wp + calving_ret_net = 0._wp + calving_src_net = 0._wp + calving_out_net = 0._wp + calving_src_heat_net = 0._wp + calving_src_heat_used_net = 0._wp + calving_out_heat_net = 0._wp + melt_net = 0._wp + berg_melt_net = 0._wp + bits_melt_net = 0._wp + bits_src_net = 0._wp + ENDIF + ! + END SUBROUTINE icb_dia + + + SUBROUTINE icb_dia_step + !!---------------------------------------------------------------------- + !! things to reset at the beginning of each timestep + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + berg_melt (:,:) = 0._wp + berg_melt_hcflx(:,:) = 0._wp + berg_melt_qlat(:,:) = 0._wp + buoy_melt (:,:) = 0._wp + eros_melt (:,:) = 0._wp + conv_melt (:,:) = 0._wp + bits_src (:,:) = 0._wp + bits_melt (:,:) = 0._wp + bits_mass (:,:) = 0._wp + berg_mass (:,:) = 0._wp + virtual_area(:,:) = 0._wp + real_calving(:,:,:) = 0._wp + ! + END SUBROUTINE icb_dia_step + + + SUBROUTINE icb_dia_put + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN !!gm useless iom will control whether it is output or not + ! + CALL iom_put( "berg_melt" , berg_melt (:,:) ) ! Melt rate of icebergs [kg/m2/s] + !! NB. The berg_melt_hcflx field is currently always zero - see comment in icbthm.F90 + CALL iom_put( "berg_melt_hcflx" , berg_melt_hcflx(:,:)) ! Heat flux to ocean due to heat content of melting icebergs [J/m2/s] + CALL iom_put( "berg_melt_qlat" , berg_melt_qlat(:,:) ) ! Heat flux to ocean due to latent heat of melting icebergs [J/m2/s] + CALL iom_put( "berg_buoy_melt" , buoy_melt (:,:) ) ! Buoyancy component of iceberg melt rate [kg/m2/s] + CALL iom_put( "berg_eros_melt" , eros_melt (:,:) ) ! Erosion component of iceberg melt rate [kg/m2/s] + CALL iom_put( "berg_conv_melt" , conv_melt (:,:) ) ! Convective component of iceberg melt rate [kg/m2/s] + CALL iom_put( "berg_virtual_area", virtual_area(:,:) ) ! Virtual coverage by icebergs [m2] + CALL iom_put( "bits_src" , bits_src (:,:) ) ! Mass source of bergy bits [kg/m2/s] + CALL iom_put( "bits_melt" , bits_melt (:,:) ) ! Melt rate of bergy bits [kg/m2/s] + CALL iom_put( "bits_mass" , bits_mass (:,:) ) ! Bergy bit density field [kg/m2] + CALL iom_put( "berg_mass" , berg_mass (:,:) ) ! Iceberg density field [kg/m2] + CALL iom_put( "berg_real_calving", real_calving(:,:,:) ) ! Calving into iceberg class [kg/s] + ! + END SUBROUTINE icb_dia_put + + + SUBROUTINE icb_dia_calve( ki, kj, kn, pcalved, pheated ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: ki, kj, kn + REAL(wp), INTENT(in) :: pcalved + REAL(wp), INTENT(in) :: pheated + !!---------------------------------------------------------------------- + ! + IF( .NOT. ln_bergdia ) RETURN + real_calving(ki,kj,kn) = real_calving(ki,kj,kn) + pcalved / berg_dt + nbergs_calved = nbergs_calved + 1 + nbergs_calved_by_class(kn) = nbergs_calved_by_class(kn) + 1 + calving_to_bergs_net = calving_to_bergs_net + pcalved + heat_to_bergs_net = heat_to_bergs_net + pheated + ! + END SUBROUTINE icb_dia_calve + + + SUBROUTINE icb_dia_income( kt, pcalving_used, pheat_used ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt + REAL(wp), INTENT(in) :: pcalving_used + REAL(wp), DIMENSION(:,:), INTENT(in) :: pheat_used + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + ! + IF( kt == nit000 ) THEN + stored_start = SUM( berg_grid%stored_ice(:,:,:) ) + CALL mpp_sum( 'icbdia', stored_start ) + ! + stored_heat_start = SUM( berg_grid%stored_heat(:,:) ) + CALL mpp_sum( 'icbdia', stored_heat_start ) + IF (nn_verbose_level > 0) THEN + WRITE(numicb,'(a,es13.6,a)') 'icb_dia_income: initial stored mass=',stored_start,' kg' + WRITE(numicb,'(a,es13.6,a)') 'icb_dia_income: initial stored heat=',stored_heat_start,' J' + ENDIF + ENDIF + ! + calving_rcv_net = calving_rcv_net + SUM( berg_grid%calving(:,:) ) * berg_dt + calving_src_net = calving_rcv_net + calving_src_heat_net = calving_src_heat_net + & + & SUM( berg_grid%calving_hflx(:,:) * e1e2t(:,:) ) * berg_dt ! Units of J + calving_used_net = calving_used_net + pcalving_used * berg_dt + calving_src_heat_used_net = calving_src_heat_used_net + SUM( pheat_used(:,:) ) + ! + END SUBROUTINE icb_dia_income + + + SUBROUTINE icb_dia_size(ki, kj, pWn, pLn, pAbits, & + & pmass_scale, pMnew, pnMbits, pz1_e1e2) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: ki, kj + REAL(wp), INTENT(in) :: pWn, pLn, pAbits, pmass_scale, pMnew, pnMbits, pz1_e1e2 + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + virtual_area(ki,kj) = virtual_area(ki,kj) + ( pWn * pLn + pAbits ) * pmass_scale ! m^2 + berg_mass(ki,kj) = berg_mass(ki,kj) + pMnew * pz1_e1e2 ! kg/m2 + bits_mass(ki,kj) = bits_mass(ki,kj) + pnMbits * pz1_e1e2 ! kg/m2 + ! + END SUBROUTINE icb_dia_size + + + SUBROUTINE icb_dia_speed() + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + nspeeding_tickets = nspeeding_tickets + 1 + ! + END SUBROUTINE icb_dia_speed + + + SUBROUTINE icb_dia_melt(ki, kj, pmnew, pheat_hcflux, pheat_latent, pmass_scale, & + & pdM, pdMbitsE, pdMbitsM, pdMb, pdMe, & + & pdMv, pz1_dt_e1e2, pz1_e1e2 ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: ki, kj + REAL(wp), INTENT(in) :: pmnew, pheat_hcflux, pheat_latent, pmass_scale + REAL(wp), INTENT(in) :: pdM, pdMbitsE, pdMbitsM, pdMb, pdMe, pdMv, pz1_dt_e1e2, pz1_e1e2 + !!---------------------------------------------------------------------- + ! + IF( .NOT.ln_bergdia ) RETURN + ! + berg_melt (ki,kj) = berg_melt (ki,kj) + pdM * pz1_dt_e1e2 ! kg/m2/s + berg_melt_hcflx (ki,kj) = berg_melt_hcflx (ki,kj) + pheat_hcflux * pz1_e1e2 ! W/m2 + berg_melt_qlat (ki,kj) = berg_melt_qlat (ki,kj) + pheat_latent * pz1_e1e2 ! W/m2 + bits_src (ki,kj) = bits_src (ki,kj) + pdMbitsE * pz1_dt_e1e2 ! mass flux into bergy bitskg/m2/s + bits_melt (ki,kj) = bits_melt (ki,kj) + pdMbitsM * pz1_dt_e1e2 ! melt rate of bergy bits kg/m2/s + buoy_melt (ki,kj) = buoy_melt (ki,kj) + pdMb * pz1_dt_e1e2 ! kg/m2/s + eros_melt (ki,kj) = eros_melt (ki,kj) + pdMe * pz1_dt_e1e2 ! erosion rate kg/m2/s + conv_melt (ki,kj) = conv_melt (ki,kj) + pdMv * pz1_dt_e1e2 ! kg/m2/s + heat_to_ocean_net = heat_to_ocean_net + (pheat_hcflux + pheat_latent) * pmass_scale * berg_dt ! J + IF( pmnew <= 0._wp ) nbergs_melted = nbergs_melted + 1 ! Delete the berg if completely melted + ! + END SUBROUTINE icb_dia_melt + + + SUBROUTINE report_state( cd_budgetstr, cd_budgetunits, cd_startstr, pstartval, cd_endstr, & + & pendval, cd_delstr, kbergs ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_budgetunits, cd_startstr, cd_endstr, cd_delstr + REAL(wp), INTENT(in) :: pstartval, pendval + INTEGER, INTENT(in), OPTIONAL :: kbergs + !!---------------------------------------------------------------------- + ! + IF (nn_verbose_level == 0) RETURN + IF( PRESENT(kbergs) ) THEN + WRITE(numicb,100) cd_budgetstr // ' state:', & + & cd_startstr // ' start', pstartval, cd_budgetunits, & + & cd_endstr // ' end', pendval, cd_budgetunits, & + & 'Delta ' // cd_delstr, pendval-pstartval, cd_budgetunits, & + & '# of bergs', kbergs + ELSE + WRITE(numicb,100) cd_budgetstr // ' state:', & + & cd_startstr // ' start', pstartval, cd_budgetunits, & + & cd_endstr // ' end', pendval, cd_budgetunits, & + & cd_delstr // 'Delta', pendval-pstartval, cd_budgetunits + ENDIF +100 FORMAT(a19,3(a18,"=",es14.7,x,a2,:,","),a12,i8) + ! + END SUBROUTINE report_state + + + SUBROUTINE report_consistant( cd_budgetstr, cd_budgetunits, cd_startstr, pstartval, cd_endstr, pendval) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_budgetunits, cd_startstr, cd_endstr + REAL(wp), INTENT(in) :: pstartval, pendval + !!---------------------------------------------------------------------- + ! + IF (nn_verbose_level == 0) RETURN + WRITE(numicb,200) cd_budgetstr // ' check:', & + & cd_startstr, pstartval, cd_budgetunits, & + & cd_endstr, pendval, cd_budgetunits, & + & 'error', (pendval-pstartval)/((pendval+pstartval)+1e-30), 'nd' +200 FORMAT(a19,10(a18,"=",es14.7,x,a2,:,",")) + ! + END SUBROUTINE report_consistant + + + SUBROUTINE report_budget( cd_budgetstr, cd_budgetunits, cd_instr, pinval, cd_outstr, & + & poutval, cd_delstr, pstartval, pendval) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_budgetunits, cd_instr, cd_outstr, cd_delstr + REAL(wp), INTENT(in) :: pinval, poutval, pstartval, pendval + ! + REAL(wp) :: zval + !!---------------------------------------------------------------------- + ! + IF (nn_verbose_level == 0) RETURN + zval = ( ( pendval - pstartval ) - ( pinval - poutval ) ) / & + & MAX( 1.e-30, MAX( ABS( pendval - pstartval ) , ABS( pinval - poutval ) ) ) + ! + WRITE(numicb,200) cd_budgetstr // ' budget:', & + & cd_instr // ' in', pinval, cd_budgetunits, & + & cd_outstr // ' out', poutval, cd_budgetunits, & + & 'Delta ' // cd_delstr, pinval-poutval, cd_budgetunits, & + & 'error', zval, 'nd' + 200 FORMAT(a19,3(a18,"=",es14.7,x,a2,:,","),a8,"=",es10.3,x,a2) + ! + END SUBROUTINE report_budget + + + SUBROUTINE report_istate( cd_budgetstr, cd_startstr, pstartval, cd_endstr, pendval, cd_delstr) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_startstr, cd_endstr, cd_delstr + INTEGER , INTENT(in) :: pstartval, pendval + !!---------------------------------------------------------------------- + ! + IF (nn_verbose_level == 0) RETURN + WRITE(numicb,100) cd_budgetstr // ' state:', & + & cd_startstr // ' start', pstartval, & + & cd_endstr // ' end', pendval, & + & cd_delstr // 'Delta', pendval-pstartval + 100 FORMAT(a19,3(a18,"=",i14,x,:,",")) + ! + END SUBROUTINE report_istate + + + SUBROUTINE report_ibudget( cd_budgetstr, cd_instr, pinval, cd_outstr, poutval, & + & cd_delstr, pstartval, pendval) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_instr, cd_outstr, cd_delstr + INTEGER, INTENT(in) :: pinval, poutval, pstartval, pendval + !!---------------------------------------------------------------------- + ! + IF (nn_verbose_level == 0) RETURN + WRITE(numicb,200) cd_budgetstr // ' budget:', & + & cd_instr // ' in', pinval, & + & cd_outstr // ' out', poutval, & + & 'Delta ' // cd_delstr, pinval-poutval, & + & 'error', ( ( pendval - pstartval ) - ( pinval - poutval ) ) +200 FORMAT(a19,10(a18,"=",i14,x,:,",")) + ! + END SUBROUTINE report_ibudget + + !!====================================================================== +END MODULE icbdia \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbdyn.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbdyn.F90 new file mode 100644 index 0000000..e146e5b --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbdyn.F90 @@ -0,0 +1,439 @@ +MODULE icbdyn + !!====================================================================== + !! *** MODULE icbdyn *** + !! Iceberg: time stepping routine for iceberg tracking + !!====================================================================== + !! History : 3.3 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! 2011-05 (Alderson) Replace broken grounding routine with one of + !! - ! Gurvan's suggestions (just like the broken one) + !!---------------------------------------------------------------------- + USE par_oce ! NEMO parameters + USE dom_oce ! NEMO ocean domain + USE phycst ! NEMO physical constants + USE in_out_manager ! IO parameters + ! + USE icb_oce ! define iceberg arrays + USE icbutl ! iceberg utility routines + USE icbdia ! iceberg budget routines + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_dyn ! routine called in icbstp.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbdyn.F90 15088 2021-07-06 13:03:34Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_dyn( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_dyn *** + !! + !! ** Purpose : iceberg evolution. + !! + !! ** Method : - See Martin & Adcroft, Ocean Modelling 34, 2010 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! + ! + LOGICAL :: ll_bounced + REAL(wp) :: zuvel1 , zvvel1 , zu1, zv1, zax1, zay1, zxi1 , zyj1 + REAL(wp) :: zuvel2 , zvvel2 , zu2, zv2, zax2, zay2, zxi2 , zyj2 + REAL(wp) :: zuvel3 , zvvel3 , zu3, zv3, zax3, zay3, zxi3 , zyj3 + REAL(wp) :: zuvel4 , zvvel4 , zu4, zv4, zax4, zay4, zxi4 , zyj4 + REAL(wp) :: zuvel_n, zvvel_n, zxi_n , zyj_n + REAL(wp) :: zdt, zdt_2, zdt_6, ze1, ze2 + TYPE(iceberg), POINTER :: berg + TYPE(point) , POINTER :: pt + !!---------------------------------------------------------------------- + ! + ! 4th order Runge-Kutta to solve: d/dt X = V, d/dt V = A + ! with I.C.'s: X=X1 and V=V1 + ! + ! ; A1=A(X1,V1) + ! X2 = X1+dt/2*V1 ; V2 = V1+dt/2*A1 ; A2=A(X2,V2) + ! X3 = X1+dt/2*V2 ; V3 = V1+dt/2*A2 ; A3=A(X3,V3) + ! X4 = X1+ dt*V3 ; V4 = V1+ dt*A3 ; A4=A(X4,V4) + ! + ! Xn = X1+dt*(V1+2*V2+2*V3+V4)/6 + ! Vn = V1+dt*(A1+2*A2+2*A3+A4)/6 + + ! time steps + zdt = berg_dt + zdt_2 = zdt * 0.5_wp + zdt_6 = zdt / 6._wp + + berg => first_berg ! start from the first berg + ! + DO WHILE ( ASSOCIATED(berg) ) !== loop over all bergs ==! + ! + pt => berg%current_point + + ll_bounced = .FALSE. + + + ! STEP 1 ! + ! ====== ! + zxi1 = pt%xi ; zuvel1 = pt%uvel !** X1 in (i,j) ; V1 in m/s + zyj1 = pt%yj ; zvvel1 = pt%vvel + + + ! !** A1 = A(X1,V1) + CALL icb_accel( kt, berg , zxi1, ze1, zuvel1, zuvel1, zax1, & + & zyj1, ze2, zvvel1, zvvel1, zay1, zdt_2, 0.5_wp ) + ! + zu1 = zuvel1 / ze1 !** V1 in d(i,j)/dt + zv1 = zvvel1 / ze2 + + ! STEP 2 ! + ! ====== ! + ! !** X2 = X1+dt/2*V1 ; V2 = V1+dt/2*A1 + ! position using di/dt & djdt ! V2 in m/s + zxi2 = zxi1 + zdt_2 * zu1 ; zuvel2 = zuvel1 + zdt_2 * zax1 + zyj2 = zyj1 + zdt_2 * zv1 ; zvvel2 = zvvel1 + zdt_2 * zay1 + ! + CALL icb_ground( berg, zxi2, zxi1, zu1, & + & zyj2, zyj1, zv1, ll_bounced ) + + ! !** A2 = A(X2,V2) + CALL icb_accel( kt, berg , zxi2, ze1, zuvel2, zuvel1, zax2, & + & zyj2, ze2, zvvel2, zvvel1, zay2, zdt_2, 0.5_wp ) + ! + zu2 = zuvel2 / ze1 !** V2 in d(i,j)/dt + zv2 = zvvel2 / ze2 + ! + ! STEP 3 ! + ! ====== ! + ! !** X3 = X1+dt/2*V2 ; V3 = V1+dt/2*A2; A3=A(X3) + zxi3 = zxi1 + zdt_2 * zu2 ; zuvel3 = zuvel1 + zdt_2 * zax2 + zyj3 = zyj1 + zdt_2 * zv2 ; zvvel3 = zvvel1 + zdt_2 * zay2 + ! + CALL icb_ground( berg, zxi3, zxi1, zu2, & + & zyj3, zyj1, zv2, ll_bounced ) + + ! !** A3 = A(X3,V3) + CALL icb_accel( kt, berg , zxi3, ze1, zuvel3, zuvel1, zax3, & + & zyj3, ze2, zvvel3, zvvel1, zay3, zdt, 1._wp ) + ! + zu3 = zuvel3 / ze1 !** V3 in d(i,j)/dt + zv3 = zvvel3 / ze2 + + ! STEP 4 ! + ! ====== ! + ! !** X4 = X1+dt*V3 ; V4 = V1+dt*A3 + zxi4 = zxi1 + zdt * zu3 ; zuvel4 = zuvel1 + zdt * zax3 + zyj4 = zyj1 + zdt * zv3 ; zvvel4 = zvvel1 + zdt * zay3 + + CALL icb_ground( berg, zxi4, zxi1, zu3, & + & zyj4, zyj1, zv3, ll_bounced ) + + ! !** A4 = A(X4,V4) + CALL icb_accel( kt, berg , zxi4, ze1, zuvel4, zuvel1, zax4, & + & zyj4, ze2, zvvel4, zvvel1, zay4, zdt, 1._wp ) + + zu4 = zuvel4 / ze1 !** V4 in d(i,j)/dt + zv4 = zvvel4 / ze2 + + ! FINAL STEP ! + ! ========== ! + ! !** Xn = X1+dt*(V1+2*V2+2*V3+V4)/6 + ! !** Vn = V1+dt*(A1+2*A2+2*A3+A4)/6 + zxi_n = pt%xi + zdt_6 * ( zu1 + 2.*(zu2 + zu3 ) + zu4 ) + zyj_n = pt%yj + zdt_6 * ( zv1 + 2.*(zv2 + zv3 ) + zv4 ) + zuvel_n = pt%uvel + zdt_6 * ( zax1 + 2.*(zax2 + zax3) + zax4 ) + zvvel_n = pt%vvel + zdt_6 * ( zay1 + 2.*(zay2 + zay3) + zay4 ) + + CALL icb_ground( berg, zxi_n, zxi1, zuvel_n, & + & zyj_n, zyj1, zvvel_n, ll_bounced ) + + pt%uvel = zuvel_n !** save in berg structure + pt%vvel = zvvel_n + pt%xi = zxi_n + pt%yj = zyj_n + + berg => berg%next ! switch to the next berg + ! + END DO !== end loop over all bergs ==! + ! + END SUBROUTINE icb_dyn + + + SUBROUTINE icb_ground( berg, pi, pi0, pu, & + & pj, pj0, pv, ld_bounced ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_ground *** + !! + !! ** Purpose : iceberg grounding. + !! + !! ** Method : - adjust velocity and then put iceberg back to start position + !! NB two possibilities available one of which is hard-coded here + !!---------------------------------------------------------------------- + TYPE(iceberg ), POINTER, INTENT(in ) :: berg ! berg + ! + REAL(wp), INTENT(inout) :: pi , pj ! current iceberg position + REAL(wp), INTENT(in ) :: pi0, pj0 ! previous iceberg position + REAL(wp), INTENT(inout) :: pu , pv ! current iceberg velocities + LOGICAL , INTENT( out) :: ld_bounced ! bounced indicator + ! + INTEGER :: ii, ii0 + INTEGER :: ij, ij0 + INTEGER :: ikb + INTEGER :: ibounce_method + ! + REAL(wp) :: zD + REAL(wp), DIMENSION(jpk) :: ze3t + !!---------------------------------------------------------------------- + ! + ld_bounced = .FALSE. + ! + ii0 = INT( pi0+0.5 ) + (nn_hls-1) ; ij0 = INT( pj0+0.5 ) + (nn_hls-1) ! initial gridpoint position (T-cell) + ii = INT( pi +0.5 ) + (nn_hls-1) ; ij = INT( pj +0.5 ) + (nn_hls-1) ! current - - + ! + IF( ii == ii0 .AND. ij == ij0 ) RETURN ! berg remains in the same cell + ! + ! map into current processor + ii0 = mi1( ii0 ) + ij0 = mj1( ij0 ) + ii = mi1( ii ) + ij = mj1( ij ) + ! + ! assume icb is grounded if tmask(ii,ij,1) or tmask(ii,ij,ikb), depending of the option is not 0 + IF ( ln_M2016 .AND. ln_icb_grd ) THEN + ! + ! draught (keel depth) + zD = rho_berg_1_oce * berg%current_point%thickness + ! + ! interpol needed data + CALL icb_utl_interp( pi, pj, pe3t=ze3t ) + ! + !compute bottom level + CALL icb_utl_getkb( ikb, ze3t, zD ) + ! + ! berg reach a new t-cell, but an ocean one + ! .AND. needed in case berg hit an isf (tmask(ii,ij,1) == 0 and tmask(ii,ij,ikb) /= 0) + IF( tmask(ii,ij,ikb) /= 0._wp .AND. tmask(ii,ij,1) /= 0._wp ) RETURN + ! + ELSE + IF( tmask(ii,ij,1) /= 0._wp ) RETURN ! berg reach a new t-cell, but an ocean one + END IF + ! + ! From here, berg have reach land: treat grounding/bouncing + ! ------------------------------- + ld_bounced = .TRUE. + + !! not obvious what should happen now + !! if berg tries to enter a land box, the only location we can return it to is the start + !! position (pi0,pj0), since it has to be in a wet box to do any melting; + !! first option is simply to set whole velocity to zero and move back to start point + !! second option (suggested by gm) is only to set the velocity component in the (i,j) direction + !! of travel to zero; at a coastal boundary this has the effect of sliding the berg along the coast + + ibounce_method = 2 + SELECT CASE ( ibounce_method ) + CASE ( 1 ) + pi = pi0 + pj = pj0 + pu = 0._wp + pv = 0._wp + CASE ( 2 ) + IF( ii0 /= ii ) THEN + pi = pi0 ! return back to the initial position + pu = 0._wp ! zeroing of velocity in the direction of the grounding + ENDIF + IF( ij0 /= ij ) THEN + pj = pj0 ! return back to the initial position + pv = 0._wp ! zeroing of velocity in the direction of the grounding + ENDIF + END SELECT + ! + END SUBROUTINE icb_ground + + + SUBROUTINE icb_accel( kt, berg , pxi, pe1, puvel, puvel0, pax, & + & pyj, pe2, pvvel, pvvel0, pay, pdt, pcfl_scale ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_accel *** + !! + !! ** Purpose : compute the iceberg acceleration. + !! + !! ** Method : - sum the terms in the momentum budget + !!---------------------------------------------------------------------- + TYPE(iceberg ), POINTER, INTENT(in ) :: berg ! berg + INTEGER , INTENT(in ) :: kt ! time step + REAL(wp) , INTENT(in ) :: pcfl_scale + REAL(wp) , INTENT(in ) :: pxi , pyj ! berg position in (i,j) referential + REAL(wp) , INTENT(in ) :: puvel , pvvel ! berg velocity [m/s] + REAL(wp) , INTENT(in ) :: puvel0, pvvel0 ! initial berg velocity [m/s] + REAL(wp) , INTENT( out) :: pe1, pe2 ! horizontal scale factor at (xi,yj) + REAL(wp) , INTENT(inout) :: pax, pay ! berg acceleration + REAL(wp) , INTENT(in ) :: pdt ! berg time step + ! + REAL(wp), PARAMETER :: pp_alpha = 0._wp ! + REAL(wp), PARAMETER :: pp_beta = 1._wp ! + REAL(wp), PARAMETER :: pp_vel_lim =15._wp ! max allowed berg speed + REAL(wp), PARAMETER :: pp_accel_lim = 1.e-2_wp ! max allowed berg acceleration + REAL(wp), PARAMETER :: pp_Cr0 = 0.06_wp ! + ! + INTEGER :: itloop, ikb, jk + REAL(wp) :: zuo, zssu, zui, zua, zuwave, zssh_x, zcn, zhi + REAL(wp) :: zvo, zssv, zvi, zva, zvwave, zssh_y + REAL(wp) :: zff, zT, zD, zW, zL, zM, zF + REAL(wp) :: zdrag_ocn, zdrag_atm, zdrag_ice, zwave_rad + REAL(wp) :: z_ocn, z_atm, z_ice, zdep + REAL(wp) :: zampl, zwmod, zCr, zLwavelength, zLcutoff, zLtop + REAL(wp) :: zlambda, zdetA, zA11, zA12, zaxe, zaye, zD_hi + REAL(wp) :: zuveln, zvveln, zus, zvs, zspeed, zloc_dx, zspeed_new + REAL(wp), DIMENSION(jpk) :: zuoce, zvoce, ze3t, zdepw + !!---------------------------------------------------------------------- + + ! Interpolate gridded fields to berg + nknberg = berg%number(1) + CALL icb_utl_interp( pxi, pyj, pe1=pe1, pe2=pe2, & ! scale factor + & pssu=zssu, pui=zui, pua=zua, & ! oce/ice/atm velocities + & pssv=zssv, pvi=zvi, pva=zva, & ! oce/ice/atm velocities + & pssh_i=zssh_x, pssh_j=zssh_y, & ! ssh gradient + & phi=zhi, pff=zff) ! ice thickness and coriolis + + zM = berg%current_point%mass + zT = berg%current_point%thickness ! total thickness + zD = rho_berg_1_oce * zT ! draught (keel depth) + zF = zT - zD ! freeboard + zW = berg%current_point%width + zL = berg%current_point%length + + zhi = MIN( zhi , zD ) + zD_hi = MAX( 0._wp, zD-zhi ) + + ! Wave radiation + zuwave = zua - zssu ; zvwave = zva - zssv ! Use wind speed rel. to ocean for wave model + zwmod = zuwave*zuwave + zvwave*zvwave ! The wave amplitude and length depend on the current; + ! ! wind speed relative to the ocean. Actually wmod is wmod**2 here. + zampl = 0.5_wp * 0.02025_wp * zwmod ! This is "a", the wave amplitude + zLwavelength = 0.32_wp * zwmod ! Surface wave length fitted to data in table at + ! ! http://www4.ncsu.edu/eos/users/c/ceknowle/public/chapter10/part2.html + zLcutoff = 0.125_wp * zLwavelength + zLtop = 0.25_wp * zLwavelength + zCr = pp_Cr0 * MIN( MAX( 0._wp, (zL-zLcutoff) / ((zLtop-zLcutoff)+1.e-30)) , 1._wp) ! Wave radiation coefficient + ! ! fitted to graph from Carrieres et al., POAC Drift Model. + zwave_rad = 0.5_wp * pp_rho_seawater / zM * zCr * grav * zampl * MIN( zampl,zF ) * (2._wp*zW*zL) / (zW+zL) + zwmod = SQRT( zua*zua + zva*zva ) ! Wind speed + IF( zwmod /= 0._wp ) THEN + zuwave = zua/zwmod ! Wave radiation force acts in wind direction ... !!gm this should be the wind rel. to ocean ? + zvwave = zva/zwmod + ELSE + zuwave = 0._wp ; zvwave=0._wp ; zwave_rad=0._wp ! ... and only when wind is present. !!gm wave_rad=0. is useless + ENDIF + + ! Weighted drag coefficients + z_ocn = pp_rho_seawater / zM * (0.5_wp*pp_Cd_wv*zW*(zD_hi)+pp_Cd_wh*zW*zL) + z_atm = pp_rho_air / zM * (0.5_wp*pp_Cd_av*zW*zF +pp_Cd_ah*zW*zL) + z_ice = pp_rho_ice / zM * (0.5_wp*pp_Cd_iv*zW*zhi ) + IF( abs(zui) + abs(zvi) == 0._wp ) z_ice = 0._wp + + ! lateral velocities + ! default ssu and ssv + ! ln_M2016: mean velocity along the profile + IF ( ln_M2016 ) THEN + ! interpol needed data + CALL icb_utl_interp( pxi, pyj, puoce=zuoce, pvoce=zvoce, pe3t=ze3t ) ! 3d velocities + + !compute bottom level + CALL icb_utl_getkb( ikb, ze3t, zD ) + + ! compute mean velocity + CALL icb_utl_zavg(zuo, zuoce, ze3t, zD, ikb) + CALL icb_utl_zavg(zvo, zvoce, ze3t, zD, ikb) + ELSE + zuo = zssu + zvo = zssv + END IF + + zuveln = puvel ; zvveln = pvvel ! Copy starting uvel, vvel + ! + DO itloop = 1, 2 ! Iterate on drag coefficients + ! + zus = 0.5_wp * ( zuveln + puvel ) + zvs = 0.5_wp * ( zvveln + pvvel ) + zdrag_ocn = z_ocn * SQRT( (zus-zuo)*(zus-zuo) + (zvs-zvo)*(zvs-zvo) ) + zdrag_atm = z_atm * SQRT( (zus-zua)*(zus-zua) + (zvs-zva)*(zvs-zva) ) + zdrag_ice = z_ice * SQRT( (zus-zui)*(zus-zui) + (zvs-zvi)*(zvs-zvi) ) + ! + ! Explicit accelerations + !zaxe= zff*pvvel -grav*zssh_x +zwave_rad*zuwave & + ! -zdrag_ocn*(puvel-zssu) -zdrag_atm*(puvel-zua) -zdrag_ice*(puvel-zui) + !zaye=-zff*puvel -grav*zssh_y +zwave_rad*zvwave & + ! -zdrag_ocn*(pvvel-zssv) -zdrag_atm*(pvvel-zva) -zdrag_ice*(pvvel-zvi) + zaxe = -grav * zssh_x + zwave_rad * zuwave + zaye = -grav * zssh_y + zwave_rad * zvwave + IF( pp_alpha > 0._wp ) THEN ! If implicit, use time-level (n) rather than RK4 latest + zaxe = zaxe + zff*pvvel0 + zaye = zaye - zff*puvel0 + ELSE + zaxe = zaxe + zff*pvvel + zaye = zaye - zff*puvel + ENDIF + IF( pp_beta > 0._wp ) THEN ! If implicit, use time-level (n) rather than RK4 latest + zaxe = zaxe - zdrag_ocn*(puvel0-zuo) - zdrag_atm*(puvel0-zua) -zdrag_ice*(puvel0-zui) + zaye = zaye - zdrag_ocn*(pvvel0-zvo) - zdrag_atm*(pvvel0-zva) -zdrag_ice*(pvvel0-zvi) + ELSE + zaxe = zaxe - zdrag_ocn*(puvel -zuo) - zdrag_atm*(puvel -zua) -zdrag_ice*(puvel -zui) + zaye = zaye - zdrag_ocn*(pvvel -zvo) - zdrag_atm*(pvvel -zva) -zdrag_ice*(pvvel -zvi) + ENDIF + + ! Solve for implicit accelerations + IF( pp_alpha + pp_beta > 0._wp ) THEN + zlambda = zdrag_ocn + zdrag_atm + zdrag_ice + zA11 = 1._wp + pp_beta *pdt*zlambda + zA12 = pp_alpha*pdt*zff + zdetA = 1._wp / ( zA11*zA11 + zA12*zA12 ) + pax = zdetA * ( zA11*zaxe + zA12*zaye ) + pay = zdetA * ( zA11*zaye - zA12*zaxe ) + ELSE + pax = zaxe ; pay = zaye + ENDIF + + zuveln = puvel0 + pdt*pax + zvveln = pvvel0 + pdt*pay + ! + END DO ! itloop + + IF( rn_speed_limit > 0._wp ) THEN ! Limit speed of bergs based on a CFL criteria (if asked) + zspeed = SQRT( zuveln*zuveln + zvveln*zvveln ) ! Speed of berg + IF( zspeed > 0._wp ) THEN + zloc_dx = MIN( pe1, pe2 ) ! minimum grid spacing + ! cfl scale is function of the RK4 step + zspeed_new = zloc_dx / pdt * rn_speed_limit * pcfl_scale ! Speed limit as a factor of dx / dt + IF( zspeed_new < zspeed ) THEN + zuveln = zuveln * ( zspeed_new / zspeed ) ! Scale velocity to reduce speed + zvveln = zvveln * ( zspeed_new / zspeed ) ! without changing the direction + pax = (zuveln - puvel0)/pdt + pay = (zvveln - pvvel0)/pdt + ! + ! print speeding ticket + IF (nn_verbose_level > 0) THEN + WRITE(numicb, 9200) 'icb speeding : ',kt, nknberg, zspeed, & + & pxi, pyj, zuo, zvo, zua, zva, zui, zvi + 9200 FORMAT(a,i9,i6,f9.2,1x,4(1x,2f9.2)) + END IF + ! + CALL icb_dia_speed() + ENDIF + ENDIF + ENDIF + ! ! check the speed and acceleration limits + IF (nn_verbose_level > 0) THEN + IF( ABS( zuveln ) > pp_vel_lim .OR. ABS( zvveln ) > pp_vel_lim ) & + WRITE(numicb,'("pe=",i3,x,a)') narea,'Dump triggered by excessive velocity' + IF( ABS( pax ) > pp_accel_lim .OR. ABS( pay ) > pp_accel_lim ) & + WRITE(numicb,'("pe=",i3,x,a)') narea,'Dump triggered by excessive acceleration' + ENDIF + ! + END SUBROUTINE icb_accel + + !!====================================================================== +END MODULE icbdyn \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbini.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbini.F90 new file mode 100644 index 0000000..192c5ad --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbini.F90 @@ -0,0 +1,528 @@ +MODULE icbini + !!====================================================================== + !! *** MODULE icbini *** + !! Icebergs: initialise variables for iceberg tracking + !!====================================================================== + !! History : - ! 2010-01 (T. Martin & A. Adcroft) Original code + !! 3.3 ! 2011-03 (G. Madec) Part conversion to NEMO form ; Removal of mapping from another grid + !! - ! 2011-04 (S. Alderson) Split into separate modules ; Restore restart routines + !! - ! 2011-05 (S. Alderson) generate_test_icebergs restored ; new forcing arrays with extra halo ; + !! - ! north fold exchange arrays added + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! icb_init : initialise icebergs + !! icb_ini_gen : generate test icebergs + !! icb_nam : read iceberg namelist + !!---------------------------------------------------------------------- + USE dom_oce ! ocean domain + USE in_out_manager ! IO routines and numout in particular + USE lib_mpp ! mpi library and lk_mpp in particular + USE sbc_oce ! ocean : surface boundary condition + USE sbc_ice ! sea-ice: surface boundary condition + USE iom ! IOM library + USE fldread ! field read + USE lbclnk ! lateral boundary condition - MPP link + ! + USE icb_oce ! define iceberg arrays + USE icbutl ! iceberg utility routines + USE icbrst ! iceberg restart routines + USE icbtrj ! iceberg trajectory I/O routines + USE icbdia ! iceberg budget routines + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_init ! routine called in nemogcm.F90 module + + CHARACTER(len=100) :: cn_dir = './' !: Root directory for location of icb files + TYPE(FLD_N) :: sn_icb !: information about the calving file to be read + TYPE(FLD), PUBLIC, ALLOCATABLE , DIMENSION(:) :: sf_icb !: structure: file information, fields read + !: used in icbini and icbstp + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbini.F90 15372 2021-10-14 15:47:24Z davestorkey $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_init( pdt, kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_init *** + !! + !! ** Purpose : iceberg initialization. + !! + !! ** Method : - read the iceberg namelist + !! - find non-overlapping processor interior since we can only + !! have one instance of a particular iceberg + !! - calculate the destinations for north fold exchanges + !! - setup either test icebergs or calving file + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pdt ! iceberg time-step (rn_Dt*nn_fsbc) + INTEGER , INTENT(in) :: kt ! time step number + ! + INTEGER :: ji, jj, jn ! dummy loop indices + INTEGER :: i1, i2, i3 ! local integers + INTEGER :: ii, inum, ivar ! - - + INTEGER :: istat1, istat2, istat3 ! - - + CHARACTER(len=300) :: cl_sdist ! local character + !!---------------------------------------------------------------------- + ! + CALL icb_nam ! Read and print namelist parameters + ! + IF( .NOT. ln_icebergs ) RETURN + ! + ALLOCATE( utau_icb(jpi,jpj), vtau_icb(jpi,jpj) ) + ! + ! ! allocate gridded fields + IF( icb_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'icb_alloc : unable to allocate arrays' ) + ! + ! ! initialised variable with extra haloes to zero + ssu_e(:,:) = 0._wp ; ssv_e(:,:) = 0._wp ; + ua_e(:,:) = 0._wp ; va_e(:,:) = 0._wp ; + ff_e(:,:) = 0._wp ; sst_e(:,:) = 0._wp ; + fr_e(:,:) = 0._wp ; sss_e(:,:) = 0._wp ; + ! + IF ( ln_M2016 ) THEN + toce_e(:,:,:) = 0._wp + uoce_e(:,:,:) = 0._wp + voce_e(:,:,:) = 0._wp + e3t_e(:,:,:) = 0._wp + END IF + ! +#if defined key_si3 + hi_e(:,:) = 0._wp ; + ui_e(:,:) = 0._wp ; vi_e(:,:) = 0._wp ; +#endif + ssh_e(:,:) = 0._wp ; + ! + ! ! open ascii output file or files for iceberg status information + ! ! note that we choose to do this on all processors since we cannot + ! ! predict where icebergs will be ahead of time + IF( nn_verbose_level > 0) THEN + CALL ctl_opn( numicb, 'icebergs.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) + ENDIF + + ! set parameters (mostly from namelist) + ! + berg_dt = pdt + first_width (:) = SQRT( rn_initial_mass(:) / ( rn_LoW_ratio * rn_rho_bergs * rn_initial_thickness(:) ) ) + first_length(:) = rn_LoW_ratio * first_width(:) + rho_berg_1_oce = rn_rho_bergs / pp_rho_seawater ! scale factor used for convertion thickness to draft + ! + ! deepest level affected by icebergs + ! can be tuned but the safest is this + ! (with z* and z~ the depth of each level change overtime, so the more robust micbkb is jpk) + micbkb = jpk + + berg_grid%calving (:,:) = 0._wp + berg_grid%calving_hflx (:,:) = 0._wp + berg_grid%stored_heat (:,:) = 0._wp + berg_grid%floating_melt(:,:) = 0._wp + berg_grid%maxclass (:,:) = nclasses + berg_grid%stored_ice (:,:,:) = 0._wp + berg_grid%tmp (:,:) = 0._wp + src_calving (:,:) = 0._wp + src_calving_hflx (:,:) = 0._wp + + ! ! domain for icebergs + IF( lk_mpp .AND. jpni == 1 ) CALL ctl_stop( 'icbinit: having ONE processor in x currently does not work' ) + ! NB: the issue here is simply that cyclic east-west boundary condition have not been coded in mpp case + ! for the north fold we work out which points communicate by asking + ! lbc_lnk to pass processor number (valid even in single processor case) + ! borrow src_calving arrays for this + ! + ! pack i and j together using a scaling of a power of 10 + nicbpack = 10000 + IF( jpiglo >= nicbpack ) CALL ctl_stop( 'icbini: processor index packing failure' ) + nicbfldproc(:) = -1 + + DO_2D( 1, 1, 1, 1 ) + src_calving_hflx(ji,jj) = narea + src_calving (ji,jj) = nicbpack * mjg(jj) + mig(ji) + END_2D + CALL lbc_lnk( 'icbini', src_calving_hflx, 'T', 1._wp ) + CALL lbc_lnk( 'icbini', src_calving , 'T', 1._wp ) + + ! work out interior of processor from exchange array + ! first entry with narea for this processor is left hand interior index + ! last entry is right hand interior index + jj = jpj/2 + nicbdi = -1 + nicbei = -1 + DO ji = 1, jpi + i3 = INT( src_calving(ji,jj) ) + i2 = INT( i3/nicbpack ) + i1 = i3 - i2*nicbpack + i3 = INT( src_calving_hflx(ji,jj) ) + IF( i1 == mig(ji) .AND. i3 == narea ) THEN + IF( nicbdi < 0 ) THEN ; nicbdi = ji + ELSE ; nicbei = ji + ENDIF + ENDIF + END DO + ! + ! repeat for j direction + ji = jpi/2 + nicbdj = -1 + nicbej = -1 + DO jj = 1, jpj + i3 = INT( src_calving(ji,jj) ) + i2 = INT( i3/nicbpack ) + i1 = i3 - i2*nicbpack + i3 = INT( src_calving_hflx(ji,jj) ) + IF( i2 == mjg(jj) .AND. i3 == narea ) THEN + IF( nicbdj < 0 ) THEN ; nicbdj = jj + ELSE ; nicbej = jj + ENDIF + ENDIF + END DO + ! + ! special for east-west boundary exchange we save the destination index + i1 = MAX( nicbdi-1, 1) + i3 = INT( src_calving(i1,jpj/2) ) + jj = INT( i3/nicbpack ) + ricb_left = REAL( i3 - nicbpack*jj, wp ) - (nn_hls-1) + i1 = MIN( nicbei+1, jpi ) + i3 = INT( src_calving(i1,jpj/2) ) + jj = INT( i3/nicbpack ) + ricb_right = REAL( i3 - nicbpack*jj, wp ) - (nn_hls-1) + + ! north fold + IF( l_IdoNFold ) THEN + ! + ! icebergs in row nicbej+1 get passed across fold + nicbfldpts(:) = INT( src_calving(:,nicbej+1) ) + nicbflddest(:) = INT( src_calving_hflx(:,nicbej+1) ) + ! + ! work out list of unique processors to talk to + ! pack them into a fixed size array where empty slots are marked by a -1 + DO ji = nicbdi, nicbei + ii = nicbflddest(ji) + IF( ii .GT. 0 ) THEN ! Needed because land suppression can mean + ! that unused points are not set in edge haloes + DO jn = 1, jpni + ! work along array until we find an empty slot + IF( nicbfldproc(jn) == -1 ) THEN + nicbfldproc(jn) = ii + EXIT !!gm EXIT should be avoided: use DO WHILE expression instead + ENDIF + ! before we find an empty slot, we may find processor number is already here so we exit + IF( nicbfldproc(jn) == ii ) EXIT + END DO + ENDIF + END DO + ENDIF + ! + IF( nn_verbose_level > 0) THEN + WRITE(numicb,*) 'processor ', narea + WRITE(numicb,*) 'jpi, jpj ', jpi, jpj + WRITE(numicb,*) 'Nis0, Nie0 ', Nis0, Nie0 + WRITE(numicb,*) 'Njs0, Nje0 ', Njs0, Nje0 + WRITE(numicb,*) 'berg i interior ', nicbdi, nicbei + WRITE(numicb,*) 'berg j interior ', nicbdj, nicbej + WRITE(numicb,*) 'berg left ', ricb_left + WRITE(numicb,*) 'berg right ', ricb_right + jj = jpj/2 + WRITE(numicb,*) "central j line:" + WRITE(numicb,*) "i processor" + WRITE(numicb,*) (INT(src_calving_hflx(ji,jj)), ji=1,jpi) + WRITE(numicb,*) "i point" + WRITE(numicb,*) (INT(src_calving(ji,jj)), ji=1,jpi) + ji = jpi/2 + WRITE(numicb,*) "central i line:" + WRITE(numicb,*) "j processor" + WRITE(numicb,*) (INT(src_calving_hflx(ji,jj)), jj=1,jpj) + WRITE(numicb,*) "j point" + WRITE(numicb,*) (INT(src_calving(ji,jj)), jj=1,jpj) + IF( l_IdoNFold ) THEN + WRITE(numicb,*) 'north fold destination points ' + WRITE(numicb,*) nicbfldpts + WRITE(numicb,*) 'north fold destination procs ' + WRITE(numicb,*) nicbflddest + WRITE(numicb,*) 'north fold destination proclist ' + WRITE(numicb,*) nicbfldproc + ENDIF + CALL flush(numicb) + ENDIF + + src_calving (:,:) = 0._wp + src_calving_hflx(:,:) = 0._wp + + ! definition of extended surface masked needed by icb_bilin_h + tmask_e(:,:) = 0._wp ; tmask_e(1:jpi,1:jpj) = tmask(:,:,1) + umask_e(:,:) = 0._wp ; umask_e(1:jpi,1:jpj) = umask(:,:,1) + vmask_e(:,:) = 0._wp ; vmask_e(1:jpi,1:jpj) = vmask(:,:,1) + CALL lbc_lnk_icb( 'icbini', tmask_e, 'T', +1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbini', umask_e, 'U', +1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbini', vmask_e, 'V', +1._wp, 1, 1 ) + + ! definition of extended lat/lon array needed by icb_bilin_h + rlon_e(:,:) = 0._wp ; rlon_e(1:jpi,1:jpj) = glamt(:,:) + rlat_e(:,:) = 0._wp ; rlat_e(1:jpi,1:jpj) = gphit(:,:) + CALL lbc_lnk_icb( 'icbini', rlon_e, 'T', +1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbini', rlat_e, 'T', +1._wp, 1, 1 ) + ! + ! definnitionn of extennded ff_f array needed by icb_utl_interp + ff_e(:,:) = 0._wp ; ff_e(1:jpi,1:jpj) = ff_f(:,:) + CALL lbc_lnk_icb( 'icbini', ff_e, 'F', +1._wp, 1, 1 ) + + ! assign each new iceberg with a unique number constructed from the processor number + ! and incremented by the total number of processors + num_bergs(:) = 0 + num_bergs(1) = narea - jpnij + + ! when not generating test icebergs we need to setup calving file + IF( nn_test_icebergs < 0 .OR. ln_use_calving ) THEN + ! + ! maximum distribution class array does not change in time so read it once + cl_sdist = TRIM( cn_dir )//TRIM( sn_icb%clname ) + CALL iom_open ( cl_sdist, inum ) ! open file + ivar = iom_varid( inum, 'maxclass', ldstop=.FALSE. ) + IF( ivar > 0 ) THEN + CALL iom_get ( inum, jpdom_global, 'maxclass', src_calving ) ! read the max distribution array + berg_grid%maxclass(:,:) = INT( src_calving ) + src_calving(:,:) = 0._wp + ENDIF + CALL iom_close( inum ) ! close file + ! + IF( nn_verbose_level > 0) THEN + WRITE(numicb,*) + WRITE(numicb,*) ' calving read in a file' + ENDIF + ALLOCATE( sf_icb(1), STAT=istat1 ) ! Create sf_icb structure (calving) + ALLOCATE( sf_icb(1)%fnow(jpi,jpj,1), STAT=istat2 ) + ALLOCATE( sf_icb(1)%fdta(jpi,jpj,1,2), STAT=istat3 ) + IF( istat1+istat2+istat3 > 0 ) THEN + CALL ctl_stop( 'sbc_icb: unable to allocate sf_icb structure' ) ; RETURN + ENDIF + ! ! fill sf_icb with the namelist (sn_icb) and control print + CALL fld_fill( sf_icb, (/ sn_icb /), cn_dir, 'icb_init', 'read calving data', 'namicb' ) + ! + ENDIF + + IF( .NOT.ln_rstart ) THEN + IF( nn_test_icebergs > 0 ) CALL icb_ini_gen() + ELSE + IF( nn_test_icebergs > 0 ) THEN + CALL icb_ini_gen() + ELSE + CALL icb_rst_read() + l_restarted_bergs = .TRUE. + ENDIF + ENDIF + ! + IF( nn_sample_rate .GT. 0 ) CALL icb_trj_init( nitend ) + ! + CALL icb_dia_init() + ! + IF( nn_verbose_level >= 2 ) CALL icb_utl_print('icb_init, initial status', nit000-1) + ! + END SUBROUTINE icb_init + + + SUBROUTINE icb_ini_gen() + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_ini_gen *** + !! + !! ** Purpose : iceberg generation + !! + !! ** Method : - at each grid point of the test box supplied in the namelist + !! generate an iceberg in one class determined by the value of + !! parameter nn_test_icebergs + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, ibergs + TYPE(iceberg) :: localberg ! NOT a pointer but an actual local variable + TYPE(point) :: localpt + INTEGER :: iyr, imon, iday, ihr, imin, isec + INTEGER :: iberg + !!---------------------------------------------------------------------- + + ! For convenience + iberg = nn_test_icebergs + + ! call get_date(Time, iyr, imon, iday, ihr, imin, isec) + ! Convert nemo time variables from dom_oce into local versions + iyr = nyear + imon = nmonth + iday = nday + ihr = INT(nsec_day/3600) + imin = INT((nsec_day-ihr*3600)/60) + isec = nsec_day - ihr*3600 - imin*60 + + ! no overlap for icebergs since we want only one instance of each across the whole domain + ! so restrict area of interest + ! use tmask here because tmask_i has been doctored on one side of the north fold line + + DO jj = nicbdj, nicbej + DO ji = nicbdi, nicbei + IF( tmask(ji,jj,1) > 0._wp .AND. & + rn_test_box(1) < glamt(ji,jj) .AND. glamt(ji,jj) < rn_test_box(2) .AND. & + rn_test_box(3) < gphit(ji,jj) .AND. gphit(ji,jj) < rn_test_box(4) ) THEN + localberg%mass_scaling = rn_mass_scaling(iberg) + localpt%xi = REAL( mig(ji) - (nn_hls-1), wp ) + localpt%yj = REAL( mjg(jj) - (nn_hls-1), wp ) + CALL icb_utl_interp( localpt%xi, localpt%yj, plat=localpt%lat, plon=localpt%lon ) + localpt%mass = rn_initial_mass (iberg) + localpt%thickness = rn_initial_thickness(iberg) + localpt%width = first_width (iberg) + localpt%length = first_length(iberg) + localpt%year = iyr + localpt%day = REAL(iday,wp)+(REAL(ihr,wp)+REAL(imin,wp)/60._wp)/24._wp + localpt%mass_of_bits = 0._wp + localpt%heat_density = 0._wp + localpt%uvel = 0._wp + localpt%vvel = 0._wp + localpt%kb = 1 + CALL icb_utl_incr() + localberg%number(:) = num_bergs(:) + call icb_utl_add(localberg, localpt) + ENDIF + END DO + END DO + ! + ibergs = icb_utl_count() + CALL mpp_sum('icbini', ibergs) + IF( nn_verbose_level > 0) THEN + WRITE(numicb,'(a,i6,a)') 'diamonds, icb_ini_gen: ',ibergs,' were generated' + ENDIF + ! + END SUBROUTINE icb_ini_gen + + + SUBROUTINE icb_nam + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_nam *** + !! + !! ** Purpose : read iceberg namelist and print the variables. + !! + !! ** input : - namberg namelist + !!---------------------------------------------------------------------- + INTEGER :: jn ! dummy loop indices + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp) :: zfact ! local scalar + ! + NAMELIST/namberg/ ln_icebergs , ln_bergdia , nn_sample_rate , rn_initial_mass , & + & rn_distribution, rn_mass_scaling, rn_initial_thickness, nn_verbose_write , & + & rn_rho_bergs , rn_LoW_ratio , nn_verbose_level , ln_operator_splitting, & + & rn_bits_erosion_fraction , rn_sicn_shift , ln_passive_mode , & + & ln_time_average_weight , nn_test_icebergs , rn_test_box , & + & ln_use_calving , rn_speed_limit , cn_dir, sn_icb , ln_M2016 , & + & cn_icbrst_indir, cn_icbrst_in , cn_icbrst_outdir , cn_icbrst_out , & + & ln_icb_grd + !!---------------------------------------------------------------------- + +#if defined key_agrif + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'icb_nam : AGRIF is not compatible with namelist namberg : ' + WRITE(numout,*) '~~~~~~~ definition of rn_initial_mass(nclasses) with nclasses as PARAMETER ' + WRITE(numout,*) + WRITE(numout,*) ' ==>>> force NO icebergs used. The namelist namberg is not read' + ENDIF + ln_icebergs = .false. + RETURN +#else + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'icb_nam : iceberg initialization through namberg namelist read' + WRITE(numout,*) '~~~~~~~~ ' + ENDIF +#endif + ! !== read namelist ==! + READ ( numnam_ref, namberg, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namberg in reference namelist' ) + READ ( numnam_cfg, namberg, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namberg in configuration namelist' ) + IF(lwm) WRITE ( numond, namberg ) + ! + IF(lwp) WRITE(numout,*) + IF( ln_icebergs ) THEN + IF(lwp) WRITE(numout,*) ' ==>>> icebergs are used' + ELSE + IF(lwp) WRITE(numout,*) ' ==>>> No icebergs used' + RETURN + ENDIF + ! + IF( nn_test_icebergs > nclasses ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> Resetting of nn_test_icebergs to ', nclasses + nn_test_icebergs = nclasses + ENDIF + ! + IF( nn_test_icebergs < 0 .AND. .NOT. ln_use_calving ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> Resetting ln_use_calving to .true. since we are not using test icebergs' + ln_use_calving = .true. + ENDIF + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'icb_nam : iceberg initialization through namberg namelist read' + WRITE(numout,*) '~~~~~~~~ ' + WRITE(numout,*) ' Calculate budgets ln_bergdia = ', ln_bergdia + WRITE(numout,*) ' Period between sampling of position for trajectory storage nn_sample_rate = ', nn_sample_rate + WRITE(numout,*) ' Mass thresholds between iceberg classes (kg) rn_initial_mass =' + DO jn = 1, nclasses + WRITE(numout,'(a,f15.2)') ' ', rn_initial_mass(jn) + ENDDO + WRITE(numout,*) ' Fraction of calving to apply to this class (non-dim) rn_distribution =' + DO jn = 1, nclasses + WRITE(numout,'(a,f10.4)') ' ', rn_distribution(jn) + END DO + WRITE(numout,*) ' Ratio between effective and real iceberg mass (non-dim) rn_mass_scaling = ' + DO jn = 1, nclasses + WRITE(numout,'(a,f10.2)') ' ', rn_mass_scaling(jn) + END DO + WRITE(numout,*) ' Total thickness of newly calved bergs (m) rn_initial_thickness = ' + DO jn = 1, nclasses + WRITE(numout,'(a,f10.2)') ' ', rn_initial_thickness(jn) + END DO + WRITE(numout,*) ' Timesteps between verbose messages nn_verbose_write = ', nn_verbose_write + + WRITE(numout,*) ' Density of icebergs rn_rho_bergs = ', rn_rho_bergs + WRITE(numout,*) ' Initial ratio L/W for newly calved icebergs rn_LoW_ratio = ', rn_LoW_ratio + WRITE(numout,*) ' Turn on more verbose output level = ', nn_verbose_level + WRITE(numout,*) ' Use first order operator splitting for thermodynamics ', & + & 'use_operator_splitting = ', ln_operator_splitting + WRITE(numout,*) ' Fraction of erosion melt flux to divert to bergy bits ', & + & 'bits_erosion_fraction = ', rn_bits_erosion_fraction + + WRITE(numout,*) ' Use icb module modification from Merino et al. (2016) : ln_M2016 = ', ln_M2016 + WRITE(numout,*) ' ground icebergs if icb bottom lvl hit the oce bottom level : ln_icb_grd = ', ln_icb_grd + + WRITE(numout,*) ' Shift of sea-ice concentration in erosion flux modulation ', & + & '(0 0 ln_use_calving = ', ln_use_calving + WRITE(numout,*) ' CFL speed limit for a berg speed_limit = ', rn_speed_limit + WRITE(numout,*) ' Writing Iceberg status information to icebergs.stat file ' + ENDIF + ! + ! ensure that the sum of berg input distribution is equal to one + zfact = SUM( rn_distribution ) + IF( zfact /= 1._wp .AND. 0_wp /= zfact ) THEN + rn_distribution(:) = rn_distribution(:) / zfact + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ==>>> CAUTION: sum of berg input distribution = ', zfact + WRITE(numout,*) ' ******* redistribution has been rescaled' + WRITE(numout,*) ' updated berg distribution is :' + DO jn = 1, nclasses + WRITE(numout,'(a,f10.4)') ' ',rn_distribution(jn) + END DO + ENDIF + ENDIF + IF( MINVAL( rn_distribution(:) ) < 0._wp ) THEN + CALL ctl_stop( 'icb_nam: a negative rn_distribution value encountered ==>> change your namelist namberg' ) + ENDIF + ! + END SUBROUTINE icb_nam + + !!====================================================================== +END MODULE icbini \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icblbc.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icblbc.F90 new file mode 100644 index 0000000..80384fb --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icblbc.F90 @@ -0,0 +1,828 @@ +MODULE icblbc + !!====================================================================== + !! *** MODULE icblbc *** + !! Ocean physics: routines to handle boundary exchanges for icebergs + !!====================================================================== + !! History : 3.3 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! 2011-05 (Alderson) MPP exchanges written based on lib_mpp + !! - ! 2011-05 (Alderson) MPP and single processor boundary conditions added + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_lbc : - Pass icebergs across cyclic boundaries + !! icb_lbc_mpp : - In MPP pass icebergs from linked list between processors + !! as they advect around + !! - Lagrangian processes cannot be handled by existing NEMO MPP + !! routines because they do not lie on regular jpi,jpj grids + !! - Processor exchanges are handled as in lib_mpp whenever icebergs step + !! across boundary of interior domain (nicbdi-nicbei, nicbdj-nicbej) + !! so that iceberg does not exist in more than one processor + !! - North fold exchanges controlled by three arrays: + !! nicbflddest - unique processor numbers that current one exchanges with + !! nicbfldproc - processor number that current grid point exchanges with + !! nicbfldpts - packed i,j point in exchanging processor + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE dom_oce ! ocean domain + USE in_out_manager ! IO parameters + USE lib_mpp ! MPI code and lk_mpp in particular + USE icb_oce ! define iceberg arrays + USE icbutl ! iceberg utility routines + + IMPLICIT NONE + PRIVATE + +#if ! defined key_mpi_off + +!$AGRIF_DO_NOT_TREAT + INCLUDE 'mpif.h' +!$AGRIF_END_DO_NOT_TREAT + + TYPE, PUBLIC :: buffer + INTEGER :: size = 0 + REAL(wp), DIMENSION(:,:), POINTER :: data + END TYPE buffer + + TYPE(buffer), POINTER :: obuffer_n=>NULL() , ibuffer_n=>NULL() + TYPE(buffer), POINTER :: obuffer_s=>NULL() , ibuffer_s=>NULL() + TYPE(buffer), POINTER :: obuffer_e=>NULL() , ibuffer_e=>NULL() + TYPE(buffer), POINTER :: obuffer_w=>NULL() , ibuffer_w=>NULL() + + ! north fold exchange buffers + TYPE(buffer), POINTER :: obuffer_f=>NULL() , ibuffer_f=>NULL() + + INTEGER, PARAMETER, PRIVATE :: jp_delta_buf = 25 ! Size by which to increment buffers + INTEGER, PARAMETER, PRIVATE :: jp_buffer_width = 15+nkounts ! items to store for each berg + +#endif + + PUBLIC icb_lbc + PUBLIC icb_lbc_mpp + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icblbc.F90 15088 2021-07-06 13:03:34Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_lbc() + !!---------------------------------------------------------------------- + !! *** SUBROUTINE icb_lbc *** + !! + !! ** Purpose : in non-mpp case need to deal with cyclic conditions + !! including north-fold + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: this + TYPE(point) , POINTER :: pt + !!---------------------------------------------------------------------- + + !! periodic east/west boundaries + !! ============================= + + IF( l_Iperio ) THEN + + this => first_berg + DO WHILE( ASSOCIATED(this) ) + pt => this%current_point + IF( pt%xi > REAL(mig(nicbei),wp) + 0.5_wp ) THEN + pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp + ELSE IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp ) THEN + pt%xi = ricb_left + MOD(pt%xi, 1._wp ) + ENDIF + this => this%next + END DO + ! + ENDIF + + !! north/south boundaries + !! ====================== + IF( l_Jperio) CALL ctl_stop(' north-south periodicity not implemented for icebergs') + ! north fold + IF( l_IdoNFold ) CALL icb_lbc_nfld() + ! + END SUBROUTINE icb_lbc + + + SUBROUTINE icb_lbc_nfld() + !!---------------------------------------------------------------------- + !! *** SUBROUTINE icb_lbc_nfld *** + !! + !! ** Purpose : single processor north fold exchange + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: this + TYPE(point) , POINTER :: pt + INTEGER :: iine, ijne, ipts + INTEGER :: iiglo, ijglo + !!---------------------------------------------------------------------- + ! + this => first_berg + DO WHILE( ASSOCIATED(this) ) + pt => this%current_point + ijne = INT( pt%yj + 0.5 ) + IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN + ! + iine = INT( pt%xi + 0.5 ) + ipts = nicbfldpts (mi1(iine)) + ! + ! moving across the cut line means both position and + ! velocity must change + ijglo = INT( ipts/nicbpack ) + iiglo = ipts - nicbpack*ijglo + pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) + pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) + pt%uvel = -1._wp * pt%uvel + pt%vvel = -1._wp * pt%vvel + ENDIF + this => this%next + END DO + ! + END SUBROUTINE icb_lbc_nfld + +#if ! defined key_mpi_off + !!---------------------------------------------------------------------- + !! MPI massively parallel processing library + !!---------------------------------------------------------------------- + + SUBROUTINE icb_lbc_mpp() + !!---------------------------------------------------------------------- + !! *** SUBROUTINE icb_lbc_mpp *** + !! + !! ** Purpose : multi processor exchange + !! + !! ** Method : identify direction for exchange, pack into a buffer + !! which is basically a real array and delete from linked list + !! length of buffer is exchanged first with receiving processor + !! then buffer is sent if necessary + !!---------------------------------------------------------------------- + TYPE(iceberg) , POINTER :: tmpberg, this + TYPE(point) , POINTER :: pt + INTEGER :: ibergs_to_send_e, ibergs_to_send_w + INTEGER :: ibergs_to_send_n, ibergs_to_send_s + INTEGER :: ibergs_rcvd_from_e, ibergs_rcvd_from_w + INTEGER :: ibergs_rcvd_from_n, ibergs_rcvd_from_s + INTEGER :: i, ibergs_start, ibergs_end + INTEGER :: ipe_N, ipe_S, ipe_W, ipe_E + REAL(wp), DIMENSION(2) :: zewbergs, zwebergs, znsbergs, zsnbergs + INTEGER :: iml_req1, iml_req2, iml_req3, iml_req4 + INTEGER :: iml_req5, iml_req6, iml_req7, iml_req8, iml_err + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat + + ! set up indices of neighbouring processors + ipe_N = -1 + ipe_S = -1 + ipe_W = -1 + ipe_E = -1 + IF( mpinei(jpwe) >= 0 ) ipe_W = mpinei(jpwe) + IF( mpinei(jpea) >= 0 ) ipe_E = mpinei(jpea) + IF( mpinei(jpso) >= 0 ) ipe_S = mpinei(jpso) + IF( mpinei(jpno) >= 0 ) ipe_N = mpinei(jpno) + ! + ! at northern line of processors with north fold handle bergs differently + IF( l_IdoNFold ) ipe_N = -1 + + ! if there's only one processor in x direction then don't let mpp try to handle periodicity + IF( jpni == 1 ) THEN + ipe_E = -1 + ipe_W = -1 + ENDIF + + IF( nn_verbose_level >= 2 ) THEN + WRITE(numicb,*) 'processor west : ', ipe_W + WRITE(numicb,*) 'processor east : ', ipe_E + WRITE(numicb,*) 'processor north : ', ipe_N + WRITE(numicb,*) 'processor south : ', ipe_S + WRITE(numicb,*) 'processor nimpp : ', nimpp + WRITE(numicb,*) 'processor njmpp : ', njmpp + CALL flush( numicb ) + ENDIF + + ! periodicity is handled here when using mpp when there is more than one processor in + ! the i direction, but it also has to happen when jpni=1 case so this is dealt with + ! in icb_lbc and called here + + IF( jpni == 1 ) CALL icb_lbc() + + ! Note that xi is adjusted when swapping because of periodic condition + + IF( nn_verbose_level > 0 ) THEN + ! store the number of icebergs on this processor at start + ibergs_start = icb_utl_count() + ENDIF + + ibergs_to_send_e = 0 + ibergs_to_send_w = 0 + ibergs_to_send_n = 0 + ibergs_to_send_s = 0 + ibergs_rcvd_from_e = 0 + ibergs_rcvd_from_w = 0 + ibergs_rcvd_from_n = 0 + ibergs_rcvd_from_s = 0 + + IF( ASSOCIATED(first_berg) ) THEN ! Find number of bergs that headed east/west + this => first_berg + DO WHILE (ASSOCIATED(this)) + pt => this%current_point + IF( ipe_E >= 0 .AND. pt%xi > REAL(mig(nicbei),wp) + 0.5_wp - (nn_hls-1) ) THEN + tmpberg => this + this => this%next + ibergs_to_send_e = ibergs_to_send_e + 1 + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to east' + CALL flush( numicb ) + ENDIF + ! deal with periodic case + tmpberg%current_point%xi = ricb_right + MOD(tmpberg%current_point%xi, 1._wp ) - 1._wp + ! now pack it into buffer and delete from list + CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e) + CALL icb_utl_delete(first_berg, tmpberg) + ELSE IF( ipe_W >= 0 .AND. pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp - (nn_hls-1) ) THEN + tmpberg => this + this => this%next + ibergs_to_send_w = ibergs_to_send_w + 1 + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to west' + CALL flush( numicb ) + ENDIF + ! deal with periodic case + tmpberg%current_point%xi = ricb_left + MOD(tmpberg%current_point%xi, 1._wp ) + ! now pack it into buffer and delete from list + CALL icb_pack_into_buffer( tmpberg, obuffer_w, ibergs_to_send_w) + CALL icb_utl_delete(first_berg, tmpberg) + ELSE + this => this%next + ENDIF + END DO + ENDIF + IF( nn_verbose_level >= 3) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' send ew: ', ibergs_to_send_e, ibergs_to_send_w + CALL flush(numicb) + ENDIF + + ! send bergs east and receive bergs from west (ie ones that were sent east) and vice versa + + ! pattern here is copied from lib_mpp code + + IF( mpinei(jpwe) >= 0 ) zewbergs(1) = ibergs_to_send_w + IF( mpinei(jpea) >= 0 ) zwebergs(1) = ibergs_to_send_e + IF( mpinei(jpwe) >= 0 ) CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2) + IF( mpinei(jpea) >= 0 ) CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3) + IF( mpinei(jpea) >= 0 ) CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) + IF( mpinei(jpwe) >= 0 ) CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) + IF( mpinei(jpwe) >= 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) + IF( mpinei(jpea) >= 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) + IF( mpinei(jpea) >= 0 ) ibergs_rcvd_from_e = INT( zewbergs(2) ) + IF( mpinei(jpwe) >= 0 ) ibergs_rcvd_from_w = INT( zwebergs(2) ) + + IF( nn_verbose_level >= 3) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' recv ew: ', ibergs_rcvd_from_w, ibergs_rcvd_from_e + CALL flush(numicb) + ENDIF + + IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req2 ) + IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req3 ) + IF( ibergs_rcvd_from_e > 0 ) THEN + CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) + CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) + ENDIF + IF( ibergs_rcvd_from_w > 0 ) THEN + CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) + CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) + ENDIF + IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) + IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) + DO i = 1, ibergs_rcvd_from_e + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' + CALL FLUSH( numicb ) + ENDIF + CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) + END DO + DO i = 1, ibergs_rcvd_from_w + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' + CALL FLUSH( numicb ) + ENDIF + CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) + END DO + + ! Find number of bergs that headed north/south + ! (note: this block should technically go ahead of the E/W recv block above + ! to handle arbitrary orientation of PEs. But for simplicity, it is + ! here to accomodate diagonal transfer of bergs between PEs -AJA) + + IF( ASSOCIATED(first_berg) ) THEN + this => first_berg + DO WHILE (ASSOCIATED(this)) + pt => this%current_point + IF( ipe_N >= 0 .AND. pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN + tmpberg => this + this => this%next + ibergs_to_send_n = ibergs_to_send_n + 1 + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to north' + CALL flush( numicb ) + ENDIF + CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n) + CALL icb_utl_delete(first_berg, tmpberg) + ELSE IF( ipe_S >= 0 .AND. pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp - (nn_hls-1) ) THEN + tmpberg => this + this => this%next + ibergs_to_send_s = ibergs_to_send_s + 1 + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to south' + CALL flush( numicb ) + ENDIF + CALL icb_pack_into_buffer( tmpberg, obuffer_s, ibergs_to_send_s) + CALL icb_utl_delete(first_berg, tmpberg) + ELSE + this => this%next + ENDIF + END DO + ENDIF + if( nn_verbose_level >= 3) then + write(numicb,*) 'bergstep ',nktberg,' send ns: ', ibergs_to_send_n, ibergs_to_send_s + call flush(numicb) + endif + + ! send bergs north + ! and receive bergs from south (ie ones sent north) + + IF( mpinei(jpso) >= 0 ) znsbergs(1) = ibergs_to_send_s + IF( mpinei(jpno) >= 0 ) zsnbergs(1) = ibergs_to_send_n + IF( mpinei(jpso) >= 0 ) CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2) + IF( mpinei(jpno) >= 0 ) CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3) + IF( mpinei(jpno) >= 0 ) CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) + IF( mpinei(jpso) >= 0 ) CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) + IF( mpinei(jpso) >= 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) + IF( mpinei(jpno) >= 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) + IF( mpinei(jpno) >= 0 ) ibergs_rcvd_from_n = INT( znsbergs(2) ) + IF( mpinei(jpso) >= 0 ) ibergs_rcvd_from_s = INT( zsnbergs(2) ) + + IF( nn_verbose_level >= 3) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n + CALL FLUSH(numicb) + ENDIF + + IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req2 ) + IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req3 ) + IF( ibergs_rcvd_from_n > 0 ) THEN + CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) + CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) + ENDIF + IF( ibergs_rcvd_from_s > 0 ) THEN + CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) + CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) + ENDIF + IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) + IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) + DO i = 1, ibergs_rcvd_from_n + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' + CALL FLUSH( numicb ) + ENDIF + CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) + END DO + DO i = 1, ibergs_rcvd_from_s + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' + CALL FLUSH( numicb ) + ENDIF + CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) + END DO + + IF( nn_verbose_level > 0 ) THEN + ! compare the number of icebergs on this processor from the start to the end + ibergs_end = icb_utl_count() + i = ( ibergs_rcvd_from_n + ibergs_rcvd_from_s + ibergs_rcvd_from_e + ibergs_rcvd_from_w ) - & + ( ibergs_to_send_n + ibergs_to_send_s + ibergs_to_send_e + ibergs_to_send_w ) + IF( ibergs_end-(ibergs_start+i) .NE. 0 ) THEN + WRITE( numicb,* ) 'send_bergs_to_other_pes: net change in number of icebergs' + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_end=', & + ibergs_end,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_start=', & + ibergs_start,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: delta=', & + i,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: error=', & + ibergs_end-(ibergs_start+i),' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_n=', & + ibergs_to_send_n,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_s=', & + ibergs_to_send_s,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_e=', & + ibergs_to_send_e,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_w=', & + ibergs_to_send_w,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_n=', & + ibergs_rcvd_from_n,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_s=', & + ibergs_rcvd_from_s,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_e=', & + ibergs_rcvd_from_e,' on PE',narea + WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_w=', & + ibergs_rcvd_from_w,' on PE',narea + 1000 FORMAT(a,i5,a,i4) + CALL ctl_stop('send_bergs_to_other_pes: lost or gained an iceberg or two') + ENDIF + ENDIF + + ! deal with north fold if we necessary when there is more than one top row processor + ! note that for jpni=1 north fold has been dealt with above in call to icb_lbc + IF( l_IdoNFold .AND. jpni > 1 ) CALL icb_lbc_mpp_nfld( ) + + IF( nn_verbose_level > 0 ) THEN + i = 0 + this => first_berg + DO WHILE (ASSOCIATED(this)) + pt => this%current_point + IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp - (nn_hls-1) .OR. & + pt%xi > REAL(mig(nicbei),wp) + 0.5_wp - (nn_hls-1) .OR. & + pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp - (nn_hls-1) .OR. & + pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN + i = i + 1 + WRITE(numicb,*) 'berg lost in halo: ', this%number(:) + WRITE(numicb,*) ' ', nimpp, njmpp + WRITE(numicb,*) ' ', nicbdi, nicbei, nicbdj, nicbej + CALL flush( numicb ) + ENDIF + this => this%next + ENDDO ! WHILE + CALL mpp_sum('icblbc', i) + IF( i .GT. 0 ) THEN + WRITE( numicb,'(a,i4)') 'send_bergs_to_other_pes: # of bergs outside computational domain = ',i + CALL ctl_stop('send_bergs_to_other_pes: there are bergs still in halos!') + ENDIF ! root_pe + ENDIF ! debug + ! + CALL mppsync() + ! + END SUBROUTINE icb_lbc_mpp + + + SUBROUTINE icb_lbc_mpp_nfld() + !!---------------------------------------------------------------------- + !! *** SUBROUTINE icb_lbc_mpp_nfld *** + !! + !! ** Purpose : north fold treatment in multi processor exchange + !! + !! ** Method : + !!---------------------------------------------------------------------- + TYPE(iceberg) , POINTER :: tmpberg, this + TYPE(point) , POINTER :: pt + INTEGER :: ibergs_to_send + INTEGER :: ibergs_to_rcv + INTEGER :: iiglo, ijglo, jk, jn + INTEGER :: ifldproc, iproc, ipts + INTEGER :: iine, ijne + INTEGER :: jjn + REAL(wp), DIMENSION(0:3) :: zsbergs, znbergs + INTEGER :: iml_req1, iml_req2, iml_err + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat + + ! set up indices of neighbouring processors + + ! nicbfldproc is a list of unique processor numbers that this processor + ! exchanges with (including itself), so we loop over this array; since + ! its of fixed size, the first -1 marks end of list of processors + ! + nicbfldnsend(:) = 0 + nicbfldexpect(:) = 0 + nicbfldreq(:) = 0 + ! + ! Since each processor may be communicating with more than one northern + ! neighbour, cycle through the sends so that the receive order can be + ! controlled. + ! + ! First compute how many icebergs each active neighbour should expect + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + nicbfldnsend(jn) = 0 + + ! Find number of bergs that need to be exchanged + ! Pick out exchanges with processor ifldproc + ! if ifldproc is this processor then don't send + ! + IF( ASSOCIATED(first_berg) ) THEN + this => first_berg + DO WHILE (ASSOCIATED(this)) + pt => this%current_point + iine = INT( pt%xi + 0.5 ) + (nn_hls-1) + iproc = nicbflddest(mi1(iine)) + IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN + IF( iproc == ifldproc ) THEN + ! + IF( iproc /= narea ) THEN + tmpberg => this + nicbfldnsend(jn) = nicbfldnsend(jn) + 1 + ENDIF + ! + ENDIF + ENDIF + this => this%next + END DO + ENDIF + ! + ENDIF + ! + END DO + ! + ! Now tell each active neighbour how many icebergs to expect + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + IF( ifldproc == narea ) CYCLE + + zsbergs(0) = narea + zsbergs(1) = nicbfldnsend(jn) + !IF ( nicbfldnsend(jn) .GT. 0 .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB sending ',nicbfldnsend(jn),' to ', ifldproc + CALL mppsend( 21, zsbergs(0:1), 2, ifldproc-1, nicbfldreq(jn)) + ENDIF + ! + END DO + ! + ! and receive the heads-up from active neighbours preparing to send + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + IF( ifldproc == narea ) CYCLE + + CALL mpprecv( 21, znbergs(1:2), 2 ) + DO jjn = 1,jpni + IF( nicbfldproc(jjn) .eq. INT(znbergs(1)) ) EXIT + END DO + IF( jjn .GT. jpni .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB ERROR' + nicbfldexpect(jjn) = INT( znbergs(2) ) + !IF ( nicbfldexpect(jjn) .GT. 0 .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB expecting ',nicbfldexpect(jjn),' from ', nicbfldproc(jjn) + !IF (nn_verbose_level > 0) CALL FLUSH(numicb) + ENDIF + ! + END DO + ! + ! post the mpi waits if using immediate send protocol + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + IF( ifldproc == narea ) CYCLE + CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) + ENDIF + ! + END DO + + ! + ! Cycle through the icebergs again, this time packing and sending any + ! going through the north fold. They will be expected. + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + ibergs_to_send = 0 + + ! Find number of bergs that need to be exchanged + ! Pick out exchanges with processor ifldproc + ! if ifldproc is this processor then don't send + ! + IF( ASSOCIATED(first_berg) ) THEN + this => first_berg + DO WHILE (ASSOCIATED(this)) + pt => this%current_point + iine = INT( pt%xi + 0.5 ) + (nn_hls-1) + ijne = INT( pt%yj + 0.5 ) + (nn_hls-1) + ipts = nicbfldpts (mi1(iine)) + iproc = nicbflddest(mi1(iine)) + IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN + IF( iproc == ifldproc ) THEN + ! + ! moving across the cut line means both position and + ! velocity must change + ijglo = INT( ipts/nicbpack ) + iiglo = ipts - nicbpack*ijglo + pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) + pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) + pt%uvel = -1._wp * pt%uvel + pt%vvel = -1._wp * pt%vvel + ! + ! now remove berg from list and pack it into a buffer + IF( iproc /= narea ) THEN + tmpberg => this + ibergs_to_send = ibergs_to_send + 1 + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for north fold' + CALL flush( numicb ) + ENDIF + CALL icb_pack_into_buffer( tmpberg, obuffer_f, ibergs_to_send) + CALL icb_utl_delete(first_berg, tmpberg) + ENDIF + ! + ENDIF + ENDIF + this => this%next + END DO + ENDIF + if( nn_verbose_level >= 3) then + write(numicb,*) 'bergstep ',nktberg,' send nfld: ', ibergs_to_send + call flush(numicb) + endif + ! + ! if we're in this processor, then we've done everything we need to + ! so go on to next element of loop + IF( ifldproc == narea ) CYCLE + + ! send bergs + + IF( ibergs_to_send > 0 ) & + CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, nicbfldreq(jn) ) + ! + ENDIF + ! + END DO + ! + ! Now receive the expected number of bergs from the active neighbours + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + IF( ifldproc == narea ) CYCLE + ibergs_to_rcv = nicbfldexpect(jn) + + IF( ibergs_to_rcv > 0 ) THEN + CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv) + CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width, ifldproc-1 ) + ENDIF + ! + DO jk = 1, ibergs_to_rcv + IF( nn_verbose_level >= 4 ) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold' + CALL flush( numicb ) + ENDIF + CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk ) + END DO + ENDIF + ! + END DO + ! + ! Finally post the mpi waits if using immediate send protocol + DO jn = 1, jpni + IF( nicbfldproc(jn) /= -1 ) THEN + ifldproc = nicbfldproc(jn) + IF( ifldproc == narea ) CYCLE + CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) + ENDIF + ! + END DO + ! + END SUBROUTINE icb_lbc_mpp_nfld + + + SUBROUTINE icb_pack_into_buffer( berg, pbuff, kb ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: berg + TYPE(buffer) , POINTER :: pbuff + INTEGER , INTENT(in) :: kb + ! + INTEGER :: k ! local integer + !!---------------------------------------------------------------------- + ! + IF( .NOT. ASSOCIATED(pbuff) ) CALL icb_increase_buffer( pbuff, jp_delta_buf ) + IF( kb .GT. pbuff%size ) CALL icb_increase_buffer( pbuff, jp_delta_buf ) + + !! pack points into buffer + + pbuff%data( 1,kb) = berg%current_point%lon + pbuff%data( 2,kb) = berg%current_point%lat + pbuff%data( 3,kb) = berg%current_point%uvel + pbuff%data( 4,kb) = berg%current_point%vvel + pbuff%data( 5,kb) = berg%current_point%xi + pbuff%data( 6,kb) = berg%current_point%yj + pbuff%data( 7,kb) = float(berg%current_point%year) + pbuff%data( 8,kb) = berg%current_point%day + pbuff%data( 9,kb) = berg%current_point%mass + pbuff%data(10,kb) = berg%current_point%thickness + pbuff%data(11,kb) = berg%current_point%width + pbuff%data(12,kb) = berg%current_point%length + pbuff%data(13,kb) = berg%current_point%mass_of_bits + pbuff%data(14,kb) = berg%current_point%heat_density + + pbuff%data(15,kb) = berg%mass_scaling + DO k=1,nkounts + pbuff%data(15+k,kb) = REAL( berg%number(k), wp ) + END DO + ! + END SUBROUTINE icb_pack_into_buffer + + + SUBROUTINE icb_unpack_from_buffer(first, pbuff, kb) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: first + TYPE(buffer) , POINTER :: pbuff + INTEGER , INTENT(in) :: kb + ! + TYPE(iceberg) :: currentberg + TYPE(point) :: pt + INTEGER :: ik + !!---------------------------------------------------------------------- + ! + pt%lon = pbuff%data( 1,kb) + pt%lat = pbuff%data( 2,kb) + pt%uvel = pbuff%data( 3,kb) + pt%vvel = pbuff%data( 4,kb) + pt%xi = pbuff%data( 5,kb) + pt%yj = pbuff%data( 6,kb) + pt%year = INT( pbuff%data( 7,kb) ) + pt%day = pbuff%data( 8,kb) + pt%mass = pbuff%data( 9,kb) + pt%thickness = pbuff%data(10,kb) + pt%width = pbuff%data(11,kb) + pt%length = pbuff%data(12,kb) + pt%mass_of_bits = pbuff%data(13,kb) + pt%heat_density = pbuff%data(14,kb) + + currentberg%mass_scaling = pbuff%data(15,kb) + DO ik = 1, nkounts + currentberg%number(ik) = INT( pbuff%data(15+ik,kb) ) + END DO + ! + CALL icb_utl_add(currentberg, pt ) + ! + END SUBROUTINE icb_unpack_from_buffer + + + SUBROUTINE icb_increase_buffer(old,kdelta) + !!---------------------------------------------------------------------- + TYPE(buffer), POINTER :: old + INTEGER , INTENT(in) :: kdelta + ! + TYPE(buffer), POINTER :: new + INTEGER :: inew_size + !!---------------------------------------------------------------------- + ! + IF( .NOT. ASSOCIATED(old) ) THEN ; inew_size = kdelta + ELSE ; inew_size = old%size + kdelta + ENDIF + ALLOCATE( new ) + ALLOCATE( new%data( jp_buffer_width, inew_size) ) + new%size = inew_size + IF( ASSOCIATED(old) ) THEN + new%data(:,1:old%size) = old%data(:,1:old%size) + DEALLOCATE(old%data) + DEALLOCATE(old) + ENDIF + old => new + ! + END SUBROUTINE icb_increase_buffer + + + SUBROUTINE icb_increase_ibuffer(old,kdelta) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + TYPE(buffer), POINTER :: old + INTEGER , INTENT(in) :: kdelta + ! + TYPE(buffer), POINTER :: new + INTEGER :: inew_size, iold_size + !!---------------------------------------------------------------------- + + IF( .NOT. ASSOCIATED(old) ) THEN + inew_size = kdelta + jp_delta_buf + iold_size = 0 + ELSE + iold_size = old%size + IF( kdelta .LT. old%size ) THEN + inew_size = old%size + kdelta + ELSE + inew_size = kdelta + jp_delta_buf + ENDIF + ENDIF + + IF( iold_size .NE. inew_size ) THEN + ALLOCATE( new ) + ALLOCATE( new%data( jp_buffer_width, inew_size) ) + new%size = inew_size + IF( ASSOCIATED(old) ) THEN + new%data(:,1:old%size) = old%data(:,1:old%size) + DEALLOCATE(old%data) + DEALLOCATE(old) + ENDIF + old => new + !IF (nn_verbose_level > 0) WRITE( numicb,*) 'icb_increase_ibuffer',narea,' increased to',inew_size + ENDIF + ! + END SUBROUTINE icb_increase_ibuffer + +#else + !!---------------------------------------------------------------------- + !! Default case: Dummy module share memory computing + !!---------------------------------------------------------------------- + SUBROUTINE icb_lbc_mpp() + WRITE(numout,*) 'icb_lbc_mpp: You should not have seen this message!!' + END SUBROUTINE icb_lbc_mpp +#endif + + !!====================================================================== +END MODULE icblbc \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbrst.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbrst.F90 new file mode 100644 index 0000000..0d38a18 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbrst.F90 @@ -0,0 +1,428 @@ +MODULE icbrst + !!====================================================================== + !! *** MODULE icbrst *** + !! Ocean physics: read and write iceberg restart files + !!====================================================================== + !! History : 3.3.1 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! 2011-04 (Alderson) Restore restart routine + !! - ! Currently needs a fixed processor + !! - ! layout between restarts + !! - ! 2015-11 Dave Storkey Convert icb_rst_read to use IOM so can + !! read single restart files + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_rst_read : read restart file + !! icb_rst_write : write restart file + !!---------------------------------------------------------------------- + USE par_oce ! NEMO parameters + USE dom_oce ! NEMO domain + USE in_out_manager ! NEMO IO routines + USE lib_mpp ! NEMO MPI library, lk_mpp in particular + USE netcdf ! netcdf routines for IO + USE iom + USE icb_oce ! define iceberg arrays + USE icbutl ! iceberg utility routines + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_rst_read ! routine called in icbini.F90 module + PUBLIC icb_rst_write ! routine called in icbstp.F90 module + + INTEGER :: nlonid, nlatid, nxid, nyid, nuvelid, nvvelid + INTEGER :: nmassid, nthicknessid, nwidthid, nlengthid + INTEGER :: nyearid, ndayid + INTEGER :: nscaling_id, nmass_of_bits_id, nheat_density_id, numberid + INTEGER :: nsiceid, nsheatid, ncalvid, ncalvhid, nkountid + INTEGER :: nret, ncid, nc_dim + + INTEGER, DIMENSION(3) :: nstrt3, nlngth3 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbrst.F90 15088 2021-07-06 13:03:34Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_rst_read() + !!---------------------------------------------------------------------- + !! *** SUBROUTINE icb_rst_read *** + !! + !! ** Purpose : read a iceberg restart file + !! NB: for this version, we just read back in the restart for this processor + !! so we cannot change the processor layout currently with iceberg code + !!---------------------------------------------------------------------- + INTEGER :: idim, ivar, iatt + INTEGER :: jn, iunlim_dim, ibergs_in_file + INTEGER :: ii, ij, iclass, ibase_err, imax_icb + REAL(wp), DIMENSION(nkounts) :: zdata + LOGICAL :: ll_found_restart + CHARACTER(len=256) :: cl_path + CHARACTER(len=256) :: cl_filename + CHARACTER(len=NF90_MAX_NAME) :: cl_dname + TYPE(iceberg) :: localberg ! NOT a pointer but an actual local variable + TYPE(point) :: localpt ! NOT a pointer but an actual local variable + !!---------------------------------------------------------------------- + ! Find a restart file. Assume iceberg restarts in same directory as ocean restarts + ! and are called TRIM(cn_ocerst)//'_icebergs' + cl_path = TRIM(cn_icbrst_indir) + IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/' + cl_filename = TRIM(cn_icbrst_in) + CALL iom_open( TRIM(cl_path)//cl_filename, ncid ) + + imax_icb = 0 + IF( iom_file(ncid)%iduld .GE. 0) THEN + + ibergs_in_file = iom_file(ncid)%lenuld + DO jn = 1,ibergs_in_file + + ! iom_get treats the unlimited dimension as time. Here the unlimited dimension + ! is the iceberg index, but we can still use the ktime keyword to get the iceberg we want. + + CALL iom_get( ncid, 'xi' ,localpt%xi , ktime=jn ) + CALL iom_get( ncid, 'yj' ,localpt%yj , ktime=jn ) + + ii = INT( localpt%xi + 0.5 ) + ( nn_hls-1 ) + ij = INT( localpt%yj + 0.5 ) + ( nn_hls-1 ) + ! Only proceed if this iceberg is on the local processor (excluding halos). + IF ( ii >= mig(Nis0) .AND. ii <= mig(Nie0) .AND. & + & ij >= mjg(Njs0) .AND. ij <= mjg(Nje0) ) THEN + + CALL iom_get( ncid, jpdom_unknown, 'number', zdata(:) , ktime=jn, kstart=(/1/), kcount=(/nkounts/) ) + localberg%number(:) = INT(zdata(:)) + imax_icb = MAX( imax_icb, INT(zdata(1)) ) + CALL iom_get( ncid, 'mass_scaling' , localberg%mass_scaling, ktime=jn ) + CALL iom_get( ncid, 'lon' , localpt%lon , ktime=jn ) + CALL iom_get( ncid, 'lat' , localpt%lat , ktime=jn ) + CALL iom_get( ncid, 'uvel' , localpt%uvel , ktime=jn ) + CALL iom_get( ncid, 'vvel' , localpt%vvel , ktime=jn ) + CALL iom_get( ncid, 'mass' , localpt%mass , ktime=jn ) + CALL iom_get( ncid, 'thickness' , localpt%thickness , ktime=jn ) + CALL iom_get( ncid, 'width' , localpt%width , ktime=jn ) + CALL iom_get( ncid, 'length' , localpt%length , ktime=jn ) + CALL iom_get( ncid, 'year' , zdata(1) , ktime=jn ) + localpt%year = INT(zdata(1)) + CALL iom_get( ncid, 'day' , localpt%day , ktime=jn ) + CALL iom_get( ncid, 'mass_of_bits' , localpt%mass_of_bits , ktime=jn ) + CALL iom_get( ncid, 'heat_density' , localpt%heat_density , ktime=jn ) + ! + CALL icb_utl_add( localberg, localpt ) + ! + ENDIF + ! + END DO + ! + ELSE + ibergs_in_file = 0 + ENDIF + + ! Gridded variables + CALL iom_get( ncid, jpdom_auto, 'calving' , src_calving ) + CALL iom_get( ncid, jpdom_auto, 'calving_hflx', src_calving_hflx ) + CALL iom_get( ncid, jpdom_auto, 'stored_heat' , berg_grid%stored_heat ) + ! with jpdom_auto_xy, ue use only the third element of kstart and kcount. + CALL iom_get( ncid, jpdom_auto_xy, 'stored_ice' , berg_grid%stored_ice, kstart=(/-99,-99,1/), kcount=(/-99,-99,nclasses/) ) + + CALL iom_get( ncid, jpdom_unknown, 'kount' , zdata(:) ) + num_bergs(:) = INT(zdata(:)) + ! + + ! Sanity checks + jn = icb_utl_count() + IF ( lwp .AND. nn_verbose_level >= 0 ) & + WRITE(numout,'(2(a,i5))') 'icebergs, read_restart_bergs: # bergs =',jn,' on PE',narea-1 + IF( lk_mpp ) THEN + ! Only mpp_sum ibergs_in_file if we are reading from multiple restart files. + IF( INDEX(iom_file(ncid)%name,'icebergs.nc' ) .EQ. 0 ) CALL mpp_sum('icbrst', ibergs_in_file) + CALL mpp_sum('icbrst', jn) + ENDIF + IF( lwp ) WRITE(numout,'(a,i5,a,i5,a)') 'icebergs, icb_rst_read: there were',ibergs_in_file, & + & ' bergs in the restart file and', jn,' bergs have been read' + ! Close file + CALL iom_close( ncid ) + ! + ! Confirm that all areas have a suitable base for assigning new iceberg + ! numbers. This will not be the case if restarting from a collated dataset + ! (even if using the same processor decomposition) + ! + ibase_err = 0 + IF( num_bergs(1) < 0 .AND. num_bergs(1) /= narea - jpnij ) THEN + ! If this area has never calved a new berg then the base should be + ! set to narea - jpnij. If it is negative but something else then + ! a new base will be needed to guarantee unique, future iceberg numbers + ibase_err = 1 + ELSEIF( MOD( num_bergs(1) - narea , jpnij ) /= 0 ) THEN + ! If this area has a base which is not in the set {narea + N*jpnij} + ! for positive integers N then a new base will be needed to guarantee + ! unique, future iceberg numbers + ibase_err = 1 + ENDIF + IF( lk_mpp ) THEN + CALL mpp_sum('icbrst', ibase_err) + ENDIF + IF( ibase_err > 0 ) THEN + ! + ! A new base is needed. The only secure solution is to set bases such that + ! all future icebergs numbers will be greater than the current global maximum + IF( lk_mpp ) THEN + CALL mpp_max('icbrst', imax_icb) + ENDIF + num_bergs(1) = imax_icb - jpnij + narea + ENDIF + ! + IF( lwp .AND. nn_verbose_level >= 0 ) WRITE(numout,'(a)') 'icebergs, icb_rst_read: completed' + ! + END SUBROUTINE icb_rst_read + + + SUBROUTINE icb_rst_write( kt ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE icb_rst_write *** + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt + ! + INTEGER :: jn ! dummy loop index + INTEGER :: idg ! number of digits + INTEGER :: ix_dim, iy_dim, ik_dim, in_dim + CHARACTER(len=256) :: cl_path + CHARACTER(len=256) :: cl_filename + CHARACTER(len=8 ) :: cl_kt + CHARACTER(LEN=12 ) :: clfmt ! writing format + TYPE(iceberg), POINTER :: this + TYPE(point) , POINTER :: pt + !!---------------------------------------------------------------------- + + ! Following the normal restart procedure, this routine will be called + ! the timestep before a restart stage as well as the restart timestep. + ! This is a performance step enabling the file to be opened and contents + ! defined in advance of the write. This is not possible with icebergs + ! since the number of bergs to be written could change between timesteps + IF( kt == nitrst ) THEN + ! Only operate on the restart timestep itself. + ! Assume we write iceberg restarts to same directory as ocean restarts. + ! + ! directory name + cl_path = TRIM(cn_icbrst_outdir) + IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/' + ! + ! file name + WRITE(cl_kt, '(i8.8)') kt + cl_filename = TRIM(cexper)//"_"//cl_kt//"_"//TRIM(cn_icbrst_out) + IF( lk_mpp ) THEN + idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' + WRITE(cl_filename, clfmt) TRIM(cl_filename), '_', narea-1, '.nc' + ELSE + WRITE(cl_filename,'(a,a)') TRIM(cl_filename), '.nc' + ENDIF + + IF ( lwp .AND. nn_verbose_level >= 0) WRITE(numout,'(2a)') 'icebergs, write_restart: creating ', & + & TRIM(cl_path)//TRIM(cl_filename) + + nret = NF90_CREATE(TRIM(cl_path)//TRIM(cl_filename), NF90_CLOBBER, ncid) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_create failed') + + ! Dimensions + nret = NF90_DEF_DIM(ncid, 'x', Ni_0, ix_dim) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim x failed') + + nret = NF90_DEF_DIM(ncid, 'y', Nj_0, iy_dim) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim y failed') + + nret = NF90_DEF_DIM(ncid, 'c', nclasses, nc_dim) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim c failed') + + nret = NF90_DEF_DIM(ncid, 'k', nkounts, ik_dim) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim k failed') + + ! global attributes + IF( lk_mpp ) THEN + ! Set domain parameters (assume jpdom_local_full) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig0(Nis0), mjg0(Njs0) /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig0(Nie0), mjg0(Nje0) /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ) + ENDIF + + IF (associated(first_berg)) then + nret = NF90_DEF_DIM(ncid, 'n', NF90_UNLIMITED, in_dim) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim n failed') + ENDIF + + ! Variables + nret = NF90_DEF_VAR(ncid, 'kount' , NF90_INT , (/ ik_dim /), nkountid) + nret = NF90_DEF_VAR(ncid, 'calving' , NF90_DOUBLE, (/ ix_dim, iy_dim /), ncalvid) + nret = NF90_DEF_VAR(ncid, 'calving_hflx', NF90_DOUBLE, (/ ix_dim, iy_dim /), ncalvhid) + nret = NF90_DEF_VAR(ncid, 'stored_ice' , NF90_DOUBLE, (/ ix_dim, iy_dim, nc_dim /), nsiceid) + nret = NF90_DEF_VAR(ncid, 'stored_heat' , NF90_DOUBLE, (/ ix_dim, iy_dim /), nsheatid) + + ! Attributes + nret = NF90_PUT_ATT(ncid, ncalvid , 'long_name', 'iceberg calving') + nret = NF90_PUT_ATT(ncid, ncalvid , 'units', 'some') + nret = NF90_PUT_ATT(ncid, ncalvhid, 'long_name', 'heat flux associated with iceberg calving') + nret = NF90_PUT_ATT(ncid, ncalvhid, 'units', 'some') + nret = NF90_PUT_ATT(ncid, nsiceid , 'long_name', 'stored ice used to calve icebergs') + nret = NF90_PUT_ATT(ncid, nsiceid , 'units', 'kg/s') + nret = NF90_PUT_ATT(ncid, nsheatid, 'long_name', 'heat in stored ice used to calve icebergs') + nret = NF90_PUT_ATT(ncid, nsheatid, 'units', 'J/kg/s') + + IF ( ASSOCIATED(first_berg) ) THEN + + ! Only add berg variables for this PE if we have anything to say + + ! Variables + nret = NF90_DEF_VAR(ncid, 'lon', NF90_DOUBLE, in_dim, nlonid) + nret = NF90_DEF_VAR(ncid, 'lat', NF90_DOUBLE, in_dim, nlatid) + nret = NF90_DEF_VAR(ncid, 'xi', NF90_DOUBLE, in_dim, nxid) + nret = NF90_DEF_VAR(ncid, 'yj', NF90_DOUBLE, in_dim, nyid) + nret = NF90_DEF_VAR(ncid, 'uvel', NF90_DOUBLE, in_dim, nuvelid) + nret = NF90_DEF_VAR(ncid, 'vvel', NF90_DOUBLE, in_dim, nvvelid) + nret = NF90_DEF_VAR(ncid, 'mass', NF90_DOUBLE, in_dim, nmassid) + nret = NF90_DEF_VAR(ncid, 'thickness', NF90_DOUBLE, in_dim, nthicknessid) + nret = NF90_DEF_VAR(ncid, 'width', NF90_DOUBLE, in_dim, nwidthid) + nret = NF90_DEF_VAR(ncid, 'length', NF90_DOUBLE, in_dim, nlengthid) + nret = NF90_DEF_VAR(ncid, 'number', NF90_INT, (/ik_dim,in_dim/), numberid) + nret = NF90_DEF_VAR(ncid, 'year', NF90_INT, in_dim, nyearid) + nret = NF90_DEF_VAR(ncid, 'day', NF90_DOUBLE, in_dim, ndayid) + nret = NF90_DEF_VAR(ncid, 'mass_scaling', NF90_DOUBLE, in_dim, nscaling_id) + nret = NF90_DEF_VAR(ncid, 'mass_of_bits', NF90_DOUBLE, in_dim, nmass_of_bits_id) + nret = NF90_DEF_VAR(ncid, 'heat_density', NF90_DOUBLE, in_dim, nheat_density_id) + + ! Attributes + nret = NF90_PUT_ATT(ncid, nlonid, 'long_name', 'longitude') + nret = NF90_PUT_ATT(ncid, nlonid, 'units', 'degrees_E') + nret = NF90_PUT_ATT(ncid, nlatid, 'long_name', 'latitude') + nret = NF90_PUT_ATT(ncid, nlatid, 'units', 'degrees_N') + nret = NF90_PUT_ATT(ncid, nxid, 'long_name', 'x grid box position') + nret = NF90_PUT_ATT(ncid, nxid, 'units', 'fractional') + nret = NF90_PUT_ATT(ncid, nyid, 'long_name', 'y grid box position') + nret = NF90_PUT_ATT(ncid, nyid, 'units', 'fractional') + nret = NF90_PUT_ATT(ncid, nuvelid, 'long_name', 'zonal velocity') + nret = NF90_PUT_ATT(ncid, nuvelid, 'units', 'm/s') + nret = NF90_PUT_ATT(ncid, nvvelid, 'long_name', 'meridional velocity') + nret = NF90_PUT_ATT(ncid, nvvelid, 'units', 'm/s') + nret = NF90_PUT_ATT(ncid, nmassid, 'long_name', 'mass') + nret = NF90_PUT_ATT(ncid, nmassid, 'units', 'kg') + nret = NF90_PUT_ATT(ncid, nthicknessid, 'long_name', 'thickness') + nret = NF90_PUT_ATT(ncid, nthicknessid, 'units', 'm') + nret = NF90_PUT_ATT(ncid, nwidthid, 'long_name', 'width') + nret = NF90_PUT_ATT(ncid, nwidthid, 'units', 'm') + nret = NF90_PUT_ATT(ncid, nlengthid, 'long_name', 'length') + nret = NF90_PUT_ATT(ncid, nlengthid, 'units', 'm') + nret = NF90_PUT_ATT(ncid, numberid, 'long_name', 'iceberg number on this processor') + nret = NF90_PUT_ATT(ncid, numberid, 'units', 'count') + nret = NF90_PUT_ATT(ncid, nyearid, 'long_name', 'calendar year of calving event') + nret = NF90_PUT_ATT(ncid, nyearid, 'units', 'years') + nret = NF90_PUT_ATT(ncid, ndayid, 'long_name', 'year day of calving event') + nret = NF90_PUT_ATT(ncid, ndayid, 'units', 'days') + nret = NF90_PUT_ATT(ncid, nscaling_id, 'long_name', 'scaling factor for mass of calving berg') + nret = NF90_PUT_ATT(ncid, nscaling_id, 'units', 'none') + nret = NF90_PUT_ATT(ncid, nmass_of_bits_id, 'long_name', 'mass of bergy bits') + nret = NF90_PUT_ATT(ncid, nmass_of_bits_id, 'units', 'kg') + nret = NF90_PUT_ATT(ncid, nheat_density_id, 'long_name', 'heat density') + nret = NF90_PUT_ATT(ncid, nheat_density_id, 'units', 'J/kg') + + ENDIF ! associated(first_berg) + + ! End define mode + nret = NF90_ENDDEF(ncid) + + ! -------------------------------- + ! now write some data + + nstrt3(1) = 1 + nstrt3(2) = 1 + nlngth3(1) = Ni_0 + nlngth3(2) = Nj_0 + nlngth3(3) = 1 + + DO jn=1,nclasses + nstrt3(3) = jn + nret = NF90_PUT_VAR( ncid, nsiceid, berg_grid%stored_ice(Nis0:Nie0,Njs0:Nje0,jn), nstrt3, nlngth3 ) + IF (nret .ne. NF90_NOERR) THEN + IF( lwp ) WRITE(numout,*) TRIM(NF90_STRERROR( nret )) + CALL ctl_stop('icebergs, write_restart: nf_put_var stored_ice failed') + ENDIF + ENDDO + IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: stored_ice written' + + nret = NF90_PUT_VAR( ncid, nkountid, num_bergs(:) ) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var kount failed') + + nret = NF90_PUT_VAR( ncid, nsheatid, berg_grid%stored_heat(Nis0:Nie0,Njs0:Nje0) ) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var stored_heat failed') + IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: stored_heat written' + + nret = NF90_PUT_VAR( ncid, ncalvid , src_calving(Nis0:Nie0,Njs0:Nje0) ) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var calving failed') + nret = NF90_PUT_VAR( ncid, ncalvhid, src_calving_hflx(Nis0:Nie0,Njs0:Nje0) ) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_put_var calving_hflx failed') + IF( lwp ) WRITE(numout,*) 'file: ',TRIM(cl_path)//TRIM(cl_filename),' var: calving written' + + IF ( ASSOCIATED(first_berg) ) THEN + + ! Write variables + ! just write out the current point of the trajectory + + this => first_berg + jn = 0 + DO WHILE (ASSOCIATED(this)) + pt => this%current_point + jn=jn+1 + + nret = NF90_PUT_VAR(ncid, numberid, this%number, (/1,jn/), (/nkounts,1/) ) + nret = NF90_PUT_VAR(ncid, nscaling_id, this%mass_scaling, (/ jn /) ) + + nret = NF90_PUT_VAR(ncid, nlonid, pt%lon, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nlatid, pt%lat, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nxid, pt%xi, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nyid, pt%yj, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nuvelid, pt%uvel, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nvvelid, pt%vvel, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nmassid, pt%mass, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nthicknessid, pt%thickness, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nwidthid, pt%width, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nlengthid, pt%length, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nyearid, pt%year, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, ndayid, pt%day, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nmass_of_bits_id, pt%mass_of_bits, (/ jn /) ) + nret = NF90_PUT_VAR(ncid, nheat_density_id, pt%heat_density, (/ jn /) ) + + this=>this%next + END DO + ! + ENDIF ! associated(first_berg) + + ! Finish up + nret = NF90_CLOSE(ncid) + IF (nret /= NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_close failed') + + ! Sanity check + jn = icb_utl_count() + IF ( lwp .AND. nn_verbose_level >= 0) & + WRITE(numout,'(2(a,i5))') 'icebergs, icb_rst_write: # bergs =',jn,' on PE',narea-1 + IF( lk_mpp ) THEN + CALL mpp_sum('icbrst', jn) + ENDIF + IF(lwp) WRITE(numout,'(a,i5,a,i5,a)') 'icebergs, icb_rst_write: ', jn, & + & ' bergs in total have been written at timestep ', kt + ! + ! Finish up + ! + ENDIF + END SUBROUTINE icb_rst_write + ! + !!====================================================================== +END MODULE icbrst \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbstp.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbstp.F90 new file mode 100644 index 0000000..2c7cc87 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbstp.F90 @@ -0,0 +1,177 @@ +MODULE icbstp + !!====================================================================== + !! *** MODULE icbstp *** + !! Icebergs: initialise variables for iceberg tracking + !!====================================================================== + !! History : 3.3.1 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! Move budgets to icbdia routine + !! - ! 2011-05 (Alderson) Add call to copy forcing arrays + !! - ! into icb copies with haloes + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_stp : start iceberg tracking + !! icb_end : end iceberg tracking + !!---------------------------------------------------------------------- + USE par_oce ! nemo parameters + USE dom_oce ! ocean domain + USE sbc_oce ! ocean surface forcing + USE phycst ! physical constants + ! + USE icb_oce ! iceberg: define arrays + USE icbini ! iceberg: initialisation routines + USE icbutl ! iceberg: utility routines + USE icbrst ! iceberg: restart routines + USE icbdyn ! iceberg: dynamics (ie advection) routines + USE icbclv ! iceberg: calving routines + USE icbthm ! iceberg: thermodynamics routines + USE icblbc ! iceberg: lateral boundary routines (including mpp) + USE icbtrj ! iceberg: trajectory I/O routines + USE icbdia ! iceberg: budget + ! + USE in_out_manager ! nemo IO + USE lib_mpp ! massively parallel library + USE iom ! I/O manager + USE fldread ! field read + USE timing ! timing + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_stp ! routine called in sbcmod.F90 module + PUBLIC icb_end ! routine called in nemogcm.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbstp.F90 14239 2020-12-23 08:57:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_stp( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_stp *** + !! + !! ** Purpose : iceberg time stepping. + !! + !! ** Method : - top level routine to do things in the correct order + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step index + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + LOGICAL :: ll_sample_traj, ll_budget, ll_verbose ! local logical + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('icb_stp') + + ! !== start of timestep housekeeping ==! + ! + nktberg = kt + ! + !CALL test_icb_utl_getkb + !CALL ctl_stop('end test icb') + ! + IF( nn_test_icebergs < 0 .OR. ln_use_calving ) THEN !* read calving data + ! + CALL fld_read ( kt, 1, sf_icb ) + src_calving (:,:) = sf_icb(1)%fnow(:,:,1) ! calving in km^3/year (water equivalent) + src_calving_hflx(:,:) = 0._wp ! NO heat flux for now + ! + ENDIF + ! + berg_grid%floating_melt(:,:) = 0._wp + ! + ! !* anything that needs to be reset to zero each timestep + CALL icb_dia_step() ! for budgets is dealt with here + ! + ! !* write out time + ll_verbose = .FALSE. + IF( nn_verbose_write > 0 .AND. MOD( kt-1 , nn_verbose_write ) == 0 ) ll_verbose = ( nn_verbose_level > 0 ) + ! + IF( ll_verbose ) WRITE(numicb,9100) nktberg, ndastp, nsec_day + 9100 FORMAT('kt= ',i8, ' day= ',i8,' secs=',i8) + ! + ! !* copy nemo forcing arrays into iceberg versions with extra halo + CALL icb_utl_copy( Kmm ) ! only necessary for variables not on T points + ! + ! + ! !== process icebergs ==! + ! ! + CALL icb_clv_flx( kt ) ! Accumulate ice from calving + ! ! + CALL icb_clv( kt ) ! Calve excess stored ice into icebergs + ! ! + ! + ! !== For each berg, evolve ==! + ! + IF( ASSOCIATED(first_berg) ) CALL icb_dyn( kt ) ! ice berg dynamics + + IF( lk_mpp ) THEN ; CALL icb_lbc_mpp() ! Send bergs to other PEs + ELSE ; CALL icb_lbc() ! Deal with any cyclic boundaries in non-mpp case + ENDIF + + IF( ASSOCIATED(first_berg) ) CALL icb_thm( kt ) ! Ice berg thermodynamics (melting) + rolling + ! + ! + ! !== diagnostics and output ==! + ! + ! !* For each berg, record trajectory (when needed) + ll_sample_traj = .FALSE. + IF( nn_sample_rate > 0 .AND. MOD(kt-1,nn_sample_rate) == 0 ) ll_sample_traj = .TRUE. + IF( ll_sample_traj .AND. ASSOCIATED(first_berg) ) CALL icb_trj_write( kt ) + + ! !* Gridded diagnostics + ! ! To get these iom_put's and those preceding to actually do something + ! ! use key_xios in cpp file and create content for XML file + ! + CALL iom_put( "calving" , berg_grid%calving (:,:) ) ! 'calving mass input' + CALL iom_put( "berg_floating_melt", berg_grid%floating_melt(:,:) ) ! 'Melt rate of icebergs + bits' , 'kg/m2/s' + CALL iom_put( "berg_stored_ice" , berg_grid%stored_ice (:,:,:) ) ! 'Accumulated ice mass by class', 'kg' + ! + CALL icb_dia_put() !* store mean budgets + ! + ! !* Dump icebergs to screen + IF( nn_verbose_level >= 2 ) CALL icb_utl_print( 'icb_stp, status', kt ) + ! + ! !* Diagnose budgets + ll_budget = .FALSE. + IF( nn_verbose_write > 0 .AND. MOD(kt-1,nn_verbose_write) == 0 ) ll_budget = ln_bergdia + CALL icb_dia( ll_budget ) + ! + IF( lrst_oce ) THEN !* restart + CALL icb_rst_write( kt ) + IF( nn_sample_rate > 0 ) CALL icb_trj_sync() + ENDIF + ! + IF( ln_timing ) CALL timing_stop('icb_stp') + ! + END SUBROUTINE icb_stp + + + SUBROUTINE icb_end( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_end *** + !! + !! ** Purpose : close iceberg files + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! model time-step index + !!---------------------------------------------------------------------- + ! + ! finish with trajectories if they were written + IF( nn_sample_rate > 0 ) CALL icb_trj_end() + + IF(lwp) WRITE(numout,'(a,i6)') 'icebergs: icb_end complete', narea + ! + IF( nn_verbose_level > 0 ) THEN + CALL flush( numicb ) + CLOSE( numicb ) + ENDIF + ! + END SUBROUTINE icb_end + + !!====================================================================== +END MODULE icbstp \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbthm.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbthm.F90 new file mode 100644 index 0000000..edc1415 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbthm.F90 @@ -0,0 +1,297 @@ +MODULE icbthm + !!====================================================================== + !! *** MODULE icbthm *** + !! Icebergs: thermodynamics routines for icebergs + !!====================================================================== + !! History : 3.3.1 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! - ! 2011-05 (Alderson) Use tmask instead of tmask_i + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! icb_thm : initialise + !! reference for equations - M = Martin + Adcroft, OM 34, 2010 + !!---------------------------------------------------------------------- + USE par_oce ! NEMO parameters + USE dom_oce ! NEMO domain + USE in_out_manager ! NEMO IO routines, numout in particular + USE lib_mpp ! NEMO MPI routines, ctl_stop in particular + USE phycst ! NEMO physical constants + USE sbc_oce + USE eosbn2 ! equation of state + USE lib_fortran, ONLY : DDPDD + + USE icb_oce ! define iceberg arrays + USE icbutl ! iceberg utility routines + USE icbdia ! iceberg budget routines + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_thm ! routine called in icbstp.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbthm.F90 15088 2021-07-06 13:03:34Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_thm( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_thm *** + !! + !! ** Purpose : compute the iceberg thermodynamics. + !! + !! ** Method : - See Martin & Adcroft, Ocean Modelling 34, 2010 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! timestep number, just passed to icb_utl_print_berg + ! + INTEGER :: ii, ij, jk, ikb + REAL(wp) :: zM, zT, zW, zL, zSST, zVol, zLn, zWn, zTn, znVol, zIC, zDn, zD, zvb, zub, ztb + REAL(wp) :: zMv, zMe, zMb, zmelt, zdvo, zdvob, zdva, zdM, zSs, zdMe, zdMb, zdMv + REAL(wp) :: zSSS, zfzpt + REAL(wp) :: zMnew, zMnew1, zMnew2, zheat_hcflux, zheat_latent, z1_12 + REAL(wp) :: zMbits, znMbits, zdMbitsE, zdMbitsM, zLbits, zAbits, zMbb + REAL(wp) :: zxi, zyj, zff, z1_rday, z1_e1e2, zdt, z1_dt, z1_dt_e1e2, zdepw + REAL(wp), DIMENSION(jpk) :: ztoce, zuoce, zvoce, ze3t, zzMv + TYPE(iceberg), POINTER :: this, next + TYPE(point) , POINTER :: pt + ! + COMPLEX(dp), DIMENSION(jpi,jpj) :: cicb_melt, cicb_hflx + !!---------------------------------------------------------------------- + ! + !! initialiaze cicb_melt and cicb_heat + cicb_melt = CMPLX( 0.e0, 0.e0, dp ) + cicb_hflx = CMPLX( 0.e0, 0.e0, dp ) + ! + z1_rday = 1._wp / rday + z1_12 = 1._wp / 12._wp + zdt = berg_dt + z1_dt = 1._wp / zdt + ! + ! we're either going to ignore berg fresh water melt flux and associated heat + ! or we pass it into the ocean, so at this point we set them both to zero, + ! accumulate the contributions to them from each iceberg in the while loop following + ! and then pass them (or not) to the ocean + ! + berg_grid%floating_melt(:,:) = 0._wp + ! calving_hflx re-used here as temporary workspace for the heat flux associated with melting + berg_grid%calving_hflx(:,:) = 0._wp + ! + this => first_berg + DO WHILE( ASSOCIATED(this) ) + ! + pt => this%current_point + nknberg = this%number(1) + + CALL icb_utl_interp( pt%xi, pt%yj, & ! position + & pssu=pt%ssu, pua=pt%ua, & ! oce/atm velocities + & pssv=pt%ssv, pva=pt%va, & ! oce/atm velocities + & psst=pt%sst, pcn=pt%cn, & + & psss=pt%sss ) + + IF ( nn_sample_rate > 0 .AND. MOD(kt-1,nn_sample_rate) == 0 ) THEN + CALL icb_utl_interp( pt%xi, pt%yj, pe1=pt%e1, pe2=pt%e2, & + & pui=pt%ui, pssh_i=pt%ssh_x, & + & pvi=pt%vi, pssh_j=pt%ssh_y, & + & phi=pt%hi, & + & plat=pt%lat, plon=pt%lon ) + END IF + ! + zSST = pt%sst + zSSS = pt%sss + CALL eos_fzp(zSSS,zfzpt) ! freezing point + zIC = MIN( 1._wp, pt%cn + rn_sicn_shift ) ! Shift sea-ice concentration !!gm ??? + zM = pt%mass + zT = pt%thickness ! total thickness + zD = rho_berg_1_oce * zT ! draught (keel depth) + zW = pt%width + zL = pt%length + zxi = pt%xi ! position in (i,j) referential + zyj = pt%yj + ii = INT( zxi + 0.5 ) ! T-cell of the berg + ii = mi1( ii + (nn_hls-1) ) + ij = INT( zyj + 0.5 ) + ij = mj1( ij + (nn_hls-1) ) + zVol = zT * zW * zL + + ! Environment + ! default sst, ssu and ssv + ! ln_M2016: use temp, u and v profile + IF ( ln_M2016 ) THEN + + ! load t, u, v and e3 profile at icb position + CALL icb_utl_interp( pt%xi, pt%yj, ptoce=ztoce, puoce=zuoce, pvoce=zvoce, pe3t=ze3t ) + + !compute bottom level + CALL icb_utl_getkb( pt%kb, ze3t, zD ) + + ikb = MIN(pt%kb,mbkt(ii,ij)) ! limit pt%kb by mbkt + ! => bottom temperature used to fill ztoce(mbkt:jpk) + ztb = ztoce(ikb) ! basal temperature + zub = zuoce(ikb) + zvb = zvoce(ikb) + ELSE + ztb = pt%sst + zub = pt%ssu + zvb = pt%ssv + END IF + + zdvob = SQRT( (pt%uvel-zub)**2 + (pt%vvel-zvb)**2 ) ! relative basal velocity + zdva = SQRT( (pt%ua -pt%ssu)**2 + (pt%va -pt%ssv)**2 ) ! relative wind + zSs = 1.5_wp * SQRT( zdva ) + 0.1_wp * zdva ! Sea state (eqn M.A9) + ! + ! Melt rates in m/s (i.e. division by rday) + ! Buoyant convection at sides (eqn M.A10) + IF ( ln_M2016 ) THEN + ! averaging along all the iceberg draft + zzMv(:) = MAX( 7.62d-3*ztoce(:)+1.29d-3*(ztoce(:)**2), 0._wp ) * z1_rday + CALL icb_utl_zavg(zMv, zzMv, ze3t, zD, ikb ) + ELSE + zMv = MAX( 7.62d-3*zSST+1.29d-3*(zSST**2), 0._wp ) * z1_rday + END IF + ! + ! Basal turbulent melting (eqn M.A7 ) + IF ( zSST > zfzpt ) THEN ! Calculate basal melting only if SST above freezing point + zMb = MAX( 0.58_wp*(zdvob**0.8_wp)*(ztb+4.0_wp)/(zL**0.2_wp) , 0._wp ) * z1_rday + ELSE + zMb = 0._wp ! No basal melting if SST below freezing point + ENDIF + ! + ! Wave erosion (eqn M.A8 ) + zMe = MAX( z1_12*(zSST+2.)*zSs*(1._wp+COS(rpi*(zIC**3))) , 0._wp ) * z1_rday + + IF( ln_operator_splitting ) THEN ! Operator split update of volume/mass + zTn = MAX( zT - zMb*zdt , 0._wp ) ! new total thickness (m) + znVol = zTn * zW * zL ! new volume (m^3) + zMnew1 = ( znVol / zVol ) * zM ! new mass (kg) + zdMb = zM - zMnew1 ! mass lost to basal melting (>0) (kg) + ! + zLn = MAX( zL - zMv*zdt , 0._wp ) ! new length (m) + zWn = MAX( zW - zMv*zdt , 0._wp ) ! new width (m) + znVol = zTn * zWn * zLn ! new volume (m^3) + zMnew2 = ( znVol / zVol ) * zM ! new mass (kg) + zdMv = zMnew1 - zMnew2 ! mass lost to buoyant convection (>0) (kg) + ! + zLn = MAX( zLn - zMe*zdt , 0._wp ) ! new length (m) + zWn = MAX( zWn - zMe*zdt , 0._wp ) ! new width (m) + znVol = zTn * zWn * zLn ! new volume (m^3) + zMnew = ( znVol / zVol ) * zM ! new mass (kg) + zdMe = zMnew2 - zMnew ! mass lost to erosion (>0) (kg) + zdM = zM - zMnew ! mass lost to all erosion and melting (>0) (kg) + ! + ELSE ! Update dimensions of berg + zLn = MAX( zL -(zMv+zMe)*zdt ,0._wp ) ! (m) + zWn = MAX( zW -(zMv+zMe)*zdt ,0._wp ) ! (m) + zTn = MAX( zT - zMb *zdt ,0._wp ) ! (m) + ! Update volume and mass of berg + znVol = zTn*zWn*zLn ! (m^3) + zMnew = (znVol/zVol)*zM ! (kg) + zdM = zM - zMnew ! (kg) + zdMb = (zM/zVol) * (zW* zL ) *zMb*zdt ! approx. mass loss to basal melting (kg) + zdMe = (zM/zVol) * (zT*(zW+zL)) *zMe*zdt ! approx. mass lost to erosion (kg) + zdMv = (zM/zVol) * (zT*(zW+zL)) *zMv*zdt ! approx. mass loss to buoyant convection (kg) + ENDIF + + IF( rn_bits_erosion_fraction > 0._wp ) THEN ! Bergy bits + ! + zMbits = pt%mass_of_bits ! mass of bergy bits (kg) + zdMbitsE = rn_bits_erosion_fraction * zdMe ! change in mass of bits (kg) + znMbits = zMbits + zdMbitsE ! add new bergy bits to mass (kg) + zLbits = MIN( zL, zW, zT, 40._wp ) ! assume bergy bits are smallest dimension or 40 meters + zAbits = ( zMbits / rn_rho_bergs ) / zLbits ! Effective bottom area (assuming T=Lbits) + zMbb = MAX( 0.58_wp*(zdvob**0.8_wp)*(zSST+2._wp) / & + & ( zLbits**0.2_wp ) , 0._wp ) * z1_rday ! Basal turbulent melting (for bits) + zMbb = rn_rho_bergs * zAbits * zMbb ! in kg/s + zdMbitsM = MIN( zMbb*zdt , znMbits ) ! bergy bits mass lost to melting (kg) + znMbits = znMbits-zdMbitsM ! remove mass lost to bergy bits melt + IF( zMnew == 0._wp ) THEN ! if parent berg has completely melted then + zdMbitsM = zdMbitsM + znMbits ! instantly melt all the bergy bits + znMbits = 0._wp + ENDIF + ELSE ! No bergy bits + zAbits = 0._wp + zdMbitsE = 0._wp + zdMbitsM = 0._wp + znMbits = pt%mass_of_bits ! retain previous value incase non-zero + ENDIF + + ! use tmask rather than tmask_i when dealing with icebergs + IF( tmask(ii,ij,1) /= 0._wp ) THEN ! Add melting to the grid and field diagnostics + z1_e1e2 = r1_e1e2t(ii,ij) * this%mass_scaling + z1_dt_e1e2 = z1_dt * z1_e1e2 + ! + ! iceberg melt + !! the use of DDPDD function for the cumulative sum is needed for reproducibility + zmelt = ( zdM - ( zdMbitsE - zdMbitsM ) ) * z1_dt ! kg/s + CALL DDPDD( CMPLX( zmelt * z1_e1e2, 0.e0, dp ), cicb_melt(ii,ij) ) + ! + ! iceberg heat flux + !! the use of DDPDD function for the cumulative sum is needed for reproducibility + !! NB. The src_calving_hflx field is currently hardwired to zero in icb_stp, which means that the + !! heat density of the icebergs is zero and the heat content flux to the ocean from iceberg + !! melting is always zero. Leaving the term in the code until such a time as this is fixed. DS. + zheat_hcflux = zmelt * pt%heat_density ! heat content flux : kg/s x J/kg = J/s + zheat_latent = - zmelt * rLfus ! latent heat flux: kg/s x J/kg = J/s + CALL DDPDD( CMPLX( ( zheat_hcflux + zheat_latent ) * z1_e1e2, 0.e0, dp ), cicb_hflx(ii,ij) ) + ! + ! diagnostics + CALL icb_dia_melt( ii, ij, zMnew, zheat_hcflux, zheat_latent, this%mass_scaling, & + & zdM, zdMbitsE, zdMbitsM, zdMb, zdMe, & + & zdMv, z1_dt_e1e2, z1_e1e2 ) + ELSE + WRITE(numout,*) 'icb_thm: berg ',this%number(:),' appears to have grounded at ',narea,ii,ij + CALL icb_utl_print_berg( this, kt ) + WRITE(numout,*) 'msk=',tmask(ii,ij,1), e1e2t(ii,ij) + CALL ctl_stop('icb_thm', 'berg appears to have grounded!') + ENDIF + + ! Rolling + zDn = rho_berg_1_oce * zTn ! draught (keel depth) + IF( zDn > 0._wp .AND. MAX(zWn,zLn) < SQRT( 0.92*(zDn**2) + 58.32*zDn ) ) THEN + zT = zTn + zTn = zWn + zWn = zT + ENDIF + + ! Store the new state of iceberg (with L>W) + pt%mass = zMnew + pt%mass_of_bits = znMbits + pt%thickness = zTn + pt%width = MIN( zWn , zLn ) + pt%length = MAX( zWn , zLn ) + + next=>this%next + +!!gm add a test to avoid over melting ? +!!pm I agree, over melting could break conservation (more melt than calving) + + IF( zMnew <= 0._wp ) THEN ! Delete the berg if completely melted + CALL icb_utl_delete( first_berg, this ) + ! + ELSE ! Diagnose mass distribution on grid + z1_e1e2 = r1_e1e2t(ii,ij) * this%mass_scaling + CALL icb_dia_size( ii, ij, zWn, zLn, zAbits, & + & this%mass_scaling, zMnew, znMbits, z1_e1e2 ) + ENDIF + ! + this=>next + ! + END DO + ! + berg_grid%floating_melt = REAL(cicb_melt,dp) ! kg/m2/s + berg_grid%calving_hflx = REAL(cicb_hflx,dp) + ! + ! now use melt and associated heat flux in ocean (or not) + ! + IF(.NOT. ln_passive_mode ) THEN + emp (:,:) = emp (:,:) - berg_grid%floating_melt(:,:) + qns (:,:) = qns (:,:) + berg_grid%calving_hflx (:,:) + ENDIF + ! + END SUBROUTINE icb_thm + + !!====================================================================== +END MODULE icbthm \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbtrj.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbtrj.F90 new file mode 100644 index 0000000..4cc5411 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbtrj.F90 @@ -0,0 +1,287 @@ +MODULE icbtrj + !!====================================================================== + !! *** MODULE icbtrj *** + !! Ocean physics: trajectory I/O routines + !!====================================================================== + !! History : 3.3 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-05 (Alderson) New module to handle trajectory output + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_trj_init : initialise iceberg trajectory output files + !! icb_trj_write : + !! icb_trj_sync : + !! icb_trj_end : + !!---------------------------------------------------------------------- + USE par_oce ! NEMO parameters + USE dom_oce ! NEMO ocean domain + USE phycst ! NEMO physical constants + USE icb_oce ! define iceberg arrays + USE icbutl ! iceberg utility routines + ! + USE lib_mpp ! NEMO MPI library, lk_mpp in particular + USE in_out_manager ! NEMO IO, numout in particular + USE ioipsl , ONLY : ju2ymds ! for calendar + USE netcdf + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_trj_init ! routine called in icbini.F90 module + PUBLIC icb_trj_write ! routine called in icbstp.F90 module + PUBLIC icb_trj_sync ! routine called in icbstp.F90 module + PUBLIC icb_trj_end ! routine called in icbstp.F90 module + + INTEGER :: num_traj = 0 + INTEGER :: n_dim, m_dim + INTEGER :: ntrajid + INTEGER :: numberid, nstepid, nscaling_id + INTEGER :: nlonid, nlatid, nxid, nyid, nuvelid, nvvelid, nmassid + INTEGER :: nssuid, nssvid, nuaid, nvaid, nuiid, nviid + INTEGER :: nsshxid, nsshyid, nsstid, ncntid, nthkid + INTEGER :: nthicknessid, nwidthid, nlengthid + INTEGER :: nyearid, ndayid + INTEGER :: nmass_of_bits_id, nheat_density_id + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbtrj.F90 14030 2020-12-03 09:26:33Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_trj_init( ktend ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_trj_init *** + !! + !! ** Purpose : initialise iceberg trajectory output files + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: ktend ! time step index + ! + INTEGER :: iret, iyear, imonth, iday + INTEGER :: idg ! number of digits + REAL(dp) :: zfjulday, zsec + CHARACTER(len=80) :: cl_filename + CHARACTER(LEN=12) :: clfmt ! writing format + CHARACTER(LEN=8 ) :: cldate_ini, cldate_end + TYPE(iceberg), POINTER :: this + TYPE(point) , POINTER :: pt + !!---------------------------------------------------------------------- + + ! compute initial time step date + CALL ju2ymds( fjulday, iyear, imonth, iday, zsec ) + WRITE(cldate_ini, '(i4.4,2i2.2)') iyear, imonth, iday + + ! compute end time step date + zfjulday = fjulday + rn_Dt / rday * REAL( nitend - nit000 + 1 , wp) + IF( ABS(zfjulday - REAL(NINT(zfjulday),wp)) < 0.1 / rday ) zfjulday = REAL(NINT(zfjulday),wp) ! avoid truncation error + CALL ju2ymds( zfjulday, iyear, imonth, iday, zsec ) + WRITE(cldate_end, '(i4.4,2i2.2)') iyear, imonth, iday + + ! define trajectory output name + cl_filename = 'trajectory_icebergs_'//cldate_ini//'-'//cldate_end + IF ( lk_mpp ) THEN + idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' + WRITE(cl_filename, clfmt) TRIM(cl_filename), '_', narea-1, '.nc' + ELSE + WRITE(cl_filename,'(a,a)') TRIM(cl_filename), '.nc' + ENDIF + IF( lwp .AND. nn_verbose_level >= 0 ) WRITE(numout,'(2a)') 'icebergs, icb_trj_init: creating ',TRIM(cl_filename) + + iret = NF90_CREATE( TRIM(cl_filename), NF90_CLOBBER, ntrajid ) + IF (iret .NE. NF90_NOERR) CALL ctl_stop('icebergs, icb_trj_init: nf_create failed') + + ! Dimensions + iret = NF90_DEF_DIM( ntrajid, 'n', NF90_UNLIMITED, n_dim ) + IF ( iret /= NF90_NOERR ) CALL ctl_stop('icebergs, icb_trj_init: nf_def_dim n failed') + iret = NF90_DEF_DIM( ntrajid, 'k', nkounts, m_dim ) + IF ( iret /= NF90_NOERR ) CALL ctl_stop('icebergs, icb_trj_init: nf_def_dim k failed') + + ! Variables + iret = NF90_DEF_VAR( ntrajid, 'iceberg_number', NF90_INT , (/m_dim,n_dim/), numberid ) + iret = NF90_DEF_VAR( ntrajid, 'timestep' , NF90_INT , n_dim , nstepid ) + iret = NF90_DEF_VAR( ntrajid, 'mass_scaling' , NF90_DOUBLE, n_dim , nscaling_id ) + iret = NF90_DEF_VAR( ntrajid, 'lon' , NF90_DOUBLE, n_dim , nlonid ) + iret = NF90_DEF_VAR( ntrajid, 'lat' , NF90_DOUBLE, n_dim , nlatid ) + iret = NF90_DEF_VAR( ntrajid, 'xi' , NF90_DOUBLE, n_dim , nxid ) + iret = NF90_DEF_VAR( ntrajid, 'yj' , NF90_DOUBLE, n_dim , nyid ) + iret = NF90_DEF_VAR( ntrajid, 'uvel' , NF90_DOUBLE, n_dim , nuvelid ) + iret = NF90_DEF_VAR( ntrajid, 'vvel' , NF90_DOUBLE, n_dim , nvvelid ) + iret = NF90_DEF_VAR( ntrajid, 'ssu' , NF90_DOUBLE, n_dim , nssuid ) + iret = NF90_DEF_VAR( ntrajid, 'ssv' , NF90_DOUBLE, n_dim , nssvid ) + iret = NF90_DEF_VAR( ntrajid, 'uta' , NF90_DOUBLE, n_dim , nuaid ) + iret = NF90_DEF_VAR( ntrajid, 'vta' , NF90_DOUBLE, n_dim , nvaid ) + iret = NF90_DEF_VAR( ntrajid, 'uti' , NF90_DOUBLE, n_dim , nuiid ) + iret = NF90_DEF_VAR( ntrajid, 'vti' , NF90_DOUBLE, n_dim , nviid ) + iret = NF90_DEF_VAR( ntrajid, 'ssh_x' , NF90_DOUBLE, n_dim , nsshxid ) + iret = NF90_DEF_VAR( ntrajid, 'ssh_y' , NF90_DOUBLE, n_dim , nsshyid ) + iret = NF90_DEF_VAR( ntrajid, 'sst' , NF90_DOUBLE, n_dim , nsstid ) + iret = NF90_DEF_VAR( ntrajid, 'icnt' , NF90_DOUBLE, n_dim , ncntid ) + iret = NF90_DEF_VAR( ntrajid, 'ithk' , NF90_DOUBLE, n_dim , nthkid ) + iret = NF90_DEF_VAR( ntrajid, 'mass' , NF90_DOUBLE, n_dim , nmassid ) + iret = NF90_DEF_VAR( ntrajid, 'thickness' , NF90_DOUBLE, n_dim , nthicknessid ) + iret = NF90_DEF_VAR( ntrajid, 'width' , NF90_DOUBLE, n_dim , nwidthid ) + iret = NF90_DEF_VAR( ntrajid, 'length' , NF90_DOUBLE, n_dim , nlengthid ) + iret = NF90_DEF_VAR( ntrajid, 'year' , NF90_INT , n_dim , nyearid ) + iret = NF90_DEF_VAR( ntrajid, 'day' , NF90_DOUBLE, n_dim , ndayid ) + iret = NF90_DEF_VAR( ntrajid, 'mass_of_bits' , NF90_DOUBLE, n_dim , nmass_of_bits_id ) + iret = NF90_DEF_VAR( ntrajid, 'heat_density' , NF90_DOUBLE, n_dim , nheat_density_id ) + + ! Attributes + iret = NF90_PUT_ATT( ntrajid, numberid , 'long_name', 'iceberg number on this processor' ) + iret = NF90_PUT_ATT( ntrajid, numberid , 'units' , 'count' ) + iret = NF90_PUT_ATT( ntrajid, nstepid , 'long_name', 'timestep number kt' ) + iret = NF90_PUT_ATT( ntrajid, nstepid , 'units' , 'count' ) + iret = NF90_PUT_ATT( ntrajid, nlonid , 'long_name', 'longitude' ) + iret = NF90_PUT_ATT( ntrajid, nlonid , 'units' , 'degrees_E') + iret = NF90_PUT_ATT( ntrajid, nlatid , 'long_name', 'latitude' ) + iret = NF90_PUT_ATT( ntrajid, nlatid , 'units' , 'degrees_N' ) + iret = NF90_PUT_ATT( ntrajid, nxid , 'long_name', 'x grid box position' ) + iret = NF90_PUT_ATT( ntrajid, nxid , 'units' , 'fractional' ) + iret = NF90_PUT_ATT( ntrajid, nyid , 'long_name', 'y grid box position' ) + iret = NF90_PUT_ATT( ntrajid, nyid , 'units' , 'fractional' ) + iret = NF90_PUT_ATT( ntrajid, nuvelid , 'long_name', 'zonal velocity' ) + iret = NF90_PUT_ATT( ntrajid, nuvelid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nvvelid , 'long_name', 'meridional velocity' ) + iret = NF90_PUT_ATT( ntrajid, nvvelid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nssuid , 'long_name', 'ocean u component' ) + iret = NF90_PUT_ATT( ntrajid, nssuid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nssvid , 'long_name', 'ocean v component' ) + iret = NF90_PUT_ATT( ntrajid, nssvid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nuaid , 'long_name', 'atmosphere u component' ) + iret = NF90_PUT_ATT( ntrajid, nuaid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nvaid , 'long_name', 'atmosphere v component' ) + iret = NF90_PUT_ATT( ntrajid, nvaid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nuiid , 'long_name', 'sea ice u component' ) + iret = NF90_PUT_ATT( ntrajid, nuiid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nviid , 'long_name', 'sea ice v component' ) + iret = NF90_PUT_ATT( ntrajid, nviid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nsshxid , 'long_name', 'sea surface height gradient from x points' ) + iret = NF90_PUT_ATT( ntrajid, nsshxid , 'units' , 'm/m' ) + iret = NF90_PUT_ATT( ntrajid, nsshyid , 'long_name', 'sea surface height gradient from y points' ) + iret = NF90_PUT_ATT( ntrajid, nsshyid , 'units' , 'm/m' ) + iret = NF90_PUT_ATT( ntrajid, nsstid , 'long_name', 'sea surface temperature' ) + iret = NF90_PUT_ATT( ntrajid, nsstid , 'units' , 'degC') + iret = NF90_PUT_ATT( ntrajid, ncntid , 'long_name', 'sea ice concentration' ) + iret = NF90_PUT_ATT( ntrajid, ncntid , 'units' , 'degC') + iret = NF90_PUT_ATT( ntrajid, nthkid , 'long_name', 'sea ice thickness' ) + iret = NF90_PUT_ATT( ntrajid, nthkid , 'units' , 'm' ) + iret = NF90_PUT_ATT( ntrajid, nmassid , 'long_name', 'mass') + iret = NF90_PUT_ATT( ntrajid, nmassid , 'units' , 'kg' ) + iret = NF90_PUT_ATT( ntrajid, nthicknessid , 'long_name', 'thickness' ) + iret = NF90_PUT_ATT( ntrajid, nthicknessid , 'units' , 'm' ) + iret = NF90_PUT_ATT( ntrajid, nwidthid , 'long_name', 'width' ) + iret = NF90_PUT_ATT( ntrajid, nwidthid , 'units' , 'm' ) + iret = NF90_PUT_ATT( ntrajid, nlengthid , 'long_name', 'length' ) + iret = NF90_PUT_ATT( ntrajid, nlengthid , 'units' , 'm' ) + iret = NF90_PUT_ATT( ntrajid, nyearid , 'long_name', 'calendar year' ) + iret = NF90_PUT_ATT( ntrajid, nyearid , 'units' , 'years' ) + iret = NF90_PUT_ATT( ntrajid, ndayid , 'long_name', 'day of year' ) + iret = NF90_PUT_ATT( ntrajid, ndayid , 'units' , 'days' ) + iret = NF90_PUT_ATT( ntrajid, nscaling_id , 'long_name', 'scaling factor for mass of berg' ) + iret = NF90_PUT_ATT( ntrajid, nscaling_id , 'units' , 'none' ) + iret = NF90_PUT_ATT( ntrajid, nmass_of_bits_id, 'long_name', 'mass of bergy bits' ) + iret = NF90_PUT_ATT( ntrajid, nmass_of_bits_id, 'units' , 'kg' ) + iret = NF90_PUT_ATT( ntrajid, nheat_density_id, 'long_name', 'heat density' ) + iret = NF90_PUT_ATT( ntrajid, nheat_density_id, 'units' , 'J/kg' ) + ! + ! End define mode + iret = NF90_ENDDEF( ntrajid ) + ! + END SUBROUTINE icb_trj_init + + + SUBROUTINE icb_trj_write( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_trj_write *** + !! + !! ** Purpose : write out iceberg trajectories + !! + !! ** Method : - for the moment write out each snapshot of positions later + !! can rewrite so that it is buffered and written out more efficiently + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! time-step index + ! + INTEGER :: iret, jn + CHARACTER(len=80) :: cl_filename + TYPE(iceberg), POINTER :: this + TYPE(point ), POINTER :: pt + !!---------------------------------------------------------------------- + + ! Write variables + ! sga - just write out the current point of the trajectory + + this => first_berg + jn = num_traj + DO WHILE( ASSOCIATED(this) ) + pt => this%current_point + jn = jn + 1 + ! + iret = NF90_PUT_VAR( ntrajid, numberid , this%number , (/1,jn/) , (/nkounts,1/) ) + iret = NF90_PUT_VAR( ntrajid, nstepid , kt , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nscaling_id , this%mass_scaling, (/ jn /) ) + ! + iret = NF90_PUT_VAR( ntrajid, nlonid , pt%lon , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nlatid , pt%lat , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nxid , pt%xi , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nyid , pt%yj , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nuvelid , pt%uvel , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nvvelid , pt%vvel , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nssuid , pt%ssu , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nssvid , pt%ssv , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nuaid , pt%ua , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nvaid , pt%va , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nuiid , pt%ui , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nviid , pt%vi , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nsshxid , pt%ssh_x , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nsshyid , pt%ssh_y , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nsstid , pt%sst , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, ncntid , pt%cn , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nthkid , pt%hi , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nmassid , pt%mass , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nthicknessid , pt%thickness , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nwidthid , pt%width , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nlengthid , pt%length , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nyearid , pt%year , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, ndayid , pt%day , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nmass_of_bits_id, pt%mass_of_bits , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nheat_density_id, pt%heat_density , (/ jn /) ) + ! + this => this%next + END DO + IF( lwp .AND. nn_verbose_level > 0 ) WRITE(numout,*) 'trajectory write to frame ', jn + num_traj = jn + ! + END SUBROUTINE icb_trj_write + + + SUBROUTINE icb_trj_sync() + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_trj_sync *** + !! + !! ** Purpose : + !!---------------------------------------------------------------------- + INTEGER :: iret + !!---------------------------------------------------------------------- + ! flush to file + iret = NF90_SYNC( ntrajid ) + IF ( iret /= NF90_NOERR ) CALL ctl_stop( 'icebergs, icb_trj_sync: nf_sync failed' ) + ! + END SUBROUTINE icb_trj_sync + + + SUBROUTINE icb_trj_end() + !!---------------------------------------------------------------------- + INTEGER :: iret + !!---------------------------------------------------------------------- + ! Finish up + iret = NF90_CLOSE( ntrajid ) + IF ( iret /= NF90_NOERR ) CALL ctl_stop( 'icebergs, icb_trj_end: nf_close failed' ) + ! + END SUBROUTINE icb_trj_end + + !!====================================================================== +END MODULE icbtrj \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbutl.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbutl.F90 new file mode 100644 index 0000000..00a434b --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ICB/icbutl.F90 @@ -0,0 +1,983 @@ +MODULE icbutl + !!====================================================================== + !! *** MODULE icbutl *** + !! Icebergs: various iceberg utility routines + !!====================================================================== + !! History : 3.3.1 ! 2010-01 (Martin&Adcroft) Original code + !! - ! 2011-03 (Madec) Part conversion to NEMO form + !! - ! Removal of mapping from another grid + !! - ! 2011-04 (Alderson) Split into separate modules + !! 4.2 ! 2020-07 (P. Mathiot) simplification of interpolation routine + !! ! and add Nacho Merino work + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_utl_interp : + !! icb_utl_pos : compute bottom left corner indice, weight and mask + !! icb_utl_bilin_h : interpolation field to icb position + !! icb_utl_bilin_e : interpolation of scale factor to icb position + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE oce, ONLY: ts, uu, vv + USE dom_oce ! ocean domain + USE in_out_manager ! IO parameters + USE lbclnk ! lateral boundary condition + USE lib_mpp ! MPI code and lk_mpp in particular + USE icb_oce ! define iceberg arrays + USE sbc_oce ! ocean surface boundary conditions +#if defined key_si3 + USE ice, ONLY: u_ice, v_ice, hm_i ! SI3 variables + USE icevar ! ice_var_sshdyn + USE sbc_ice, ONLY: snwice_mass, snwice_mass_b +#endif + + IMPLICIT NONE + PRIVATE + + INTERFACE icb_utl_bilin_h + MODULE PROCEDURE icb_utl_bilin_2d_h, icb_utl_bilin_3d_h + END INTERFACE + + PUBLIC icb_utl_copy ! routine called in icbstp module + PUBLIC icb_utl_getkb ! routine called in icbdyn and icbthm modules + PUBLIC test_icb_utl_getkb ! routine called in icbdyn and icbthm modules + PUBLIC icb_utl_zavg ! routine called in icbdyn and icbthm modules + PUBLIC icb_utl_interp ! routine called in icbdyn, icbthm modules + PUBLIC icb_utl_bilin_h ! routine called in icbdyn module + PUBLIC icb_utl_add ! routine called in icbini.F90, icbclv, icblbc and icbrst modules + PUBLIC icb_utl_delete ! routine called in icblbc, icbthm modules + PUBLIC icb_utl_destroy ! routine called in icbstp module + PUBLIC icb_utl_track ! routine not currently used, retain just in case + PUBLIC icb_utl_print_berg ! routine called in icbthm module + PUBLIC icb_utl_print ! routine called in icbini, icbstp module + PUBLIC icb_utl_count ! routine called in icbdia, icbini, icblbc, icbrst modules + PUBLIC icb_utl_incr ! routine called in icbini, icbclv modules + PUBLIC icb_utl_yearday ! routine called in icbclv, icbstp module + PUBLIC icb_utl_mass ! routine called in icbdia module + PUBLIC icb_utl_heat ! routine called in icbdia module + + !! * Substitutions +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: icbutl.F90 15372 2021-10-14 15:47:24Z davestorkey $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_utl_copy( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_copy *** + !! + !! ** Purpose : iceberg initialization. + !! + !! ** Method : - blah blah + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(0:jpi+1,0:jpj+1) :: ztmp +#if defined key_si3 + REAL(wp), DIMENSION(jpi,jpj) :: zssh_lead_m ! ocean surface (ssh_m) if ice is not embedded + ! ! ocean surface in leads if ice is embedded +#endif + INTEGER :: jk ! vertical loop index + INTEGER :: Kmm ! ocean time levelindex + ! + ! copy nemo forcing arrays into iceberg versions with extra halo + ! only necessary for variables not on T points + ! and ssh which is used to calculate gradients + ! + ! surface forcing + ! + ssu_e(1:jpi,1:jpj) = ssu_m(:,:) * umask(:,:,1) + ssv_e(1:jpi,1:jpj) = ssv_m(:,:) * vmask(:,:,1) + sst_e(1:jpi,1:jpj) = sst_m(:,:) + sss_e(1:jpi,1:jpj) = sss_m(:,:) + fr_e (1:jpi,1:jpj) = fr_i (:,:) + ua_e (1:jpi,1:jpj) = utau_icb (:,:) * umask(:,:,1) ! maybe mask useless because mask applied in sbcblk + va_e (1:jpi,1:jpj) = vtau_icb (:,:) * vmask(:,:,1) ! maybe mask useless because mask applied in sbcblk + ff_e(1:jpi,1:jpj) = ff_f (:,:) + ! + CALL lbc_lnk_icb( 'icbutl', ssu_e, 'U', -1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', ssv_e, 'V', -1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', ua_e , 'U', -1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', va_e , 'V', -1._wp, 1, 1 ) +#if defined key_si3 + hi_e(1:jpi, 1:jpj) = hm_i (:,:) + ui_e(1:jpi, 1:jpj) = u_ice(:,:) + vi_e(1:jpi, 1:jpj) = v_ice(:,:) + ! + ! compute ssh slope using ssh_lead if embedded + zssh_lead_m(:,:) = ice_var_sshdyn(ssh_m, snwice_mass, snwice_mass_b) + ssh_e(1:jpi, 1:jpj) = zssh_lead_m(:,:) * tmask(:,:,1) + ! + CALL lbc_lnk_icb( 'icbutl', ui_e , 'U', -1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', vi_e , 'V', -1._wp, 1, 1 ) +#else + ssh_e(1:jpi, 1:jpj) = ssh_m(:,:) * tmask(:,:,1) +#endif + ! + ! (PM) could be improve with a 3d lbclnk gathering both variables + ! should be done once extra haloe generalised + IF ( ln_M2016 ) THEN + DO jk = 1,jpk + ! uoce + ztmp(1:jpi,1:jpj) = uu(:,:,jk,Kmm) + CALL lbc_lnk_icb( 'icbutl', ztmp, 'U', -1._wp, 1, 1 ) + uoce_e(:,:,jk) = ztmp(:,:) + ! + ! voce + ztmp(1:jpi,1:jpj) = vv(:,:,jk,Kmm) + CALL lbc_lnk_icb( 'icbutl', ztmp, 'V', -1._wp, 1, 1 ) + voce_e(:,:,jk) = ztmp(:,:) + ! + e3t_e(1:jpi,1:jpj,jk) = e3t(:,:,jk,Kmm) + END DO + toce_e(1:jpi,1:jpj,:) = ts(:,:,:,1,Kmm) + END IF + ! + END SUBROUTINE icb_utl_copy + + + SUBROUTINE icb_utl_interp( pi, pj, pe1 , pssu, pui, pua, pssh_i, & + & pe2 , pssv, pvi, pva, pssh_j, & + & psst, psss, pcn, phi, pff , & + & plon, plat, ptoce, puoce, pvoce, pe3t ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_interp *** + !! + !! ** Purpose : interpolation + !! + !! ** Method : - interpolate from various ocean arrays onto iceberg position + !! + !! !!gm CAUTION here I do not care of the slip/no-slip conditions + !! this can be done later (not that easy to do...) + !! right now, U is 0 in land so that the coastal value of velocity parallel to the coast + !! is half the off shore value, wile the normal-to-the-coast value is zero. + !! This is OK as a starting point. + !! !!pm HARD CODED: - rho_air now computed in sbcblk (what are the effect ?) + !! - drag coefficient (should it be namelist parameter ?) + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: pi , pj ! position in (i,j) referential + REAL(wp), INTENT( out), OPTIONAL :: pe1, pe2 ! i- and j scale factors + REAL(wp), INTENT( out), OPTIONAL :: pssu, pssv, pui, pvi, pua, pva ! ocean, ice and wind speeds + REAL(wp), INTENT( out), OPTIONAL :: pssh_i, pssh_j ! ssh i- & j-gradients + REAL(wp), INTENT( out), OPTIONAL :: psst, psss, pcn, phi, pff ! SST, SSS, ice concentration, ice thickness, Coriolis + REAL(wp), INTENT( out), OPTIONAL :: plat, plon ! position + REAL(wp), DIMENSION(jpk), INTENT( out), OPTIONAL :: ptoce, puoce, pvoce, pe3t ! 3D variables + ! + REAL(wp), DIMENSION(4) :: zwT , zwU , zwV , zwF ! interpolation weight + REAL(wp), DIMENSION(4) :: zmskF, zmskU, zmskV, zmskT ! mask + REAL(wp), DIMENSION(4) :: zwTp, zmskTp, zwTm, zmskTm + REAL(wp), DIMENSION(4,jpk) :: zw1d + INTEGER :: iiT, iiU, iiV, iiF, ijT, ijU, ijV, ijF ! bottom left corner + INTEGER :: iiTp, iiTm, ijTp, ijTm + REAL(wp) :: zcd, zmod ! local scalars + !!---------------------------------------------------------------------- + ! + ! get position, weight and mask + CALL icb_utl_pos( pi, pj, 'T', iiT, ijT, zwT, zmskT ) + CALL icb_utl_pos( pi, pj, 'U', iiU, ijU, zwU, zmskU ) + CALL icb_utl_pos( pi, pj, 'V', iiV, ijV, zwV, zmskV ) + CALL icb_utl_pos( pi, pj, 'F', iiF, ijF, zwF, zmskF ) + ! + ! metrics and coordinates + IF ( PRESENT(pe1 ) ) pe1 = icb_utl_bilin_e( e1t, CASTSP(e1u), e1v, e1f, pi, pj ) ! scale factors + IF ( PRESENT(pe2 ) ) pe2 = icb_utl_bilin_e( e2t, e2u, CASTSP(e2v), e2f, pi, pj ) + IF ( PRESENT(plon) ) plon= icb_utl_bilin_h( rlon_e, iiT, ijT, zwT, .true. ) + IF ( PRESENT(plat) ) plat= icb_utl_bilin_h( rlat_e, iiT, ijT, zwT, .false. ) + ! + IF ( PRESENT(pssu) ) pssu = icb_utl_bilin_h( ssu_e, iiU, ijU, zwU , .false. ) ! ocean velocities + IF ( PRESENT(pssv) ) pssv = icb_utl_bilin_h( ssv_e, iiV, ijV, zwV , .false. ) ! + IF ( PRESENT(psst) ) psst = icb_utl_bilin_h( sst_e, iiT, ijT, zwT * zmskT, .false. ) ! sst + IF ( PRESENT(psss) ) psss = icb_utl_bilin_h( sss_e, iiT, ijT, zwT * zmskT, .false. ) ! sss + IF ( PRESENT(pcn ) ) pcn = icb_utl_bilin_h( fr_e , iiT, ijT, zwT * zmskT, .false. ) ! ice concentration + IF ( PRESENT(pff ) ) pff = icb_utl_bilin_h( ff_e , iiF, ijF, zwF , .false. ) ! Coriolis parameter + ! + IF ( PRESENT(pua) .AND. PRESENT(pva) ) THEN + pua = icb_utl_bilin_h( ua_e, iiU, ijU, zwU * zmskU, .false. ) ! 10m wind + pva = icb_utl_bilin_h( va_e, iiV, ijV, zwV * zmskV, .false. ) ! here (ua,va) are stress => rough conversion from stress to speed + zcd = 1.22_wp * 1.5e-3_wp ! air density * drag coefficient + zmod = 1._wp / MAX( 1.e-20, SQRT( zcd * SQRT( pua*pua + pva*pva) ) ) + pua = pua * zmod ! note: stress module=0 necessarly implies ua=va=0 + pva = pva * zmod + END IF + ! +#if defined key_si3 + IF ( PRESENT(pui) ) pui = icb_utl_bilin_h( ui_e , iiU, ijU, zwU , .false. ) ! sea-ice velocities + IF ( PRESENT(pvi) ) pvi = icb_utl_bilin_h( vi_e , iiV, ijV, zwV , .false. ) + IF ( PRESENT(phi) ) phi = icb_utl_bilin_h( hi_e , iiT, ijT, zwT * zmskT, .false. ) ! ice thickness +#else + IF ( PRESENT(pui) ) pui = 0._wp + IF ( PRESENT(pvi) ) pvi = 0._wp + IF ( PRESENT(phi) ) phi = 0._wp +#endif + ! + ! Estimate SSH gradient in i- and j-direction (centred evaluation) + IF ( PRESENT(pssh_i) .AND. PRESENT(pssh_j) ) THEN + CALL icb_utl_pos( pi+0.1_wp, pj , 'T', iiTp, ijTp, zwTp, zmskTp ) + CALL icb_utl_pos( pi-0.1_wp, pj , 'T', iiTm, ijTm, zwTm, zmskTm ) + ! + IF ( .NOT. PRESENT(pe1) ) pe1 = icb_utl_bilin_e( e1t, CASTSP(e1u), e1v, e1f, pi, pj ) + pssh_i = ( icb_utl_bilin_h( ssh_e, iiTp, ijTp, zwTp*zmskTp, .false. ) - & + & icb_utl_bilin_h( ssh_e, iiTm, ijTm, zwTm*zmskTm, .false. ) ) / ( 0.2_wp * pe1 ) + ! + CALL icb_utl_pos( pi , pj+0.1_wp, 'T', iiTp, ijTp, zwTp, zmskTp ) + CALL icb_utl_pos( pi , pj-0.1_wp, 'T', iiTm, ijTm, zwTm, zmskTm ) + ! + IF ( .NOT. PRESENT(pe2) ) pe2 = icb_utl_bilin_e( e2t, e2u, CASTSP(e2v), e2f, pi, pj ) + pssh_j = ( icb_utl_bilin_h( ssh_e, iiTp, ijTp, zwTp*zmskTp, .false. ) - & + & icb_utl_bilin_h( ssh_e, iiTm, ijTm, zwTm*zmskTm, .false. ) ) / ( 0.2_wp * pe2 ) + END IF + ! + ! 3d interpolation + IF ( PRESENT(puoce) .AND. PRESENT(pvoce) ) THEN + ! no need to mask as 0 is a valid data for land + zw1d(1,:) = zwU(1) ; zw1d(2,:) = zwU(2) ; zw1d(3,:) = zwU(3) ; zw1d(4,:) = zwU(4) ; + puoce(:) = icb_utl_bilin_h( uoce_e , iiU, ijU, zw1d ) + + zw1d(1,:) = zwV(1) ; zw1d(2,:) = zwV(2) ; zw1d(3,:) = zwV(3) ; zw1d(4,:) = zwV(4) ; + pvoce(:) = icb_utl_bilin_h( voce_e , iiV, ijV, zw1d ) + END IF + + IF ( PRESENT(ptoce) ) THEN + ! for temperature we need to mask the weight properly + ! no need of extra halo as it is a T point variable + zw1d(1,:) = tmask(iiT ,ijT ,:) * zwT(1) * zmskT(1) + zw1d(2,:) = tmask(iiT+1,ijT ,:) * zwT(2) * zmskT(2) + zw1d(3,:) = tmask(iiT ,ijT+1,:) * zwT(3) * zmskT(3) + zw1d(4,:) = tmask(iiT+1,ijT+1,:) * zwT(4) * zmskT(4) + ptoce(:) = icb_utl_bilin_h( toce_e , iiT, ijT, zw1d ) + END IF + ! + IF ( PRESENT(pe3t) ) pe3t(:) = e3t_e(iiT,ijT,:) ! as in Nacho tarball need to be fix once we are able to reproduce Nacho results + ! + END SUBROUTINE icb_utl_interp + + SUBROUTINE icb_utl_pos( pi, pj, cd_type, kii, kij, pw, pmsk ) + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_bilin *** + !! + !! ** Purpose : bilinear interpolation at berg location depending on the grid-point type + !! this version deals with extra halo points + !! + !! !!gm CAUTION an optional argument should be added to handle + !! the slip/no-slip conditions ==>>> to be done later + !! + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(IN) :: pi, pj ! targeted coordinates in (i,j) referential + CHARACTER(len=1) , INTENT(IN) :: cd_type ! point type + REAL(wp), DIMENSION(4), INTENT(OUT) :: pw, pmsk ! weight and mask + INTEGER , INTENT(OUT) :: kii, kij ! bottom left corner position in local domain + ! + REAL(wp) :: zwi, zwj ! distance to bottom left corner + INTEGER :: ierr + ! + !!---------------------------------------------------------------------- + ! + SELECT CASE ( cd_type ) + CASE ( 'T' ) + ! note that here there is no +0.5 added + ! since we're looking for four T points containing quadrant we're in of + ! current T cell + kii = MAX(0, INT( pi )) + kij = MAX(0, INT( pj )) ! T-point + zwi = pi - REAL(kii,wp) + zwj = pj - REAL(kij,wp) + CASE ( 'U' ) + kii = MAX(0, INT( pi-0.5_wp )) + kij = MAX(0, INT( pj )) ! U-point + zwi = pi - 0.5_wp - REAL(kii,wp) + zwj = pj - REAL(kij,wp) + CASE ( 'V' ) + kii = MAX(0, INT( pi )) + kij = MAX(0, INT( pj-0.5_wp )) ! V-point + zwi = pi - REAL(kii,wp) + zwj = pj - 0.5_wp - REAL(kij,wp) + CASE ( 'F' ) + kii = MAX(0, INT( pi-0.5_wp )) + kij = MAX(0, INT( pj-0.5_wp )) ! F-point + zwi = pi - 0.5_wp - REAL(kii,wp) + zwj = pj - 0.5_wp - REAL(kij,wp) + END SELECT + kii = kii + (nn_hls-1) + kij = kij + (nn_hls-1) + ! + ! compute weight + pw(1) = (1._wp-zwi) * (1._wp-zwj) + pw(2) = zwi * (1._wp-zwj) + pw(3) = (1._wp-zwi) * zwj + pw(4) = zwi * zwj + ! + ! find position in this processor. Prevent near edge problems (see #1389) + ! + IF (TRIM(cd_type) == 'T' ) THEN + ierr = 0 + IF ( kii < mig( 1 ) ) THEN ; ierr = ierr + 1 + ELSEIF( kii >= mig(jpi) ) THEN ; ierr = ierr + 1 + ENDIF + ! + IF ( kij < mjg( 1 ) ) THEN ; ierr = ierr + 1 + ELSEIF( kij >= mjg(jpj) ) THEN ; ierr = ierr + 1 + ENDIF + ! + IF ( ierr > 0 ) THEN + WRITE(numicb,*) 'bottom left corner T point out of bound' + WRITE(numicb,*) pi, kii, mig( 1 ), mig(jpi) + WRITE(numicb,*) pj, kij, mjg( 1 ), mjg(jpj) + WRITE(numicb,*) pmsk + CALL FLUSH(numicb) + CALL ctl_stop('STOP','icb_utl_bilin_e: an icebergs coordinates is out of valid range (out of bound error).' , & + & 'This can be fixed using rn_speed_limit=0.4 in &namberg.' , & + & 'More details in the corresponding iceberg.stat file (nn_verbose_level > 0).' ) + END IF + END IF + ! + ! find position in this processor. Prevent near edge problems (see #1389) + ! (PM) will be useless if extra halo is used in NEMO + ! + IF ( kii <= mig(1)-1 ) THEN ; kii = 0 + ELSEIF( kii > mig(jpi) ) THEN ; kii = jpi + ELSE ; kii = mi1(kii) + ENDIF + IF ( kij <= mjg(1)-1 ) THEN ; kij = 0 + ELSEIF( kij > mjg(jpj) ) THEN ; kij = jpj + ELSE ; kij = mj1(kij) + ENDIF + ! + ! define mask array + ! land value is not used in the interpolation + SELECT CASE ( cd_type ) + CASE ( 'T' ) + pmsk = (/tmask_e(kii,kij), tmask_e(kii+1,kij), tmask_e(kii,kij+1), tmask_e(kii+1,kij+1)/) + CASE ( 'U' ) + pmsk = (/umask_e(kii,kij), umask_e(kii+1,kij), umask_e(kii,kij+1), umask_e(kii+1,kij+1)/) + CASE ( 'V' ) + pmsk = (/vmask_e(kii,kij), vmask_e(kii+1,kij), vmask_e(kii,kij+1), vmask_e(kii+1,kij+1)/) + CASE ( 'F' ) + ! F case only used for coriolis, ff_f is not mask so zmask = 1 + pmsk = 1. + END SELECT + END SUBROUTINE icb_utl_pos + + REAL(wp) FUNCTION icb_utl_bilin_2d_h( pfld, pii, pij, pw, pllon ) + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_bilin *** + !! + !! ** Purpose : bilinear interpolation at berg location depending on the grid-point type + !! this version deals with extra halo points + !! + !! !!gm CAUTION an optional argument should be added to handle + !! the slip/no-slip conditions ==>>> to be done later + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(0:jpi+1,0:jpj+1), INTENT(in) :: pfld ! field to be interpolated + REAL(wp), DIMENSION(4) , INTENT(in) :: pw ! weight + LOGICAL , INTENT(in) :: pllon ! input data is a longitude + INTEGER , INTENT(in) :: pii, pij ! bottom left corner + ! + REAL(wp), DIMENSION(4) :: zdat ! input data + !!---------------------------------------------------------------------- + ! + ! data + zdat(1) = pfld(pii ,pij ) + zdat(2) = pfld(pii+1,pij ) + zdat(3) = pfld(pii ,pij+1) + zdat(4) = pfld(pii+1,pij+1) + ! + IF( pllon .AND. MAXVAL(zdat) - MINVAL(zdat) > 90._wp ) THEN + WHERE( zdat < 0._wp ) zdat = zdat + 360._wp + ENDIF + ! + ! compute interpolated value + icb_utl_bilin_2d_h = ( zdat(1)*pw(1) + zdat(2)*pw(2) + zdat(3)*pw(3) + zdat(4)*pw(4) ) / MAX(1.e-20, pw(1)+pw(2)+pw(3)+pw(4)) + ! + IF( pllon .AND. icb_utl_bilin_2d_h > 180._wp ) icb_utl_bilin_2d_h = icb_utl_bilin_2d_h - 360._wp + ! + END FUNCTION icb_utl_bilin_2d_h + + FUNCTION icb_utl_bilin_3d_h( pfld, pii, pij, pw ) + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_bilin *** + !! + !! ** Purpose : bilinear interpolation at berg location depending on the grid-point type + !! this version deals with extra halo points + !! + !! !!gm CAUTION an optional argument should be added to handle + !! the slip/no-slip conditions ==>>> to be done later + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(0:jpi+1,0:jpj+1, jpk), INTENT(in) :: pfld ! field to be interpolated + REAL(wp), DIMENSION(4,jpk) , INTENT(in) :: pw ! weight + INTEGER , INTENT(in) :: pii, pij ! bottom left corner + REAL(wp), DIMENSION(jpk) :: icb_utl_bilin_3d_h + ! + REAL(wp), DIMENSION(4,jpk) :: zdat ! input data + INTEGER :: jk + !!---------------------------------------------------------------------- + ! + ! data + zdat(1,:) = pfld(pii ,pij ,:) + zdat(2,:) = pfld(pii+1,pij ,:) + zdat(3,:) = pfld(pii ,pij+1,:) + zdat(4,:) = pfld(pii+1,pij+1,:) + ! + ! compute interpolated value + DO jk=1,jpk + icb_utl_bilin_3d_h(jk) = ( zdat(1,jk)*pw(1,jk) + zdat(2,jk)*pw(2,jk) + zdat(3,jk)*pw(3,jk) + zdat(4,jk)*pw(4,jk) ) & + & / MAX(1.e-20, pw(1,jk)+pw(2,jk)+pw(3,jk)+pw(4,jk)) + END DO + ! + END FUNCTION icb_utl_bilin_3d_h + + REAL(wp) FUNCTION icb_utl_bilin_e( pet, peu, pev, pef, pi, pj ) + !!---------------------------------------------------------------------- + !! *** FUNCTION dom_init *** + !! + !! ** Purpose : bilinear interpolation at berg location of horizontal scale factor + !! ** Method : interpolation done using the 4 nearest grid points among + !! t-, u-, v-, and f-points. + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), INTENT(in) :: peu, pev! horizontal scale factor to be interpolated at t-,u-,v- & f-pts + REAL(dp), DIMENSION(:,:), INTENT(in) :: pet, pef! horizontal scale factor to be interpolated at t-,u-,v- & f-pts + REAL(wp) , INTENT(IN) :: pi , pj ! iceberg position + ! + ! weights corresponding to corner points of a T cell quadrant + REAL(wp) :: zi, zj ! local real + INTEGER :: ii, ij ! bottom left corner coordinate in local domain + ! + ! values at corner points of a T cell quadrant + ! 00 = bottom left, 10 = bottom right, 01 = top left, 11 = top right + REAL(wp) :: ze00, ze10, ze01, ze11 + !!---------------------------------------------------------------------- + ! + ! cannot used iiT because need ii/ij reltaive to global indices not local one + ii = MAX(1, INT( pi )) ; ij = MAX(1, INT( pj )) ! left bottom T-point (i,j) indices + ! + ! fractional box spacing + ! 0 <= zi < 0.5, 0 <= zj < 0.5 --> NW quadrant of current T cell + ! 0.5 <= zi < 1 , 0 <= zj < 0.5 --> NE quadrant + ! 0 <= zi < 0.5, 0.5 <= zj < 1 --> SE quadrant + ! 0.5 <= zi < 1 , 0.5 <= zj < 1 --> SW quadrant + + zi = pi - REAL(ii,wp) !!gm use here mig, mjg arrays + zj = pj - REAL(ij,wp) + + ! conversion to local domain (no need to do a sanity check already done in icbpos) + ii = mi1(ii) + (nn_hls-1) + ij = mj1(ij) + (nn_hls-1) + ! + IF( 0.0_wp <= zi .AND. zi < 0.5_wp ) THEN + IF( 0.0_wp <= zj .AND. zj < 0.5_wp ) THEN ! NE quadrant + ! ! i=I i=I+1/2 + ze01 = pev(ii ,ij ) ; ze11 = pef(ii ,ij ) ! j=J+1/2 V ------- F + ze00 = pet(ii ,ij ) ; ze10 = peu(ii ,ij ) ! j=J T ------- U + zi = 2._wp * zi + zj = 2._wp * zj + ELSE ! SE quadrant + ! ! i=I i=I+1/2 + ze01 = pet(ii ,ij+1) ; ze11 = peu(ii ,ij+1) ! j=J+1 T ------- U + ze00 = pev(ii ,ij ) ; ze10 = pef(ii ,ij ) ! j=J+1/2 V ------- F + zi = 2._wp * zi + zj = 2._wp * (zj-0.5_wp) + ENDIF + ELSE + IF( 0.0_wp <= zj .AND. zj < 0.5_wp ) THEN ! NW quadrant + ! ! i=I i=I+1/2 + ze01 = pef(ii ,ij ) ; ze11 = pev(ii+1,ij) ! j=J+1/2 F ------- V + ze00 = peu(ii ,ij ) ; ze10 = pet(ii+1,ij) ! j=J U ------- T + zi = 2._wp * (zi-0.5_wp) + zj = 2._wp * zj + ELSE ! SW quadrant + ! ! i=I+1/2 i=I+1 + ze01 = peu(ii ,ij+1) ; ze11 = pet(ii+1,ij+1) ! j=J+1 U ------- T + ze00 = pef(ii ,ij ) ; ze10 = pev(ii+1,ij ) ! j=J+1/2 F ------- V + zi = 2._wp * (zi-0.5_wp) + zj = 2._wp * (zj-0.5_wp) + ENDIF + ENDIF + ! + icb_utl_bilin_e = ( ze01 * (1._wp-zi) + ze11 * zi ) * zj & + & + ( ze00 * (1._wp-zi) + ze10 * zi ) * (1._wp-zj) + ! + END FUNCTION icb_utl_bilin_e + + SUBROUTINE icb_utl_getkb( kb, pe3, pD ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_getkb *** + !! + !! ** Purpose : compute the latest level affected by icb + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(out):: kb + REAL(wp), DIMENSION(:), INTENT(in) :: pe3 + REAL(wp), INTENT(in) :: pD + !! + INTEGER :: jk + REAL(wp) :: zdepw + !!---------------------------------------------------------------------- + !! + zdepw = pe3(1) ; kb = 2 + DO WHILE ( zdepw < pD) + zdepw = zdepw + pe3(kb) + kb = kb + 1 + END DO + kb = MIN(kb - 1,jpk) + END SUBROUTINE icb_utl_getkb + + SUBROUTINE icb_utl_zavg(pzavg, pdat, pe3, pD, kb ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_getkb *** + !! + !! ** Purpose : compute the vertical average of ocean properties affected by icb + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kb ! deepest level affected by icb + REAL(wp), DIMENSION(:), INTENT(in ) :: pe3, pdat ! vertical profile + REAL(wp), INTENT(in ) :: pD ! draft + REAL(wp), INTENT(out) :: pzavg ! z average + !!---------------------------------------------------------------------- + INTEGER :: jk + REAL(wp) :: zdep + !!---------------------------------------------------------------------- + pzavg = 0.0 ; zdep = 0.0 + DO jk = 1,kb-1 + pzavg = pzavg + pe3(jk)*pdat(jk) + zdep = zdep + pe3(jk) + END DO + ! if kb is limited by mbkt => bottom value is used between bathy and icb tail + ! if kb not limited by mbkt => ocean value over mask is used (ie 0.0 for u, v) + pzavg = ( pzavg + (pD - zdep)*pdat(kb)) / pD + END SUBROUTINE icb_utl_zavg + + SUBROUTINE icb_utl_add( bergvals, ptvals ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_add *** + !! + !! ** Purpose : add a new berg to the iceberg list + !! + !!---------------------------------------------------------------------- + TYPE(iceberg), INTENT(in) :: bergvals + TYPE(point) , INTENT(in) :: ptvals + ! + TYPE(iceberg), POINTER :: new => NULL() + !!---------------------------------------------------------------------- + ! + new => NULL() + CALL icb_utl_create( new, bergvals, ptvals ) + CALL icb_utl_insert( new ) + new => NULL() ! Clear new + ! + END SUBROUTINE icb_utl_add + + + SUBROUTINE icb_utl_create( berg, bergvals, ptvals ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_create *** + !! + !! ** Purpose : add a new berg to the iceberg list + !! + !!---------------------------------------------------------------------- + TYPE(iceberg), INTENT(in) :: bergvals + TYPE(point) , INTENT(in) :: ptvals + TYPE(iceberg), POINTER :: berg + ! + TYPE(point) , POINTER :: pt + INTEGER :: istat + !!---------------------------------------------------------------------- + ! + IF( ASSOCIATED(berg) ) CALL ctl_stop( 'icebergs, icb_utl_create: berg already associated' ) + ALLOCATE(berg, STAT=istat) + IF( istat /= 0 ) CALL ctl_stop( 'failed to allocate iceberg' ) + berg%number(:) = bergvals%number(:) + berg%mass_scaling = bergvals%mass_scaling + berg%prev => NULL() + berg%next => NULL() + ! + ALLOCATE(pt, STAT=istat) + IF( istat /= 0 ) CALL ctl_stop( 'failed to allocate first iceberg point' ) + pt = ptvals + berg%current_point => pt + ! + END SUBROUTINE icb_utl_create + + + SUBROUTINE icb_utl_insert( newberg ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_insert *** + !! + !! ** Purpose : add a new berg to the iceberg list + !! + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: newberg + ! + TYPE(iceberg), POINTER :: this, prev, last + !!---------------------------------------------------------------------- + ! + IF( ASSOCIATED( first_berg ) ) THEN + last => first_berg + DO WHILE (ASSOCIATED(last%next)) + last => last%next + ENDDO + newberg%prev => last + last%next => newberg + last => newberg + ELSE ! list is empty so create it + first_berg => newberg + ENDIF + ! + END SUBROUTINE icb_utl_insert + + + REAL(wp) FUNCTION icb_utl_yearday(kmon, kday, khr, kmin, ksec) + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_yearday *** + !! + !! ** Purpose : + !! + ! sga - improved but still only applies to 365 day year, need to do this properly + ! + !!gm all these info are already known in daymod, no??? + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kmon, kday, khr, kmin, ksec + ! + INTEGER, DIMENSION(12) :: imonths = (/ 0,31,28,31,30,31,30,31,31,30,31,30 /) + !!---------------------------------------------------------------------- + ! + icb_utl_yearday = REAL( SUM( imonths(1:kmon) ), wp ) + icb_utl_yearday = icb_utl_yearday + REAL(kday-1,wp) + (REAL(khr,wp) + (REAL(kmin,wp) + REAL(ksec,wp)/60.)/60.)/24. + ! + END FUNCTION icb_utl_yearday + + !!------------------------------------------------------------------------- + + SUBROUTINE icb_utl_delete( first, berg ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_delete *** + !! + !! ** Purpose : + !! + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: first, berg + !!---------------------------------------------------------------------- + ! Connect neighbors to each other + IF ( ASSOCIATED(berg%prev) ) THEN + berg%prev%next => berg%next + ELSE + first => berg%next + ENDIF + IF (ASSOCIATED(berg%next)) berg%next%prev => berg%prev + ! + CALL icb_utl_destroy(berg) + ! + END SUBROUTINE icb_utl_delete + + + SUBROUTINE icb_utl_destroy( berg ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_destroy *** + !! + !! ** Purpose : remove a single iceberg instance + !! + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: berg + !!---------------------------------------------------------------------- + ! + ! Remove any points + IF( ASSOCIATED( berg%current_point ) ) DEALLOCATE( berg%current_point ) + ! + DEALLOCATE(berg) + ! + END SUBROUTINE icb_utl_destroy + + + SUBROUTINE icb_utl_track( knum, cd_label, kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_track *** + !! + !! ** Purpose : + !! + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(nkounts) :: knum ! iceberg number + CHARACTER(len=*) :: cd_label ! + INTEGER :: kt ! timestep number + ! + TYPE(iceberg), POINTER :: this + LOGICAL :: match + INTEGER :: k + !!---------------------------------------------------------------------- + ! + this => first_berg + DO WHILE( ASSOCIATED(this) ) + match = .TRUE. + DO k = 1, nkounts + IF( this%number(k) /= knum(k) ) match = .FALSE. + END DO + IF( match ) CALL icb_utl_print_berg(this, kt) + this => this%next + END DO + ! + END SUBROUTINE icb_utl_track + + + SUBROUTINE icb_utl_print_berg( berg, kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_print_berg *** + !! + !! ** Purpose : print one + !! + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: berg + TYPE(point) , POINTER :: pt + INTEGER :: kt ! timestep number + !!---------------------------------------------------------------------- + ! + IF (nn_verbose_level == 0) RETURN + pt => berg%current_point + WRITE(numicb, 9200) kt, berg%number(1), & + pt%xi, pt%yj, pt%lon, pt%lat, pt%uvel, pt%vvel, & + pt%ssu, pt%ssv, pt%ua, pt%va, pt%ui, pt%vi + CALL flush( numicb ) + 9200 FORMAT(5x,i5,2x,i10,6(2x,2f10.4)) + ! + END SUBROUTINE icb_utl_print_berg + + + SUBROUTINE icb_utl_print( cd_label, kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_print *** + !! + !! ** Purpose : print many + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*) :: cd_label + INTEGER, INTENT(IN) :: kt ! timestep number + ! + INTEGER :: ibergs, inbergs + TYPE(iceberg), POINTER :: this + !!---------------------------------------------------------------------- + ! + IF (nn_verbose_level == 0) RETURN + this => first_berg + IF( ASSOCIATED(this) ) THEN + WRITE(numicb,'(a," pe=(",i3,")")' ) cd_label, narea + WRITE(numicb,'(a8,4x,a6,12x,a5,15x,a7,19x,a3,17x,a5,17x,a5,17x,a5)' ) & + & 'timestep', 'number', 'xi,yj','lon,lat','u,v','ssu,ssv','ua,va','ui,vi' + ENDIF + DO WHILE( ASSOCIATED(this) ) + CALL icb_utl_print_berg(this, kt) + this => this%next + END DO + ibergs = icb_utl_count() + inbergs = ibergs + CALL mpp_sum('icbutl', inbergs) + IF( ibergs > 0 ) WRITE(numicb,'(a," there are",i5," bergs out of",i6," on PE ",i4)') & + & cd_label, ibergs, inbergs, narea + ! + END SUBROUTINE icb_utl_print + + + SUBROUTINE icb_utl_incr() + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_incr *** + !! + !! ** Purpose : + !! + ! Small routine for coping with very large integer values labelling icebergs + ! num_bergs is a array of integers + ! the first member is incremented in steps of jpnij starting from narea + ! this means each iceberg is labelled with a unique number + ! when this gets to the maximum allowed integer the second and subsequent members are + ! used to count how many times the member before cycles + !!---------------------------------------------------------------------- + INTEGER :: ii, ibig + !!---------------------------------------------------------------------- + + ibig = HUGE(num_bergs(1)) + IF( ibig-jpnij < num_bergs(1) ) THEN + num_bergs(1) = narea + DO ii = 2,nkounts + IF( num_bergs(ii) == ibig ) THEN + num_bergs(ii) = 0 + IF( ii == nkounts ) CALL ctl_stop('Sorry, run out of iceberg number space') + ELSE + num_bergs(ii) = num_bergs(ii) + 1 + EXIT + ENDIF + END DO + ELSE + num_bergs(1) = num_bergs(1) + jpnij + ENDIF + ! + END SUBROUTINE icb_utl_incr + + + INTEGER FUNCTION icb_utl_count() + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_count *** + !! + !! ** Purpose : + !!---------------------------------------------------------------------- + TYPE(iceberg), POINTER :: this + !!---------------------------------------------------------------------- + ! + icb_utl_count = 0 + this => first_berg + DO WHILE( ASSOCIATED(this) ) + icb_utl_count = icb_utl_count+1 + this => this%next + END DO + ! + END FUNCTION icb_utl_count + + + REAL(wp) FUNCTION icb_utl_mass( first, justbits, justbergs ) + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_mass *** + !! + !! ** Purpose : compute the mass all iceberg, all berg bits or all bergs. + !!---------------------------------------------------------------------- + TYPE(iceberg) , POINTER :: first + TYPE(point) , POINTER :: pt + LOGICAL, INTENT(in), OPTIONAL :: justbits, justbergs + ! + TYPE(iceberg), POINTER :: this + !!---------------------------------------------------------------------- + icb_utl_mass = 0._wp + this => first + ! + IF( PRESENT( justbergs ) ) THEN + DO WHILE( ASSOCIATED( this ) ) + pt => this%current_point + icb_utl_mass = icb_utl_mass + pt%mass * this%mass_scaling + this => this%next + END DO + ELSEIF( PRESENT(justbits) ) THEN + DO WHILE( ASSOCIATED( this ) ) + pt => this%current_point + icb_utl_mass = icb_utl_mass + pt%mass_of_bits * this%mass_scaling + this => this%next + END DO + ELSE + DO WHILE( ASSOCIATED( this ) ) + pt => this%current_point + icb_utl_mass = icb_utl_mass + ( pt%mass + pt%mass_of_bits ) * this%mass_scaling + this => this%next + END DO + ENDIF + ! + END FUNCTION icb_utl_mass + + + REAL(wp) FUNCTION icb_utl_heat( first, justbits, justbergs ) + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_heat *** + !! + !! ** Purpose : compute the heat in all iceberg, all bergies or all bergs. + !!---------------------------------------------------------------------- + TYPE(iceberg) , POINTER :: first + LOGICAL, INTENT(in), OPTIONAL :: justbits, justbergs + ! + TYPE(iceberg) , POINTER :: this + TYPE(point) , POINTER :: pt + !!---------------------------------------------------------------------- + icb_utl_heat = 0._wp + this => first + ! + IF( PRESENT( justbergs ) ) THEN + DO WHILE( ASSOCIATED( this ) ) + pt => this%current_point + icb_utl_heat = icb_utl_heat + pt%mass * this%mass_scaling * pt%heat_density + this => this%next + END DO + ELSEIF( PRESENT(justbits) ) THEN + DO WHILE( ASSOCIATED( this ) ) + pt => this%current_point + icb_utl_heat = icb_utl_heat + pt%mass_of_bits * this%mass_scaling * pt%heat_density + this => this%next + END DO + ELSE + DO WHILE( ASSOCIATED( this ) ) + pt => this%current_point + icb_utl_heat = icb_utl_heat + ( pt%mass + pt%mass_of_bits ) * this%mass_scaling * pt%heat_density + this => this%next + END DO + ENDIF + ! + END FUNCTION icb_utl_heat + + SUBROUTINE test_icb_utl_getkb + !!---------------------------------------------------------------------- + !! *** FUNCTION test_icb_utl_getkb *** + !! + !! ** Purpose : Test routine icb_utl_getkb, icb_utl_zavg + !! ** Methode : Call each subroutine with specific input data + !! What should be the output is easy to determined and check + !! if NEMO return the correct answer. + !! ** Comments : not called, if needed a CALL test_icb_utl_getkb need to be added in icb_step + !!---------------------------------------------------------------------- + INTEGER :: ikb + REAL(wp) :: zout + REAL(wp) :: zD + REAL(wp), DIMENSION(jpk) :: ze3, zin + WRITE(numout,*) 'Test icb_utl_getkb : ' + zD = 0.0 ; ze3= 20.0 + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) + CALL icb_utl_getkb(ikb, ze3, zD) + WRITE(numout,*) 'OUTPUT : kb = ',ikb + + zD = 8000000.0 ; ze3= 20.0 + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) + CALL icb_utl_getkb(ikb, ze3, zD) + WRITE(numout,*) 'OUTPUT : kb = ',ikb + + zD = 80.0 ; ze3= 20.0 + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) + CALL icb_utl_getkb(ikb, ze3, zD) + WRITE(numout,*) 'OUTPUT : kb = ',ikb + + zD = 85.0 ; ze3= 20.0 + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) + CALL icb_utl_getkb(ikb, ze3, zD) + WRITE(numout,*) 'OUTPUT : kb = ',ikb + + zD = 75.0 ; ze3= 20.0 + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) + CALL icb_utl_getkb(ikb, ze3, zD) + WRITE(numout,*) 'OUTPUT : kb = ',ikb + + WRITE(numout,*) '==================================' + WRITE(numout,*) 'Test icb_utl_zavg' + zD = 0.0 ; ze3= 20.0 ; zin=1.0 + CALL icb_utl_getkb(ikb, ze3, zD) + CALL icb_utl_zavg(zout, zin, ze3, zD, ikb) + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1),' zin = ', zin, ' ikb = ',ikb + WRITE(numout,*) 'OUTPUT : zout = ',zout + + zD = 50.0 ; ze3= 20.0 ; zin=1.0; zin(3:jpk) = 0.0 + CALL icb_utl_getkb(ikb, ze3, zD) + CALL icb_utl_zavg(zout, zin, ze3, zD, ikb) + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1),' zin = ', zin, ' ikb = ',ikb + WRITE(numout,*) 'OUTPUT : zout = ',zout + CALL FLUSH(numout) + + zD = 80.0 ; ze3= 20.0 ; zin=1.0; zin(3:jpk) = 0.0 + CALL icb_utl_getkb(ikb, ze3, zD) + CALL icb_utl_zavg(zout, zin, ze3, zD, ikb) + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1),' zin = ', zin, ' ikb = ',ikb + WRITE(numout,*) 'OUTPUT : zout = ',zout + + zD = 80 ; ze3= 20.0 ; zin=1.0 ; zin(3:jpk) = 0.0 + CALL icb_utl_getkb(ikb, ze3, zD) + ikb = 2 + CALL icb_utl_zavg(zout, zin, ze3, zD, ikb) + WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1),' zin = ', zin, ' ikb = ',ikb + WRITE(numout,*) 'OUTPUT : zout = ',zout + + CALL FLUSH(numout) + + END SUBROUTINE test_icb_utl_getkb + + !!====================================================================== +END MODULE icbutl diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/in_out_manager.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/in_out_manager.F90 new file mode 100644 index 0000000..62b04ec --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/in_out_manager.F90 @@ -0,0 +1,194 @@ +MODULE in_out_manager + !!====================================================================== + !! *** MODULE in_out_manager *** + !! I/O manager utilities : Defines run parameters together with logical units + !!===================================================================== + !! History : 1.0 ! 2002-06 (G. Madec) original code + !! 2.0 ! 2006-07 (S. Masson) iom, add ctl_stop, ctl_warn + !! 3.0 ! 2008-06 (G. Madec) add ctmp4 to ctmp10 + !! 3.2 ! 2009-08 (S. MAsson) add new ctl_opn + !! 3.3 ! 2010-10 (A. Coward) add NetCDF4 usage + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameter + USE nc4interface ! NetCDF4 interface + + IMPLICIT NONE + PUBLIC + + !!---------------------------------------------------------------------- + !! namrun namelist parameters + !!---------------------------------------------------------------------- + CHARACTER(lc) :: cn_exp !: experiment name used for output filename + CHARACTER(lc) :: cn_ocerst_in !: suffix of ocean restart name (input) + CHARACTER(lc) :: cn_ocerst_indir !: restart input directory + CHARACTER(lc) :: cn_ocerst_out !: suffix of ocean restart name (output) + CHARACTER(lc) :: cn_ocerst_outdir !: restart output directory + LOGICAL :: ln_rstart !: start from (F) rest or (T) a restart file + LOGICAL :: ln_rst_list !: output restarts at list of times (T) or by frequency (F) + INTEGER :: nn_rstctl !: control of the time step (0, 1 or 2) + INTEGER :: nn_rstssh = 0 !: hand made initilization of ssh or not (1/0) + INTEGER :: nn_it000 !: index of the first time step + INTEGER :: nn_itend !: index of the last time step + INTEGER :: nn_date0 !: initial calendar date aammjj + INTEGER :: nn_time0 !: initial time of day in hhmm + INTEGER :: nn_leapy !: Leap year calendar flag (0/1 or 30) + INTEGER :: nn_istate !: initial state output flag (0/1) + INTEGER :: nn_write !: model standard output frequency + INTEGER :: nn_stock !: restart file frequency + INTEGER, DIMENSION(10) :: nn_stocklist !: restart dump times + LOGICAL :: ln_mskland !: mask land points in NetCDF outputs (costly: + ~15%) + LOGICAL :: ln_cfmeta !: output additional data to netCDF files required for compliance with the CF metadata standard + LOGICAL :: ln_clobber !: clobber (overwrite) an existing file + INTEGER :: nn_chunksz !: chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) + LOGICAL :: ln_xios_read !: use xios to read single file restart + INTEGER :: nn_wxios !: write resart using xios 0 - no, 1 - single, 2 - multiple file output + INTEGER :: nn_no !: Assimilation cycle + +#if defined key_netcdf4 + !!---------------------------------------------------------------------- + !! namnc4 namelist parameters (key_netcdf4) + !!---------------------------------------------------------------------- + ! The following four values determine the partitioning of the output fields + ! into netcdf4 chunks. They are unrelated to the nn_chunk_sz setting which is + ! for runtime optimisation. The individual netcdf4 chunks can be optionally + ! gzipped (recommended) leading to significant reductions in I/O volumes + ! !!!** variables only used with iom_nf90 routines and key_netcdf4 ** + INTEGER :: nn_nchunks_i !: number of chunks required in the i-dimension + INTEGER :: nn_nchunks_j !: number of chunks required in the j-dimension + INTEGER :: nn_nchunks_k !: number of chunks required in the k-dimension + INTEGER :: nn_nchunks_t !: number of chunks required in the t-dimension + LOGICAL :: ln_nc4zip !: netcdf4 usage: (T) chunk and compress output using the HDF5 sublayers of netcdf4 + ! ! (F) ignore chunking request and use the netcdf4 library + ! ! to produce netcdf3-compatible files +#endif + +!$AGRIF_DO_NOT_TREAT + TYPE(snc4_ctl) :: snc4set !: netcdf4 chunking control structure (always needed for decision making) +!$AGRIF_END_DO_NOT_TREAT + + + !! conversion of DOCTOR norm namelist name into model name + !! (this should disappear in a near futur) + + CHARACTER(lc) :: cexper !: experiment name used for output filename + INTEGER :: nrstdt !: control of the time step (0, 1 or 2) + INTEGER :: nit000 !: index of the first time step + INTEGER :: nitend !: index of the last time step + INTEGER :: ndate0 !: initial calendar date aammjj + INTEGER :: nleapy !: Leap year calendar flag (0/1 or 30) + INTEGER :: ninist !: initial state output flag (0/1) + + !!---------------------------------------------------------------------- + !! was in restart but moved here because of the OFF line... better solution should be found... + !!---------------------------------------------------------------------- + INTEGER :: nitrst !: time step at which restart file should be written + LOGICAL :: lrst_oce !: logical to control the oce restart write + LOGICAL :: lrst_ice !: logical to control the ice restart write + LOGICAL :: lrst_abl !: logical to control the abl restart write + INTEGER :: numror = 0 !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90) + INTEGER :: numrir = 0 !: logical unit for ice restart (read) + INTEGER :: numrar = 0 !: logical unit for abl restart (read) + INTEGER :: numrow = 0 !: logical unit for ocean restart (write) + INTEGER :: numriw = 0 !: logical unit for ice restart (write) + INTEGER :: numraw = 0 !: logical unit for abl restart (write) + INTEGER :: numrtr = 0 !: trc restart (read ) + INTEGER :: numrtw = 0 !: trc restart (write ) + INTEGER :: numrsr = 0 !: logical unit for sed restart (read) + INTEGER :: numrsw = 0 !: logical unit for sed restart (write) + + INTEGER :: nrst_lst !: number of restart to output next + + !!---------------------------------------------------------------------- + !! output monitoring + !!---------------------------------------------------------------------- + TYPE :: sn_ctl !: structure for control over output selection + LOGICAL :: l_runstat = .FALSE. !: Produce/do not produce run.stat file (T/F) + LOGICAL :: l_trcstat = .FALSE. !: Produce/do not produce tracer.stat file (T/F) + LOGICAL :: l_oceout = .FALSE. !: Produce all ocean.outputs (T) or just one (F) + LOGICAL :: l_layout = .FALSE. !: Produce all layout.dat files (T) or just one (F) + LOGICAL :: l_prtctl = .FALSE. !: Produce/do not produce mpp.output_XXXX files (T/F) + LOGICAL :: l_prttrc = .FALSE. !: Produce/do not produce mpp.top.output_XXXX files (T/F) + LOGICAL :: l_oasout = .FALSE. !: Produce/do not write oasis setup info to ocean.output (T/F) + ! Optional subsetting of processor report files + ! Default settings of 0/1000000/1 should ensure all areas report. + ! Set to a more restrictive range to select specific areas + INTEGER :: procmin = 0 !: Minimum narea to output + INTEGER :: procmax = 1000000 !: Maximum narea to output + INTEGER :: procincr = 1 !: narea increment to output + INTEGER :: ptimincr = 1 !: timestep increment to output (time.step and run.stat) + END TYPE + TYPE(sn_ctl), SAVE :: sn_cfctl !: run control structure for selective output, must have SAVE for default init. of sn_ctl + LOGICAL :: ln_timing !: run control for timing + LOGICAL :: ln_diacfl !: flag whether to create CFL diagnostics + INTEGER :: nn_ictls !: Start i indice for the SUM control + INTEGER :: nn_ictle !: End i indice for the SUM control + INTEGER :: nn_jctls !: Start j indice for the SUM control + INTEGER :: nn_jctle !: End j indice for the SUM control + INTEGER :: nn_isplt !: number of processors following i + INTEGER :: nn_jsplt !: number of processors following j + + !!---------------------------------------------------------------------- + !! logical units + !!---------------------------------------------------------------------- + INTEGER :: numstp = -1 !: logical unit for time step + INTEGER :: numtime = -1 !: logical unit for timing + INTEGER :: numout = 6 !: logical unit for output print; Set to stdout to ensure any + INTEGER :: numnul = -1 !: logical unit for /dev/null + ! ! early output can be collected; do not change + INTEGER :: numond = -1 !: logical unit for Output Namelist Dynamics + INTEGER :: numoni = -1 !: logical unit for Output Namelist Ice + INTEGER :: numevo_ice = -1 !: logical unit for ice variables (temp. evolution) + INTEGER :: numrun = -1 !: logical unit for run statistics + INTEGER :: numdct_in = -1 !: logical unit for transports computing + INTEGER :: numdct_vol = -1 !: logical unit for volume transports output + INTEGER :: numdct_heat = -1 !: logical unit for heat transports output + INTEGER :: numdct_salt = -1 !: logical unit for salt transports output + INTEGER :: numfl = -1 !: logical unit for floats ascii output + INTEGER :: numflo = -1 !: logical unit for floats ascii output + ! + CHARACTER(LEN=:), ALLOCATABLE :: numnam_ref !: character buffer for reference namelist + CHARACTER(LEN=:), ALLOCATABLE :: numnam_cfg !: character buffer for configuration specific namelist + CHARACTER(LEN=:), ALLOCATABLE :: numnam_ice_ref !: character buffer for ice reference namelist + CHARACTER(LEN=:), ALLOCATABLE :: numnam_ice_cfg !: character buffer for ice configuration specific namelist + + !!---------------------------------------------------------------------- + !! Run control + !!---------------------------------------------------------------------- + INTEGER :: no_print = 0 !: optional argument of fld_fill (if present, suppress some control print) + INTEGER :: nstop = 0 !: error flag (=number of reason for a premature stop run) +!$AGRIF_DO_NOT_TREAT + INTEGER :: ngrdstop = -1 !: grid number having nstop > 1 +!$AGRIF_END_DO_NOT_TREAT + INTEGER :: nwarn = 0 !: warning flag (=number of warning found during the run) + CHARACTER(lc) :: ctmp1, ctmp2, ctmp3 !: temporary characters 1 to 3 + CHARACTER(lc) :: ctmp4, ctmp5, ctmp6 !: temporary characters 4 to 6 + CHARACTER(lc) :: ctmp7, ctmp8, ctmp9 !: temporary characters 7 to 9 + CHARACTER(lc) :: ctmp10 !: temporary character 10 + LOGICAL :: lwm = .FALSE. !: boolean : true on the 1st processor only (always) + LOGICAL :: lwp = .FALSE. !: boolean : true on the 1st processor only .OR. sn_cfctl%l_oceout=T + LOGICAL :: lsp_area = .TRUE. !: to make a control print over a specific area + CHARACTER(LEN=lc) :: cxios_context !: context name used in xios + CHARACTER(LEN=lc) :: cr_ocerst_cxt !: context name used in xios to read OCE restart + CHARACTER(LEN=lc) :: cw_ocerst_cxt !: context name used in xios to write OCE restart file + CHARACTER(LEN=lc) :: cr_icerst_cxt !: context name used in xios to read SI3 restart + CHARACTER(LEN=lc) :: cw_icerst_cxt !: context name used in xios to write SI3 restart file + CHARACTER(LEN=lc) :: cr_ablrst_cxt !: context name used in xios to read ABL restart + CHARACTER(LEN=lc) :: cw_ablrst_cxt !: context name used in xios to write ABL restart file + CHARACTER(LEN=lc) :: cr_toprst_cxt !: context name used in xios to read TOP restart + CHARACTER(LEN=lc) :: cw_toprst_cxt !: context name used in xios to write TOP restart file + CHARACTER(LEN=lc) :: cr_sedrst_cxt !: context name used in xios to read SEDIMENT restart + CHARACTER(LEN=lc) :: cw_sedrst_cxt !: context name used in xios to write SEDIMENT restart file + + + + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: in_out_manager.F90 14553 2021-02-26 17:01:43Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!===================================================================== +END MODULE in_out_manager \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/iom.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/iom.F90 new file mode 100644 index 0000000..007f1e6 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/iom.F90 @@ -0,0 +1,2830 @@ +MODULE iom + !!====================================================================== + !! *** MODULE iom *** + !! Input/Output manager : Library to read input files + !!====================================================================== + !! History : 2.0 ! 2005-12 (J. Belier) Original code + !! 2.0 ! 2006-02 (S. Masson) Adaptation to NEMO + !! 3.0 ! 2007-07 (D. Storkey) Changes to iom_gettime + !! 3.4 ! 2012-12 (R. Bourdalle-Badie and G. Reffray) add C1D case + !! 3.6 ! 2014-15 DIMG format removed + !! 3.6 ! 2015-15 (J. Harle) Added procedure to read REAL attributes + !! 4.0 ! 2017-11 (M. Andrejczuk) Extend IOM interface to write any 3D fields + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! iom_open : open a file read only + !! iom_close : close a file or all files opened by iom + !! iom_get : read a field (interfaced to several routines) + !! iom_varid : get the id of a variable in a file + !! iom_rstput : write a field in a restart file (interfaced to several routines) + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE domutl ! + USE flo_oce ! floats module declarations + USE lbclnk ! lateal boundary condition / mpp exchanges + USE iom_def ! iom variables definitions + USE iom_nf90 ! NetCDF format with native NetCDF library + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE sbc_oce , ONLY : nn_fsbc, ght_abl, ghw_abl, e3t_abl, e3w_abl, jpka, jpkam1 + USE icb_oce , ONLY : nclasses, class_num ! !: iceberg classes +#if defined key_si3 + USE ice , ONLY : jpl +#endif + USE phycst ! physical constants + USE dianam ! build name of file +#if defined key_xios + USE xios +# endif + USE ioipsl, ONLY : ju2ymds ! for calendar + USE crs ! Grid coarsening +#if defined key_top + USE trc, ONLY : profsed +#endif + USE lib_fortran + USE diu_bulk, ONLY : ln_diurnal_only, ln_diurnal + USE iom_nf90 + USE netcdf + + IMPLICIT NONE + PUBLIC ! must be public to be able to access iom_def through iom + +#if defined key_xios + LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .TRUE. !: iom_put flag +#else + LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .FALSE. !: iom_put flag +#endif + PUBLIC iom_init, iom_init_closedef, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get, iom_get_var + PUBLIC iom_chkatt, iom_getatt, iom_putatt, iom_getszuld, iom_rstput, iom_delay_rst, iom_put + PUBLIC iom_use, iom_context_finalize, iom_update_file_name, iom_miss_val + PUBLIC iom_xios_setid + + PRIVATE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp + PRIVATE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp + PRIVATE iom_get_123d + PRIVATE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp + PRIVATE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp + PRIVATE iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp + PRIVATE iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp +#if defined key_xios + PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr + PRIVATE set_grid, set_grid_bounds, set_scalar, set_xmlatt, set_mooring, iom_sdate + PRIVATE iom_set_rst_context, iom_set_vars_active +# endif + PRIVATE set_xios_context + PRIVATE iom_set_rstw_active + + INTERFACE iom_get + MODULE PROCEDURE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp + MODULE PROCEDURE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp + END INTERFACE + INTERFACE iom_getatt + MODULE PROCEDURE iom_g0d_iatt, iom_g1d_iatt, iom_g0d_ratt, iom_g1d_ratt, iom_g0d_catt + END INTERFACE + INTERFACE iom_putatt + MODULE PROCEDURE iom_p0d_iatt, iom_p1d_iatt, iom_p0d_ratt, iom_p1d_ratt, iom_p0d_catt + END INTERFACE + INTERFACE iom_rstput + MODULE PROCEDURE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp + MODULE PROCEDURE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp + END INTERFACE + INTERFACE iom_put + MODULE PROCEDURE iom_p0d_sp, iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp + MODULE PROCEDURE iom_p0d_dp, iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp + END INTERFACE iom_put + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: iom.F90 15033 2021-06-21 10:24:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE iom_init( cdname, kdid, ld_closedef ) + !!---------------------------------------------------------------------- + !! *** ROUTINE *** + !! + !! ** Purpose : + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname + INTEGER , OPTIONAL, INTENT(in) :: kdid + LOGICAL , OPTIONAL, INTENT(in) :: ld_closedef +#if defined key_xios + ! + TYPE(xios_duration) :: dtime = xios_duration(0, 0, 0, 0, 0, 0) + TYPE(xios_date) :: start_date + CHARACTER(len=lc) :: clname + INTEGER :: irefyear, irefmonth, irefday + INTEGER :: ji + LOGICAL :: llrst_context ! is context related to restart + LOGICAL :: llrstr, llrstw + INTEGER :: inum + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zt_bnds, zw_bnds + REAL(wp), DIMENSION(2,jpkam1) :: za_bnds ! ABL vertical boundaries + LOGICAL :: ll_closedef + LOGICAL :: ll_exist + !!---------------------------------------------------------------------- + ! + ll_closedef = .TRUE. + IF ( PRESENT(ld_closedef) ) ll_closedef = ld_closedef + ! + ALLOCATE( zt_bnds(2,jpk), zw_bnds(2,jpk) ) + ! + clname = cdname + IF( TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(cdname) + CALL xios_context_initialize(TRIM(clname), mpi_comm_oce) + CALL iom_swap( cdname ) + + llrstr = (cdname == cr_ocerst_cxt) .OR. (cdname == cr_icerst_cxt) + llrstr = llrstr .OR. (cdname == cr_ablrst_cxt) + llrstr = llrstr .OR. (cdname == cr_toprst_cxt) + llrstr = llrstr .OR. (cdname == cr_sedrst_cxt) + + llrstw = (cdname == cw_ocerst_cxt) .OR. (cdname == cw_icerst_cxt) + llrstw = llrstw .OR. (cdname == cw_ablrst_cxt) + llrstw = llrstw .OR. (cdname == cw_toprst_cxt) + llrstw = llrstw .OR. (cdname == cw_sedrst_cxt) + + llrst_context = llrstr .OR. llrstw + + ! Calendar type is now defined in xml file + IF (.NOT.(xios_getvar('ref_year' ,irefyear ))) irefyear = 1900 + IF (.NOT.(xios_getvar('ref_month',irefmonth))) irefmonth = 01 + IF (.NOT.(xios_getvar('ref_day' ,irefday ))) irefday = 01 + + SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL + CASE ( 1) ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & + & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) + CASE ( 0) ; CALL xios_define_calendar( TYPE = "NoLeap" , time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & + & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) + CASE (30) ; CALL xios_define_calendar( TYPE = "D360" , time_origin = xios_date(irefyear,irefmonth,irefday,0,0,0), & + & start_date = xios_date( nyear, nmonth, nday,0,0,0) ) + END SELECT + + ! horizontal grid definition + IF(.NOT.llrst_context) CALL set_scalar + ! + IF( cdname == cxios_context ) THEN + CALL set_grid( "T", glamt, gphit, .FALSE., .FALSE. ) + CALL set_grid( "U", glamu, gphiu, .FALSE., .FALSE. ) + CALL set_grid( "V", glamv, gphiv, .FALSE., .FALSE. ) + CALL set_grid( "W", glamt, gphit, .FALSE., .FALSE. ) + CALL set_grid( "F", glamf, gphif, .FALSE., .FALSE. ) + CALL set_grid_znl( gphit ) + ! + IF( ln_cfmeta ) THEN ! Add additional grid metadata + CALL iom_set_domain_attr("grid_T", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) + CALL iom_set_domain_attr("grid_U", area = real( e1e2u(Nis0:Nie0, Njs0:Nje0), dp)) + CALL iom_set_domain_attr("grid_V", area = real( e1e2v(Nis0:Nie0, Njs0:Nje0), dp)) + CALL iom_set_domain_attr("grid_W", area = REAL( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) + CALL iom_set_domain_attr("grid_F", area = real( e1e2f(Nis0:Nie0, Njs0:Nje0), dp)) + CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) + CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) + CALL set_grid_bounds( "V", glamu, gphiu, glamv, gphiv ) + CALL set_grid_bounds( "W", glamf, gphif, glamt, gphit ) + CALL set_grid_bounds( "F", glamt, gphit, glamf, gphif ) + ENDIF + ENDIF + ! + IF( TRIM(cdname) == TRIM(cxios_context)//"_crs" ) THEN + CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain + ! + CALL set_grid( "T", glamt_crs, gphit_crs, .FALSE., .FALSE. ) + CALL set_grid( "U", glamu_crs, gphiu_crs, .FALSE., .FALSE. ) + CALL set_grid( "V", glamv_crs, gphiv_crs, .FALSE., .FALSE. ) + CALL set_grid( "W", glamt_crs, gphit_crs, .FALSE., .FALSE. ) + CALL set_grid_znl( gphit_crs ) + ! + CALL dom_grid_glo ! Return to parent grid domain + ! + IF( ln_cfmeta .AND. .NOT. llrst_context) THEN ! Add additional grid metadata + CALL iom_set_domain_attr("grid_T", area = real(e1e2t_crs(Nis0:Nie0, Njs0:Nje0), dp)) + CALL iom_set_domain_attr("grid_U", area = real(e1u_crs(Nis0:Nie0, Njs0:Nje0) * e2u_crs(Nis0:Nie0, Njs0:Nje0), dp)) + CALL iom_set_domain_attr("grid_V", area = real(e1v_crs(Nis0:Nie0, Njs0:Nje0) * e2v_crs(Nis0:Nie0, Njs0:Nje0), dp)) + CALL iom_set_domain_attr("grid_W", area = real(e1e2t_crs(Nis0:Nie0, Njs0:Nje0), dp)) + CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) + CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs ) + CALL set_grid_bounds( "V", glamu_crs, gphiu_crs, glamv_crs, gphiv_crs ) + CALL set_grid_bounds( "W", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) + ENDIF + ENDIF + ! + ! vertical grid definition + IF(.NOT.llrst_context) THEN + CALL iom_set_axis_attr( "deptht", paxis = gdept_1d ) + CALL iom_set_axis_attr( "depthu", paxis = gdept_1d ) + CALL iom_set_axis_attr( "depthv", paxis = gdept_1d ) + CALL iom_set_axis_attr( "depthw", paxis = gdepw_1d ) + CALL iom_set_axis_attr( "depthf", paxis = gdept_1d ) + + ! ABL + IF( .NOT. ALLOCATED(ght_abl) ) THEN ! force definition for xml files (xios) + ALLOCATE( ght_abl(jpka), ghw_abl(jpka), e3t_abl(jpka), e3w_abl(jpka) ) ! default allocation needed by iom + ght_abl(:) = -1._wp ; ghw_abl(:) = -1._wp + e3t_abl(:) = -1._wp ; e3w_abl(:) = -1._wp + ENDIF + CALL iom_set_axis_attr( "ght_abl", ght_abl(2:jpka) ) + CALL iom_set_axis_attr( "ghw_abl", ghw_abl(2:jpka) ) + + ! Add vertical grid bounds + zt_bnds(2,: ) = gdept_1d(:) + zt_bnds(1,2:jpk ) = gdept_1d(1:jpkm1) + zt_bnds(1,1 ) = gdept_1d(1) - e3w_1d(1) + zw_bnds(1,: ) = gdepw_1d(:) + zw_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) + zw_bnds(2,jpk: ) = gdepw_1d(jpk) + e3t_1d(jpk) + CALL iom_set_axis_attr( "deptht", bounds=zw_bnds ) + CALL iom_set_axis_attr( "depthu", bounds=zw_bnds ) + CALL iom_set_axis_attr( "depthv", bounds=zw_bnds ) + CALL iom_set_axis_attr( "depthw", bounds=zt_bnds ) + CALL iom_set_axis_attr( "depthf", bounds=zw_bnds ) + + ! ABL + za_bnds(1,:) = ghw_abl(1:jpkam1) + za_bnds(2,:) = ghw_abl(2:jpka ) + CALL iom_set_axis_attr( "ght_abl", bounds=za_bnds ) + za_bnds(1,:) = ght_abl(2:jpka ) + za_bnds(2,:) = ght_abl(2:jpka ) + e3w_abl(2:jpka) + CALL iom_set_axis_attr( "ghw_abl", bounds=za_bnds ) + + CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) +# if defined key_si3 + CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) + ! SIMIP diagnostics (4 main arctic straits) + CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) +# endif +#if defined key_top + IF( ALLOCATED(profsed) ) CALL iom_set_axis_attr( "profsed", paxis = profsed ) +#endif + CALL iom_set_axis_attr( "icbcla", class_num ) + CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) ! strange syntaxe and idea... + CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) ) ! strange syntaxe and idea... + CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) ! strange syntaxe and idea... + ! for diaprt, we need to define an axis which size can be 1 (default) or 5 (if the file subbasins.nc exists) + INQUIRE( FILE = 'subbasins.nc', EXIST = ll_exist ) + nbasin = 1 + 4 * COUNT( (/ll_exist/) ) + CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,nbasin) /) ) + ENDIF + ! + ! automatic definitions of some of the xml attributs + IF(llrstr) THEN + IF(PRESENT(kdid)) THEN + CALL iom_set_rst_context(.TRUE.) +!set which fields will be read from restart file + CALL iom_set_vars_active(kdid) + ELSE + CALL ctl_stop( 'iom_init:', 'restart read with XIOS: missing pointer to NETCDF file' ) + ENDIF + ELSE IF(llrstw) THEN + CALL iom_set_rstw_file(iom_file(kdid)%name) + ELSE + CALL set_xmlatt + ENDIF + ! + ! set time step length + dtime%second = rn_Dt + CALL xios_set_timestep( dtime ) + ! + ! conditional closure of context definition + IF ( ll_closedef ) CALL iom_init_closedef + ! + DEALLOCATE( zt_bnds, zw_bnds ) + ! +#endif + ! + END SUBROUTINE iom_init + + SUBROUTINE iom_init_closedef(cdname) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE iom_init_closedef *** + !!---------------------------------------------------------------------- + !! + !! ** Purpose : Closure of context definition + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), OPTIONAL, INTENT(IN) :: cdname +#if defined key_xios + LOGICAL :: llrstw + + llrstw = .FALSE. + IF(PRESENT(cdname)) THEN + llrstw = (cdname == cw_ocerst_cxt) + llrstw = llrstw .OR. (cdname == cw_icerst_cxt) + llrstw = llrstw .OR. (cdname == cw_ablrst_cxt) + llrstw = llrstw .OR. (cdname == cw_toprst_cxt) + llrstw = llrstw .OR. (cdname == cw_sedrst_cxt) + ENDIF + + IF( llrstw ) THEN +!set names of the fields in restart file IF using XIOS to write data + CALL iom_set_rst_context(.FALSE.) + CALL xios_close_context_definition() + ELSE + CALL xios_close_context_definition() + CALL xios_update_calendar( 0 ) + ENDIF +#else + IF( .FALSE. ) WRITE(numout,*) 'iom_init_closedef: should not see this' ! useless statement to avoid compilation warnings +#endif + + END SUBROUTINE iom_init_closedef + + SUBROUTINE iom_set_vars_active(idnum) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_set_vars_active *** + !! + !! ** Purpose : define filename in XIOS context for reading file, + !! enable variables present in a file for reading with XIOS + !! id of the file is assumed to be rrestart. + !!--------------------------------------------------------------------- + INTEGER, INTENT(IN) :: idnum + +#if defined key_xios + INTEGER :: ndims, nvars, natts, unlimitedDimId, dimlen, xtype,mdims + TYPE(xios_field) :: field_hdl + TYPE(xios_file) :: file_hdl + TYPE(xios_filegroup) :: filegroup_hdl + INTEGER :: dimids(4), jv,i, idim + CHARACTER(LEN=256) :: clinfo ! info character + INTEGER, ALLOCATABLE :: indimlens(:) + CHARACTER(LEN=nf90_max_name), ALLOCATABLE :: indimnames(:) + CHARACTER(LEN=nf90_max_name) :: dimname, varname + INTEGER :: iln + CHARACTER(LEN=lc) :: fname + LOGICAL :: lmeta +!metadata in restart file for restart read with XIOS + INTEGER, PARAMETER :: NMETA = 11 + CHARACTER(LEN=lc) :: meta(NMETA) + + + meta(1) = "nav_lat" + meta(2) = "nav_lon" + meta(3) = "nav_lev" + meta(4) = "time_instant" + meta(5) = "time_instant_bounds" + meta(6) = "time_counter" + meta(7) = "time_counter_bounds" + meta(8) = "x" + meta(9) = "y" + meta(10) = "numcat" + meta(11) = "nav_hgt" + + clinfo = ' iom_set_vars_active, file: '//TRIM(iom_file(idnum)%name) + + iln = INDEX( iom_file(idnum)%name, '.nc' ) +!XIOS doee not need .nc + IF(iln > 0) THEN + fname = iom_file(idnum)%name(1:iln-1) + ELSE + fname = iom_file(idnum)%name + ENDIF + +!set name of the restart file and enable available fields + CALL xios_get_handle("file_definition", filegroup_hdl ) + CALL xios_add_child(filegroup_hdl, file_hdl, 'rrestart') + CALL xios_set_file_attr( "rrestart", name=fname, type="one_file", & + par_access="collective", enabled=.TRUE., mode="read", & + output_freq=xios_timestep ) + + CALL iom_nf90_check( nf90_inquire(iom_file(idnum)%nfid, ndims, nvars, natts ), clinfo ) + ALLOCATE(indimlens(ndims), indimnames(ndims)) + CALL iom_nf90_check( nf90_inquire(iom_file(idnum)%nfid, unlimitedDimId = unlimitedDimId ), clinfo ) + + DO idim = 1, ndims + CALL iom_nf90_check( nf90_inquire_dimension(iom_file(idnum)%nfid, idim, dimname, dimlen ), clinfo ) + indimlens(idim) = dimlen + indimnames(idim) = dimname + ENDDO + + DO jv =1, nvars + lmeta = .FALSE. + CALL iom_nf90_check( nf90_inquire_variable(iom_file(idnum)%nfid, jv, varname, xtype, ndims, dimids, natts ), clinfo ) + DO i = 1, NMETA + IF(varname == meta(i)) THEN + lmeta = .TRUE. + ENDIF + ENDDO + IF(.NOT.lmeta) THEN + CALL xios_add_child(file_hdl, field_hdl, varname) + mdims = ndims + + IF(ANY(dimids(1:ndims) == unlimitedDimId)) THEN + mdims = mdims - 1 + ENDIF + + IF(mdims == 3) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & + domain_ref="grid_N", & + axis_ref=iom_axis(indimlens(dimids(mdims))), & + prec = 8, operation = "instant" ) + ELSEIF(mdims == 2) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & + domain_ref="grid_N", prec = 8, & + operation = "instant" ) + ELSEIF(mdims == 1) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & + axis_ref=iom_axis(indimlens(dimids(mdims))), & + prec = 8, operation = "instant" ) + ELSEIF(mdims == 0) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & + scalar_ref = "grid_scalar", prec = 8, & + operation = "instant" ) + ELSE + WRITE(ctmp1,*) 'iom_set_vars_active: variable ', TRIM(varname) ,' incorrect number of dimensions' + CALL ctl_stop( 'iom_set_vars_active:', ctmp1 ) + ENDIF + ENDIF + ENDDO + DEALLOCATE(indimlens, indimnames) +#endif + END SUBROUTINE iom_set_vars_active + + SUBROUTINE iom_set_rstw_file(cdrst_file) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_set_rstw_file *** + !! + !! ** Purpose : define file name in XIOS context for writing restart + !!--------------------------------------------------------------------- + CHARACTER(len=*) :: cdrst_file +#if defined key_xios + TYPE(xios_file) :: file_hdl + TYPE(xios_filegroup) :: filegroup_hdl + +!set name of the restart file and enable available fields + IF(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS write) to: ', TRIM(cdrst_file) + CALL xios_get_handle("file_definition", filegroup_hdl ) + CALL xios_add_child(filegroup_hdl, file_hdl, 'wrestart') + IF(nxioso.eq.1) THEN + CALL xios_set_file_attr( "wrestart", type="one_file", enabled=.TRUE.,& + mode="write", output_freq=xios_timestep) + IF(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in one_file mode' + ELSE + CALL xios_set_file_attr( "wrestart", type="multiple_file", enabled=.TRUE.,& + mode="write", output_freq=xios_timestep) + IF(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in multiple_file mode' + ENDIF + CALL xios_set_file_attr( "wrestart", name=trim(cdrst_file)) +#endif + END SUBROUTINE iom_set_rstw_file + + + SUBROUTINE iom_set_rstw_active(sdfield, rd0, rs0, rd1, rs1, rd2, rs2, rd3, rs3) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_set_rstw_active *** + !! + !! ** Purpose : define file name in XIOS context for writing restart + !! enable variables present in restart file for writing + !!--------------------------------------------------------------------- +!sets enabled = .TRUE. for each field in restart file + CHARACTER(len = *), INTENT(IN) :: sdfield + REAL(dp), OPTIONAL, INTENT(IN) :: rd0 + REAL(sp), OPTIONAL, INTENT(IN) :: rs0 + REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:) :: rd1 + REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:) :: rs1 + REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:, :) :: rd2 + REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:, :) :: rs2 + REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:, :, :) :: rd3 + REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:, :, :) :: rs3 +#if defined key_xios + TYPE(xios_field) :: field_hdl + TYPE(xios_file) :: file_hdl + + CALL xios_get_handle("wrestart", file_hdl) +!define fields for restart context + CALL xios_add_child(file_hdl, field_hdl, sdfield) + + IF(PRESENT(rd3)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + domain_ref = "grid_N", & + axis_ref = iom_axis(size(rd3, 3)), & + prec = 8, operation = "instant" ) + ELSEIF(PRESENT(rs3)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + domain_ref = "grid_N", & + axis_ref = iom_axis(size(rd3, 3)), & + prec = 4, operation = "instant" ) + ELSEIF(PRESENT(rd2)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + domain_ref = "grid_N", prec = 8, & + operation = "instant" ) + ELSEIF(PRESENT(rs2)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + domain_ref = "grid_N", prec = 4, & + operation = "instant" ) + ELSEIF(PRESENT(rd1)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + axis_ref = iom_axis(size(rd1, 1)), & + prec = 8, operation = "instant" ) + ELSEIF(PRESENT(rs1)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + axis_ref = iom_axis(size(rd1, 1)), & + prec = 4, operation = "instant" ) + ELSEIF(PRESENT(rd0)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + scalar_ref = "grid_scalar", prec = 8, & + operation = "instant" ) + ELSEIF(PRESENT(rs0)) THEN + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & + scalar_ref = "grid_scalar", prec = 4, & + operation = "instant" ) + ENDIF +#endif + END SUBROUTINE iom_set_rstw_active + + FUNCTION iom_axis(idlev) result(axis_ref) + !!--------------------------------------------------------------------- + !! *** FUNCTION iom_axis *** + !! + !! ** Purpose : Used for grid definition when XIOS is used to read/write + !! restart. Returns axis corresponding to the number of levels + !! given as an input variable. Axes are defined in routine + !! iom_set_rst_context + !!--------------------------------------------------------------------- + INTEGER, INTENT(IN) :: idlev + CHARACTER(len=lc) :: axis_ref + CHARACTER(len=12) :: str + IF(idlev == jpk) THEN + axis_ref="nav_lev" + ELSEIF(idlev == jpka) THEN + axis_ref="nav_hgt" +#if defined key_si3 + ELSEIF(idlev == jpl) THEN + axis_ref="numcat" +#endif + ELSE + write(str, *) idlev + CALL ctl_stop( 'iom_axis', 'Definition for axis with '//TRIM(ADJUSTL(str))//' levels missing') + ENDIF + END FUNCTION iom_axis + + FUNCTION iom_xios_setid(cdname) result(kid) + !!--------------------------------------------------------------------- + !! *** FUNCTION *** + !! + !! ** Purpose : this function returns first available id to keep information about file + !! sets filename in iom_file structure and sets name + !! of XIOS context depending on cdcomp + !! corresponds to iom_nf90_open + !!--------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! File name + INTEGER :: kid ! identifier of the opened file + INTEGER :: jl + + kid = 0 + DO jl = jpmax_files, 1, -1 + IF( iom_file(jl)%nfid == 0 ) kid = jl + ENDDO + + iom_file(kid)%name = TRIM(cdname) + iom_file(kid)%nfid = 1 + iom_file(kid)%nvars = 0 + iom_file(kid)%irec = -1 + + END FUNCTION iom_xios_setid + + SUBROUTINE iom_set_rst_context(ld_rstr) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_set_rst_context *** + !! + !! ** Purpose : Define domain, axis and grid for restart (read/write) + !! context + !! + !!--------------------------------------------------------------------- + LOGICAL, INTENT(IN) :: ld_rstr + INTEGER :: ji +#if defined key_xios + TYPE(xios_domaingroup) :: domaingroup_hdl + TYPE(xios_domain) :: domain_hdl + TYPE(xios_axisgroup) :: axisgroup_hdl + TYPE(xios_axis) :: axis_hdl + TYPE(xios_scalar) :: scalar_hdl + TYPE(xios_scalargroup) :: scalargroup_hdl + + CALL xios_get_handle("domain_definition",domaingroup_hdl) + CALL xios_add_child(domaingroup_hdl, domain_hdl, "grid_N") + CALL set_grid("N", glamt, gphit, .TRUE., ld_rstr) + + CALL xios_get_handle("axis_definition",axisgroup_hdl) + CALL xios_add_child(axisgroup_hdl, axis_hdl, "nav_lev") +!AGRIF fails to compile when unit= is in call to xios_set_axis_attr +! CALL xios_set_axis_attr( "nav_lev", long_name="Vertical levels", unit="m", positive="down") + CALL xios_set_axis_attr( "nav_lev", long_name = "Vertical levels in meters", positive = "down") + CALL iom_set_axis_attr( "nav_lev", paxis = gdept_1d ) +#if defined key_si3 + CALL xios_add_child(axisgroup_hdl, axis_hdl, "numcat") + CALL iom_set_axis_attr( "numcat", (/ (REAL(ji,wp), ji=1,jpl) /) ) +#endif + CALL xios_add_child(axisgroup_hdl, axis_hdl, "nav_hgt") + CALL iom_set_axis_attr( "nav_hgt", (/ (REAL(ji,wp), ji=1,jpka) /) ) + CALL xios_get_handle("scalar_definition", scalargroup_hdl) + CALL xios_add_child(scalargroup_hdl, scalar_hdl, "grid_scalar") +#endif + END SUBROUTINE iom_set_rst_context + + + SUBROUTINE set_xios_context(kdid, cdcont) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_set_rst_context *** + !! + !! ** Purpose : set correct XIOS context based on kdid + !! + !!--------------------------------------------------------------------- + INTEGER, INTENT(IN) :: kdid ! Identifier of the file + CHARACTER(LEN=lc), INTENT(OUT) :: cdcont ! name of the context for XIOS read/write + + cdcont = "NONE" + + IF(lrxios) THEN + IF(kdid == numror) THEN + cdcont = cr_ocerst_cxt + ELSEIF(kdid == numrir) THEN + cdcont = cr_icerst_cxt + ELSEIF(kdid == numrar) THEN + cdcont = cr_ablrst_cxt + ELSEIF(kdid == numrtr) THEN + cdcont = cr_toprst_cxt + ELSEIF(kdid == numrsr) THEN + cdcont = cr_sedrst_cxt + ENDIF + ENDIF + + IF(lwxios) THEN + IF(kdid == numrow) THEN + cdcont = cw_ocerst_cxt + ELSEIF(kdid == numriw) THEN + cdcont = cw_icerst_cxt + ELSEIF(kdid == numraw) THEN + cdcont = cw_ablrst_cxt + ELSEIF(kdid == numrtw) THEN + cdcont = cw_toprst_cxt + ELSEIF(kdid == numrsw) THEN + cdcont = cw_sedrst_cxt + ENDIF + ENDIF + END SUBROUTINE set_xios_context + + + SUBROUTINE iom_swap( cdname ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_swap *** + !! + !! ** Purpose : swap context between different agrif grid for xmlio_server + !!--------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname +#if defined key_xios + TYPE(xios_context) :: nemo_hdl + IF( TRIM(Agrif_CFixed()) == '0' ) THEN + CALL xios_get_handle(TRIM(cdname),nemo_hdl) + ELSE + CALL xios_get_handle(TRIM(Agrif_CFixed())//"_"//TRIM(cdname),nemo_hdl) + ENDIF + ! + CALL xios_set_current_context(nemo_hdl) +#endif + ! + END SUBROUTINE iom_swap + + + SUBROUTINE iom_open( cdname, kiomid, ldwrt, ldstop, ldiof, kdlev, cdcomp ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_open *** + !! + !! ** Purpose : open an input file (return 0 if not found) + !!--------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! File name + INTEGER , INTENT( out) :: kiomid ! iom identifier of the opened file + LOGICAL , INTENT(in ), OPTIONAL :: ldwrt ! open in write modeb (default = .FALSE.) + LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if open to read a non-existing file (default = .TRUE.) + LOGICAL , INTENT(in ), OPTIONAL :: ldiof ! Interp On the Fly, needed for AGRIF (default = .FALSE.) + INTEGER , INTENT(in ), OPTIONAL :: kdlev ! number of vertical levels + CHARACTER(len=3), INTENT(in ), OPTIONAL :: cdcomp ! name of component calling iom_nf90_open + ! + CHARACTER(LEN=256) :: clname ! the name of the file based on cdname [[+clcpu]+clcpu] + CHARACTER(LEN=256) :: cltmpn ! tempory name to store clname (in writting mode) + CHARACTER(LEN=10) :: clsuffix ! ".nc" + CHARACTER(LEN=15) :: clcpu ! the cpu number (max jpmax_digits digits) + CHARACTER(LEN=256) :: clinfo ! info character + LOGICAL :: llok ! check the existence + LOGICAL :: llwrt ! local definition of ldwrt + LOGICAL :: llstop ! local definition of ldstop + LOGICAL :: lliof ! local definition of ldiof + INTEGER :: icnt ! counter for digits in clcpu (max = jpmax_digits) + INTEGER :: iln, ils ! lengths of character + INTEGER :: istop ! + ! local number of points for x,y dimensions + ! position of first local point for x,y dimensions + ! position of last local point for x,y dimensions + ! start halo size for x,y dimensions + ! end halo size for x,y dimensions + !--------------------------------------------------------------------- + ! Initializations and control + ! ============= + kiomid = -1 + clinfo = ' iom_open ~~~ ' + istop = nstop + ! if iom_open is called for the first time: initialize iom_file(:)%nfid to 0 + ! (could be done when defining iom_file in f95 but not in f90) + IF( Agrif_Root() ) THEN + IF( iom_open_init == 0 ) THEN + iom_file(:)%nfid = 0 + iom_open_init = 1 + ENDIF + ENDIF + ! do we read or write the file? + IF( PRESENT(ldwrt) ) THEN ; llwrt = ldwrt + ELSE ; llwrt = .FALSE. + ENDIF + ! do we call ctl_stop if we try to open a non-existing file in read mode? + IF( PRESENT(ldstop) ) THEN ; llstop = ldstop + ELSE ; llstop = .TRUE. + ENDIF + ! are we using interpolation on the fly? + IF( PRESENT(ldiof) ) THEN ; lliof = ldiof + ELSE ; lliof = .FALSE. + ENDIF + ! create the file name by added, if needed, TRIM(Agrif_CFixed()) and TRIM(clsuffix) + ! ============= + clname = trim(cdname) + IF ( .NOT. Agrif_Root() .AND. .NOT. lliof ) THEN + iln = INDEX(clname,'/') + cltmpn = clname(1:iln) + clname = clname(iln+1:LEN_TRIM(clname)) + clname=TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname) + ENDIF + ! which suffix should we use? + clsuffix = '.nc' + ! Add the suffix if needed + iln = LEN_TRIM(clname) + ils = LEN_TRIM(clsuffix) + IF( iln <= ils .OR. INDEX( TRIM(clname), TRIM(clsuffix), back = .TRUE. ) /= iln - ils + 1 ) & + & clname = TRIM(clname)//TRIM(clsuffix) + cltmpn = clname ! store this name + ! try to find if the file to be opened already exist + ! ============= + INQUIRE( FILE = clname, EXIST = llok ) + IF( .NOT.llok ) THEN + ! we try to add the cpu number to the name + WRITE(clcpu,*) narea-1 + + clcpu = TRIM(ADJUSTL(clcpu)) + iln = INDEX(clname,TRIM(clsuffix), back = .TRUE.) + clname = clname(1:iln-1)//'_'//TRIM(clcpu)//TRIM(clsuffix) + icnt = 0 + INQUIRE( FILE = clname, EXIST = llok ) + ! we try different formats for the cpu number by adding 0 + DO WHILE( .NOT.llok .AND. icnt < jpmax_digits ) + clcpu = "0"//trim(clcpu) + clname = clname(1:iln-1)//'_'//TRIM(clcpu)//TRIM(clsuffix) + INQUIRE( FILE = clname, EXIST = llok ) + icnt = icnt + 1 + END DO + ELSE + lxios_sini = .TRUE. + ENDIF + ! Open the NetCDF file + ! ============= + ! do we have some free file identifier? + IF( MINVAL(iom_file(:)%nfid) /= 0 ) & + & CALL ctl_stop( TRIM(clinfo), 'No more free file identifier', 'increase jpmax_files in iom_def' ) + ! if no file was found... + IF( .NOT. llok ) THEN + IF( .NOT. llwrt ) THEN ! we are in read mode + IF( llstop ) THEN ; CALL ctl_stop( TRIM(clinfo), 'File '//TRIM(cltmpn)//'* not found' ) + ELSE ; istop = nstop + 1 ! make sure that istop /= nstop so we don't open the file + ENDIF + ELSE ! we are in write mode so we + clname = cltmpn ! get back the file name without the cpu number + ENDIF + ELSE + IF( llwrt .AND. .NOT. ln_clobber ) THEN ! we stop as we want to write in a new file + CALL ctl_stop( TRIM(clinfo), 'We want to write in a new file but '//TRIM(clname)//' already exists...' ) + istop = nstop + 1 ! make sure that istop /= nstop so we don't open the file + ELSEIF( llwrt ) THEN ! the file exists and we are in write mode with permission to + clname = cltmpn ! overwrite so get back the file name without the cpu number + ENDIF + ENDIF + IF( istop == nstop ) THEN ! no error within this routine + CALL iom_nf90_open( clname, kiomid, llwrt, llok, kdlev = kdlev, cdcomp = cdcomp ) + ENDIF + ! + END SUBROUTINE iom_open + + + SUBROUTINE iom_close( kiomid ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_close *** + !! + !! ** Purpose : close an input file, or all files opened by iom + !!-------------------------------------------------------------------- + INTEGER, INTENT(inout), OPTIONAL :: kiomid ! iom identifier of the file to be closed + ! ! return 0 when file is properly closed + ! ! No argument: all files opened by iom are closed + + INTEGER :: jf ! dummy loop indices + INTEGER :: i_s, i_e ! temporary integer + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + ! + IF( iom_open_init == 0 ) RETURN ! avoid to use iom_file(jf)%nfid that us not yet initialized + ! + clinfo = ' iom_close ~~~ ' + IF( PRESENT(kiomid) ) THEN + i_s = kiomid + i_e = kiomid + ELSE + i_s = 1 + i_e = jpmax_files + ENDIF + + IF( i_s > 0 ) THEN + DO jf = i_s, i_e + IF( iom_file(jf)%nfid > 0 ) THEN + CALL iom_nf90_close( jf ) + iom_file(jf)%nfid = 0 ! free the id + IF( PRESENT(kiomid) ) kiomid = 0 ! return 0 as id to specify that the file was closed + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' close file: '//TRIM(iom_file(jf)%name)//' ok' + ELSEIF( PRESENT(kiomid) ) THEN + WRITE(ctmp1,*) '--->', kiomid + CALL ctl_stop( TRIM(clinfo)//' Invalid file identifier', ctmp1 ) + ENDIF + END DO + ENDIF + ! + END SUBROUTINE iom_close + + + FUNCTION iom_varid ( kiomid, cdvar, kdimsz, kndims, lduld, ldstop ) + !!----------------------------------------------------------------------- + !! *** FUNCTION iom_varid *** + !! + !! ** Purpose : get the id of a variable in a file (return 0 if not found) + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! file Identifier + CHARACTER(len=*) , INTENT(in ) :: cdvar ! name of the variable + INTEGER, DIMENSION(:), INTENT( out), OPTIONAL :: kdimsz ! size of each dimension + INTEGER , INTENT( out), OPTIONAL :: kndims ! number of dimensions + LOGICAL , INTENT( out), OPTIONAL :: lduld ! true if the last dimension is unlimited (time) + LOGICAL , INTENT(in ), OPTIONAL :: ldstop ! stop if looking for non-existing variable (default = .TRUE.) + ! + INTEGER :: iom_varid, iiv, i_nvd + LOGICAL :: ll_fnd + CHARACTER(LEN=100) :: clinfo ! info character + LOGICAL :: llstop ! local definition of ldstop + !!----------------------------------------------------------------------- + iom_varid = 0 ! default definition + ! do we call ctl_stop if we look for non-existing variable? + IF( PRESENT(ldstop) ) THEN ; llstop = ldstop + ELSE ; llstop = .TRUE. + ENDIF + ! + IF( kiomid > 0 ) THEN + clinfo = 'iom_varid, file: '//trim(iom_file(kiomid)%name)//', var: '//trim(cdvar) + IF( iom_file(kiomid)%nfid == 0 ) THEN + CALL ctl_stop( trim(clinfo), 'the file is not open' ) + ELSE + ll_fnd = .FALSE. + iiv = 0 + ! + DO WHILE ( .NOT.ll_fnd .AND. iiv < iom_file(kiomid)%nvars ) + iiv = iiv + 1 + ll_fnd = ( TRIM(cdvar) == TRIM(iom_file(kiomid)%cn_var(iiv)) ) + END DO + ! + IF( .NOT.ll_fnd ) THEN + iiv = iiv + 1 + IF( iiv <= jpmax_vars ) THEN + iom_varid = iom_nf90_varid( kiomid, cdvar, iiv, kdimsz, kndims, lduld ) + ELSE + CALL ctl_stop( trim(clinfo), 'Too many variables in the file '//iom_file(kiomid)%name, & + & 'increase the parameter jpmax_vars') + ENDIF + IF( llstop .AND. iom_varid == -1 ) CALL ctl_stop( TRIM(clinfo)//' not found' ) + ELSE + iom_varid = iiv + IF( PRESENT(kdimsz) ) THEN + i_nvd = iom_file(kiomid)%ndims(iiv) + IF( i_nvd <= size(kdimsz) ) THEN + kdimsz(1:i_nvd) = iom_file(kiomid)%dimsz(1:i_nvd,iiv) + ELSE + WRITE(ctmp1,*) i_nvd, size(kdimsz) + CALL ctl_stop( trim(clinfo), 'error in kdimsz size'//trim(ctmp1) ) + ENDIF + ENDIF + IF( PRESENT(kndims) ) kndims = iom_file(kiomid)%ndims(iiv) + IF( PRESENT( lduld) ) lduld = iom_file(kiomid)%luld( iiv) + ENDIF + ENDIF + ENDIF + ! + END FUNCTION iom_varid + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_get + !!---------------------------------------------------------------------- + SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(sp) , INTENT( out) :: pvar ! read field + REAL(dp) :: ztmp_pvar ! tmp var to read field + INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number + ! + INTEGER :: idvar ! variable id + INTEGER :: idmspc ! number of spatial dimensions + INTEGER , DIMENSION(1) :: itime ! record number + CHARACTER(LEN=100) :: clinfo ! info character + CHARACTER(LEN=100) :: clname ! file name + CHARACTER(LEN=1) :: cldmspc ! + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + IF(context == "NONE") THEN ! read data using default library + itime = 1 + IF( PRESENT(ktime) ) itime = ktime + ! + clname = iom_file(kiomid)%name + clinfo = ' iom_g0d, file: '//trim(clname)//', var: '//trim(cdvar) + ! + IF( kiomid > 0 ) THEN + idvar = iom_varid( kiomid, cdvar ) + IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN + idmspc = iom_file ( kiomid )%ndims( idvar ) + IF( iom_file(kiomid)%luld(idvar) ) idmspc = idmspc - 1 + WRITE(cldmspc , fmt='(i1)') idmspc + IF( idmspc > 0 ) CALL ctl_stop( TRIM(clinfo), 'When reading to a 0D array, we do not accept data', & + & 'with 1 or more spatial dimensions: '//cldmspc//' were found.' , & + & 'Use ncwa -a to suppress the unnecessary dimensions' ) + CALL iom_nf90_get( kiomid, idvar, ztmp_pvar, itime ) + pvar = ztmp_pvar + ENDIF + ENDIF + ELSE +#if defined key_xios + IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) + CALL iom_swap(context) + CALL xios_recv_field( trim(cdvar), pvar) + CALL iom_swap(cxios_context) +#else + WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) + CALL ctl_stop( 'iom_g0d', ctmp1 ) +#endif + ENDIF + END SUBROUTINE iom_g0d_sp + + SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(dp) , INTENT( out) :: pvar ! read field + INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number + ! + INTEGER :: idvar ! variable id + INTEGER :: idmspc ! number of spatial dimensions + INTEGER , DIMENSION(1) :: itime ! record number + CHARACTER(LEN=100) :: clinfo ! info character + CHARACTER(LEN=100) :: clname ! file name + CHARACTER(LEN=1) :: cldmspc ! + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + IF(context == "NONE") THEN ! read data using default library + itime = 1 + IF( PRESENT(ktime) ) itime = ktime + ! + clname = iom_file(kiomid)%name + clinfo = ' iom_g0d, file: '//trim(clname)//', var: '//trim(cdvar) + ! + IF( kiomid > 0 ) THEN + idvar = iom_varid( kiomid, cdvar ) + IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN + idmspc = iom_file ( kiomid )%ndims( idvar ) + IF( iom_file(kiomid)%luld(idvar) ) idmspc = idmspc - 1 + WRITE(cldmspc , fmt='(i1)') idmspc + IF( idmspc > 0 ) CALL ctl_stop( TRIM(clinfo), 'When reading to a 0D array, we do not accept data', & + & 'with 1 or more spatial dimensions: '//cldmspc//' were found.' , & + & 'Use ncwa -a to suppress the unnecessary dimensions' ) + CALL iom_nf90_get( kiomid, idvar, pvar, itime ) + ENDIF + ENDIF + ELSE +#if defined key_xios + IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) + CALL iom_swap(context) + CALL xios_recv_field( trim(cdvar), pvar) + CALL iom_swap(cxios_context) +#else + WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) + CALL ctl_stop( 'iom_g0d', ctmp1 ) +#endif + ENDIF + END SUBROUTINE iom_g0d_dp + + SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(sp) , INTENT( out), DIMENSION(:) :: pvar ! read field + REAL(dp) , ALLOCATABLE , DIMENSION(:) :: ztmp_pvar ! tmp var to read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading + INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ALLOCATE(ztmp_pvar(size(pvar,1))) + CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=ztmp_pvar, & + & ktime=ktime, kstart=kstart, kcount=kcount ) + pvar = ztmp_pvar + DEALLOCATE(ztmp_pvar) + END IF + ENDIF + END SUBROUTINE iom_g1d_sp + + + SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(dp) , INTENT( out), DIMENSION(:) :: pvar ! read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading + INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=pvar, & + & ktime=ktime, kstart=kstart, kcount=kcount) + ENDIF + END SUBROUTINE iom_g1d_dp + + SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(sp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field + REAL(dp) , ALLOCATABLE , DIMENSION(:,:) :: ztmp_pvar ! tmp var to read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) + REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold + INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk + INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading + INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2))) + CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = ztmp_pvar , ktime = ktime, & + & cd_type = cd_type, psgn = psgn , kfill = kfill, & + & kstart = kstart , kcount = kcount ) + pvar = ztmp_pvar + DEALLOCATE(ztmp_pvar) + ENDIF + ENDIF + END SUBROUTINE iom_g2d_sp + + SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(dp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) + REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.): (not) change sign across the north fold + INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk + INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading + INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = pvar , ktime = ktime, & + & cd_type = cd_type, psgn = psgn , kfill = kfill, & + & kstart = kstart , kcount = kcount ) + ENDIF + END SUBROUTINE iom_g2d_dp + + SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(sp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field + REAL(dp) , ALLOCATABLE , DIMENSION(:,:,:) :: ztmp_pvar ! tmp var to read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) + REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold + INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk + INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading + INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2), size(pvar,3))) + CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = ztmp_pvar , ktime = ktime, & + & cd_type = cd_type, psgn = psgn , kfill = kfill, & + & kstart = kstart , kcount = kcount ) + pvar = ztmp_pvar + DEALLOCATE(ztmp_pvar) + END IF + ENDIF + END SUBROUTINE iom_g3d_sp + + SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(dp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + CHARACTER(len=1), INTENT(in ) , OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) + REAL(dp) , INTENT(in ) , OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold + INTEGER , INTENT(in ) , OPTIONAL :: kfill ! value of kfillmode in lbc_lbk + INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading + INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = pvar , ktime = ktime, & + & cd_type = cd_type, psgn = psgn , kfill = kfill, & + & kstart = kstart , kcount = kcount ) + END IF + ENDIF + END SUBROUTINE iom_g3d_dp + + !!---------------------------------------------------------------------- + + SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , & + & cd_type, psgn, kfill, kstart, kcount ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_get_123d *** + !! + !! ** Purpose : read a 1D/2D/3D variable + !! + !! ** Method : read ONE record at each CALL + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kdom ! Type of domain to be read + CHARACTER(len=*) , INTENT(in ) :: cdvar ! Name of the variable + REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) + REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) + REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) + INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number + CHARACTER(len=1) , INTENT(in ), OPTIONAL :: cd_type ! nature of grid-points (T, U, V, F, W) + REAL(dp) , INTENT(in ), OPTIONAL :: psgn ! -1.(1.) : (not) change sign across the north fold + INTEGER , INTENT(in ), OPTIONAL :: kfill ! value of kfillmode in lbc_lbk + INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis + INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis + ! + LOGICAL :: llok ! true if ok! + INTEGER :: jl ! loop on number of dimension + INTEGER :: idom ! type of domain + INTEGER :: idvar ! id of the variable + INTEGER :: inbdim ! number of dimensions of the variable + INTEGER :: idmspc ! number of spatial dimensions + INTEGER :: itime ! record number + INTEGER :: istop ! temporary value of nstop + INTEGER :: ix1, ix2, iy1, iy2 ! subdomain indexes + INTEGER :: ji, jj ! loop counters + INTEGER :: irankpv ! + INTEGER :: ind1, ind2 ! substring index + INTEGER, DIMENSION(jpmax_dims) :: istart ! starting point to read for each axis + INTEGER, DIMENSION(jpmax_dims) :: icnt ! number of value to read along each axis + INTEGER, DIMENSION(jpmax_dims) :: idimsz ! size of the dimensions of the variable + INTEGER, DIMENSION(jpmax_dims) :: ishape ! size of the dimensions of the variable + REAL(dp) :: zscf, zofs ! sacle_factor and add_offset + REAL(dp) :: zsgn ! local value of psgn + INTEGER :: itmp ! temporary integer + CHARACTER(LEN=256) :: clinfo ! info character + CHARACTER(LEN=256) :: clname ! file name + CHARACTER(LEN=1) :: clrankpv, cldmspc ! + CHARACTER(LEN=1) :: cl_type ! local value of cd_type + LOGICAL :: ll_only3rd ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. + INTEGER :: inlev ! number of levels for 3D data + REAL(dp) :: gma, gmi + !--------------------------------------------------------------------- + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + inlev = -1 + IF( PRESENT(pv_r3d) ) inlev = SIZE(pv_r3d, 3) + ! + idom = kdom + istop = nstop + ! + IF(context == "NONE") THEN + clname = iom_file(kiomid)%name ! esier to read + clinfo = ' iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar) + ! check kcount and kstart optionals parameters... + IF( PRESENT(kcount) .AND. .NOT. PRESENT(kstart) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present') + IF( PRESENT(kstart) .AND. .NOT. PRESENT(kcount) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present') + IF( PRESENT(kstart) .AND. idom /= jpdom_unknown .AND. idom /= jpdom_auto_xy ) & + & CALL ctl_stop(TRIM(clinfo), 'kstart present needs idom = jpdom_unknown or idom = jpdom_auto_xy') + IF( idom == jpdom_auto_xy .AND. .NOT. PRESENT(kstart) ) & + & CALL ctl_stop(TRIM(clinfo), 'idom = jpdom_auto_xy requires kstart to be present') + ! + ! Search for the variable in the data base (eventually actualize data) + ! + idvar = iom_varid( kiomid, cdvar ) + IF( idvar > 0 ) THEN + ! + idimsz(:) = iom_file(kiomid)%dimsz(:, idvar) ! to write iom_file(kiomid)%dimsz in a shorter way + inbdim = iom_file(kiomid)%ndims(idvar) ! number of dimensions in the file + idmspc = inbdim ! number of spatial dimensions in the file + IF( iom_file(kiomid)%luld(idvar) ) idmspc = inbdim - 1 + IF( idmspc > 3 ) CALL ctl_stop(trim(clinfo), 'the file has more than 3 spatial dimensions this case is not coded...') + ! + ! Identify the domain in case of jpdom_auto definition + IF( idom == jpdom_auto .OR. idom == jpdom_auto_xy ) THEN + idom = jpdom_global ! default + ! else: if the file name finishes with _xxxx.nc with xxxx any number + ind1 = INDEX( clname, '_', back = .TRUE. ) + 1 + ind2 = INDEX( clname, '.', back = .TRUE. ) - 1 + IF( ind2 > ind1 ) THEN ; IF( VERIFY( clname(ind1:ind2), '0123456789' ) == 0 ) idom = jpdom_local ; ENDIF + ENDIF + ! + ! check the consistency between input array and data rank in the file + ! + ! initializations + itime = 1 + IF( PRESENT(ktime) ) itime = ktime + ! + irankpv = 1 * COUNT( (/PRESENT(pv_r1d)/) ) + 2 * COUNT( (/PRESENT(pv_r2d)/) ) + 3 * COUNT( (/PRESENT(pv_r3d)/) ) + WRITE(clrankpv, fmt='(i1)') irankpv + WRITE(cldmspc , fmt='(i1)') idmspc + ! + IF( idmspc < irankpv ) THEN ! it seems we want to read more than we can... + IF( irankpv == 3 .AND. idmspc == 2 ) THEN ! 3D input array from 2D spatial data in the file: + llok = inlev == 1 ! -> 3rd dimension must be equal to 1 + ELSEIF( irankpv == 3 .AND. idmspc == 1 ) THEN ! 3D input array from 1D spatial data in the file: + llok = inlev == 1 .AND. SIZE(pv_r3d, 2) == 1 ! -> 2nd and 3rd dimensions must be equal to 1 + ELSEIF( irankpv == 2 .AND. idmspc == 2 ) THEN ! 2D input array from 1D spatial data in the file: + llok = SIZE(pv_r2d, 2) == 1 ! -> 2nd dimension must be equal to 1 + ELSE + llok = .FALSE. + ENDIF + IF( .NOT. llok ) CALL ctl_stop( TRIM(clinfo), 'The file has only '//cldmspc//' spatial dimension', & + & '=> cannot read a true '//clrankpv//'D array from this file...' ) + ELSEIF( idmspc == irankpv ) THEN + IF( PRESENT(pv_r1d) .AND. idom /= jpdom_unknown ) & + & CALL ctl_stop( TRIM(clinfo), 'case not coded...You must use jpdom_unknown' ) + ELSEIF( idmspc > irankpv ) THEN ! it seems we want to read less than we should... + IF( PRESENT(pv_r2d) .AND. itime == 1 .AND. idimsz(3) == 1 .AND. idmspc == 3 ) THEN + CALL ctl_warn( trim(clinfo), '2D array input but 3 spatial dimensions in the file...' , & + & 'As the size of the z dimension is 1 and as we try to read the first record, ', & + & 'we accept this case, even if there is a possible mix-up between z and time dimension' ) + idmspc = idmspc - 1 + !!GS: possibility to read 3D ABL atmopsheric forcing and use 1st level to force BULK simulation + !ELSE + ! CALL ctl_stop( TRIM(clinfo), 'To keep iom lisibility, when reading a '//clrankpv//'D array,', & + ! & 'we do not accept data with '//cldmspc//' spatial dimensions' , & + ! & 'Use ncwa -a to suppress the unnecessary dimensions' ) + ENDIF + ENDIF + ! + ! definition of istart and icnt + ! + icnt (:) = 1 ! default definition (simple way to deal with special cases listed above) + istart(:) = 1 ! default definition (simple way to deal with special cases listed above) + istart(idmspc+1) = itime ! temporal dimenstion + ! + IF( idom == jpdom_unknown ) THEN + IF( PRESENT(kstart) .AND. idom /= jpdom_auto_xy ) THEN + istart(1:idmspc) = kstart(1:idmspc) + icnt (1:idmspc) = kcount(1:idmspc) + ELSE + icnt (1:idmspc) = idimsz(1:idmspc) + ENDIF + ELSE ! not a 1D array as pv_r1d requires jpdom_unknown + ! we do not read the overlap and the extra-halos -> from Nis0 to Nie0 and from Njs0 to Nje0 + IF( idom == jpdom_global ) istart(1:2) = (/ mig0(Nis0), mjg0(Njs0) /) + icnt(1:2) = (/ Ni_0, Nj_0 /) + IF( PRESENT(pv_r3d) ) THEN + IF( idom == jpdom_auto_xy ) THEN + istart(3) = kstart(3) + icnt (3) = kcount(3) + ELSE + icnt (3) = inlev + ENDIF + ENDIF + ENDIF + ! + ! check that istart and icnt can be used with this file + !- + DO jl = 1, jpmax_dims + itmp = istart(jl)+icnt(jl)-1 + IF( itmp > idimsz(jl) .AND. idimsz(jl) /= 0 ) THEN + WRITE( ctmp1, FMT="('(istart(', i1, ') + icnt(', i1, ') - 1) = ', i5)" ) jl, jl, itmp + WRITE( ctmp2, FMT="(' is larger than idimsz(', i1,') = ', i5)" ) jl, idimsz(jl) + CALL ctl_stop( trim(clinfo), 'start and count too big regarding to the size of the data, ', ctmp1, ctmp2 ) + ENDIF + END DO + ! + ! check that icnt matches the input array + !- + IF( idom == jpdom_unknown ) THEN + IF( irankpv == 1 ) ishape(1:1) = SHAPE(pv_r1d) + IF( irankpv == 2 ) ishape(1:2) = SHAPE(pv_r2d) + IF( irankpv == 3 ) ishape(1:3) = SHAPE(pv_r3d) + ctmp1 = 'd' + ELSE + IF( irankpv == 2 ) THEN + ishape(1:2) = SHAPE(pv_r2d(Nis0:Nie0,Njs0:Nje0 )) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0)' + ENDIF + IF( irankpv == 3 ) THEN + ishape(1:3) = SHAPE(pv_r3d(Nis0:Nie0,Njs0:Nje0,:)) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0,:)' + ENDIF + ENDIF + DO jl = 1, irankpv + WRITE( ctmp2, FMT="(', ', i1,'): ', i5,' /= icnt(', i1,'):', i5)" ) jl, ishape(jl), jl, icnt(jl) + IF( ishape(jl) /= icnt(jl) ) CALL ctl_stop( TRIM(clinfo), 'size(pv_r'//clrankpv//TRIM(ctmp1)//TRIM(ctmp2) ) + END DO + + ENDIF + + ! read the data + !- + IF( idvar > 0 .AND. istop == nstop ) THEN ! no additional errors until this point... + ! + ! find the right index of the array to be read + IF( idom /= jpdom_unknown ) THEN ; ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0 + ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) + ENDIF + + CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, pv_r3d ) + + IF( istop == nstop ) THEN ! no additional errors until this point... + IF(lwp) WRITE(numout,"(10x,' read ',a,' (rec: ',i6,') in ',a,' ok')") TRIM(cdvar), itime, TRIM(iom_file(kiomid)%name) + + cl_type = 'T' + IF( PRESENT(cd_type) ) cl_type = cd_type + zsgn = 1._wp + IF( PRESENT(psgn ) ) zsgn = psgn + !--- overlap areas and extra hallows (mpp) + IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN + CALL lbc_lnk( 'iom', pv_r2d, cl_type, zsgn, kfillmode = kfill ) + ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN + CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill ) + ENDIF + ! + ELSE + ! return if istop == nstop is false + RETURN + ENDIF + ELSE + ! return if statment idvar > 0 .AND. istop == nstop is false + RETURN + ENDIF + ! + ELSE ! read using XIOS. Only if key_xios is defined +#if defined key_xios +!would be good to be able to check which context is active and swap only if current is not restart + idvar = iom_varid( kiomid, cdvar ) + CALL iom_swap(context) + zsgn = 1._wp + IF( PRESENT(psgn ) ) zsgn = psgn + cl_type = 'T' + IF( PRESENT(cd_type) ) cl_type = cd_type + + IF( PRESENT(pv_r3d) ) THEN + IF(lwp) WRITE(numout,*) 'XIOS RST READ (3D): ',TRIM(cdvar) + CALL xios_recv_field( trim(cdvar), pv_r3d(:, :, :)) + IF(idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN + CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill) + ENDIF + ELSEIF( PRESENT(pv_r2d) ) THEN + IF(lwp) WRITE(numout,*) 'XIOS RST READ (2D): ', TRIM(cdvar) + CALL xios_recv_field( trim(cdvar), pv_r2d(:, :)) + IF(idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN + CALL lbc_lnk('iom', pv_r2d, cl_type, zsgn, kfillmode = kfill) + ENDIF + ELSEIF( PRESENT(pv_r1d) ) THEN + IF(lwp) WRITE(numout,*) 'XIOS RST READ (1D): ', TRIM(cdvar) + CALL xios_recv_field( trim(cdvar), pv_r1d) + ENDIF + CALL iom_swap(cxios_context) +#else + istop = istop + 1 + clinfo = 'Can not use XIOS in iom_get_123d, file: '//trim(clname)//', var:'//trim(cdvar) +#endif + ENDIF + + !--- Apply scale_factor and offset + zscf = iom_file(kiomid)%scf(idvar) ! scale factor + zofs = iom_file(kiomid)%ofs(idvar) ! offset + IF( PRESENT(pv_r1d) ) THEN + IF( zscf /= 1._wp ) pv_r1d(:) = pv_r1d(:) * zscf + IF( zofs /= 0._wp ) pv_r1d(:) = pv_r1d(:) + zofs + ELSEIF( PRESENT(pv_r2d) ) THEN + IF( zscf /= 1._wp) pv_r2d(:,:) = pv_r2d(:,:) * zscf + IF( zofs /= 0._wp) pv_r2d(:,:) = pv_r2d(:,:) + zofs + ELSEIF( PRESENT(pv_r3d) ) THEN + IF( zscf /= 1._wp) pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf + IF( zofs /= 0._wp) pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs + ENDIF + ! + END SUBROUTINE iom_get_123d + + SUBROUTINE iom_get_var( cdname, z2d) + CHARACTER(LEN=*), INTENT(in ) :: cdname + REAL(wp), DIMENSION(jpi,jpj) :: z2d +#if defined key_xios + IF( xios_field_is_active( cdname, at_current_timestep_arg = .TRUE. ) ) THEN + z2d(:,:) = 0._wp + CALL xios_recv_field( cdname, z2d) + ENDIF +#else + IF( .FALSE. ) WRITE(numout,*) cdname, z2d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_get_var + + + FUNCTION iom_getszuld ( kiomid ) + !!----------------------------------------------------------------------- + !! *** FUNCTION iom_getszuld *** + !! + !! ** Purpose : get the size of the unlimited dimension in a file + !! (return -1 if not found) + !!----------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kiomid ! file Identifier + ! + INTEGER :: iom_getszuld + !!----------------------------------------------------------------------- + iom_getszuld = -1 + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%iduld > 0 ) iom_getszuld = iom_file(kiomid)%lenuld + ENDIF + END FUNCTION iom_getszuld + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_chkatt + !!---------------------------------------------------------------------- + SUBROUTINE iom_chkatt( kiomid, cdatt, llok, ksize, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdatt ! Name of the attribute + LOGICAL , INTENT( out) :: llok ! Error code + INTEGER , INTENT( out), OPTIONAL :: ksize ! Size of the attribute array + CHARACTER(len=*), INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_chkatt( kiomid, cdatt, llok, ksize=ksize, cdvar=cdvar ) + ENDIF + ! + END SUBROUTINE iom_chkatt + + !!---------------------------------------------------------------------- + !! INTERFACE iom_getatt + !!---------------------------------------------------------------------- + SUBROUTINE iom_g0d_iatt( kiomid, cdatt, katt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER , INTENT( out) :: katt0d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, katt0d = katt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g0d_iatt + + SUBROUTINE iom_g1d_iatt( kiomid, cdatt, katt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER, DIMENSION(:) , INTENT( out) :: katt1d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, katt1d = katt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g1d_iatt + + SUBROUTINE iom_g0d_ratt( kiomid, cdatt, patt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp) , INTENT( out) :: patt0d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, patt0d = patt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g0d_ratt + + SUBROUTINE iom_g1d_ratt( kiomid, cdatt, patt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp), DIMENSION(:), INTENT( out) :: patt1d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, patt1d = patt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g1d_ratt + + SUBROUTINE iom_g0d_catt( kiomid, cdatt, cdatt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + CHARACTER(len=*) , INTENT( out) :: cdatt0d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, cdatt0d = cdatt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g0d_catt + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_putatt + !!---------------------------------------------------------------------- + SUBROUTINE iom_p0d_iatt( kiomid, cdatt, katt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER , INTENT(in ) :: katt0d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, katt0d = katt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p0d_iatt + + SUBROUTINE iom_p1d_iatt( kiomid, cdatt, katt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER, DIMENSION(:) , INTENT(in ) :: katt1d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, katt1d = katt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p1d_iatt + + SUBROUTINE iom_p0d_ratt( kiomid, cdatt, patt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp) , INTENT(in ) :: patt0d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, patt0d = patt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p0d_ratt + + SUBROUTINE iom_p1d_ratt( kiomid, cdatt, patt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp), DIMENSION(:), INTENT(in ) :: patt1d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, patt1d = patt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p1d_ratt + + SUBROUTINE iom_p0d_catt( kiomid, cdatt, cdatt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + CHARACTER(len=*) , INTENT(in ) :: cdatt0d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, cdatt0d = cdatt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p0d_catt + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_rstput + !!---------------------------------------------------------------------- + SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(sp) , INTENT(in) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) + CALL iom_swap(context) + CALL iom_put(trim(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 0D) ',trim(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( trim(cdvar), rs0 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = real(pvar, dp) ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp0d_sp + + SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(dp) , INTENT(in) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) + CALL iom_swap(context) + CALL iom_put(trim(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 0D) ',trim(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( trim(cdvar), rd0 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp0d_dp + + + SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(sp) , INTENT(in), DIMENSION( :) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) + CALL iom_swap(context) + CALL iom_put(trim(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 1D)',trim(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( trim(cdvar), rs1 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = real(pvar, dp) ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp1d_sp + + SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(dp) , INTENT(in), DIMENSION( :) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) + CALL iom_swap(context) + CALL iom_put(trim(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 1D)',trim(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( trim(cdvar), rd1 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp1d_dp + + + SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(sp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) + CALL iom_swap(context) + CALL iom_put(trim(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 2D)',trim(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( trim(cdvar), rs2 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = real(pvar, dp) ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp2d_sp + + SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(dp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) + CALL iom_swap(context) + CALL iom_put(trim(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 2D)',trim(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( trim(cdvar), rd2 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp2d_dp + + + SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(sp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) + CALL iom_swap(context) + CALL iom_put(trim(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 3D)',trim(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( trim(cdvar), rs3 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = real(pvar, dp) ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp3d_sp + + SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in) :: cdvar ! time axis name + REAL(dp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + ! + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + CHARACTER(LEN=lc) :: context + ! + CALL set_xios_context(kiomid, context) + + llx = .NOT. (context == "NONE") + + IF( llx ) THEN +#ifdef key_xios + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) + CALL iom_swap(context) + CALL iom_put(trim(cdvar), pvar) + CALL iom_swap(cxios_context) + ELSE + IF(lwp) write(numout,*) 'RESTART: define (XIOS 3D)',trim(cdvar) + CALL iom_swap(context) + CALL iom_set_rstw_active( trim(cdvar), rd3 = pvar ) + CALL iom_swap(cxios_context) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp3d_dp + + + + SUBROUTINE iom_delay_rst( cdaction, cdcpnt, kncid ) + !!--------------------------------------------------------------------- + !! Routine iom_delay_rst: used read/write restart related to mpp_delay + !! + !!--------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdaction ! + CHARACTER(len=*), INTENT(in ) :: cdcpnt + INTEGER , INTENT(in ) :: kncid + ! + INTEGER :: ji + INTEGER :: indim + LOGICAL :: llattexist + REAL(wp), ALLOCATABLE, DIMENSION(:) :: zreal1d + !!--------------------------------------------------------------------- + ! + ! =================================== + IF( TRIM(cdaction) == 'READ' ) THEN ! read restart related to mpp_delay ! + ! =================================== + DO ji = 1, nbdelay + IF ( c_delaycpnt(ji) == cdcpnt ) THEN + CALL iom_chkatt( kncid, 'DELAY_'//c_delaylist(ji), llattexist, indim ) + IF( llattexist ) THEN + ALLOCATE( todelay(ji)%z1d(indim) ) + CALL iom_getatt( kncid, 'DELAY_'//c_delaylist(ji), todelay(ji)%z1d(:) ) + ndelayid(ji) = 0 ! set to 0 to specify that the value was read in the restart + ENDIF + ENDIF + END DO + ! ==================================== + ELSE ! write restart related to mpp_delay ! + ! ==================================== + DO ji = 1, nbdelay ! save only ocean delayed global communication variables + IF ( c_delaycpnt(ji) == cdcpnt ) THEN + IF( ASSOCIATED(todelay(ji)%z1d) ) THEN + CALL mpp_delay_rcv(ji) ! make sure %z1d is received + CALL iom_putatt( kncid, 'DELAY_'//c_delaylist(ji), todelay(ji)%z1d(:) ) + ENDIF + ENDIF + END DO + ! + ENDIF + + END SUBROUTINE iom_delay_rst + + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_put + !!---------------------------------------------------------------------- + SUBROUTINE iom_p0d_sp( cdname, pfield0d ) + CHARACTER(LEN=*), INTENT(in) :: cdname + REAL(sp) , INTENT(in) :: pfield0d + !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson +#if defined key_xios +!!clem zz(:,:)=pfield0d +!!clem CALL xios_send_field(cdname, zz) + CALL xios_send_field(cdname, (/pfield0d/)) +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p0d_sp + + SUBROUTINE iom_p0d_dp( cdname, pfield0d ) + CHARACTER(LEN=*), INTENT(in) :: cdname + REAL(dp) , INTENT(in) :: pfield0d +!! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson +#if defined key_xios +!!clem zz(:,:)=pfield0d +!!clem CALL xios_send_field(cdname, zz) + CALL xios_send_field(cdname, (/pfield0d/)) +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p0d_dp + + + SUBROUTINE iom_p1d_sp( cdname, pfield1d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(sp), DIMENSION(:), INTENT(in) :: pfield1d +#if defined key_xios + CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p1d_sp + + SUBROUTINE iom_p1d_dp( cdname, pfield1d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(dp), DIMENSION(:), INTENT(in) :: pfield1d +#if defined key_xios + CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p1d_dp + + SUBROUTINE iom_p2d_sp( cdname, pfield2d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(sp), DIMENSION(:,:), INTENT(in) :: pfield2d + IF( iom_use(cdname) ) THEN +#if defined key_xios + IF( is_tile(pfield2d) == 1 ) THEN + CALL xios_send_field( cdname, pfield2d, ntile - 1 ) + ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + CALL xios_send_field( cdname, pfield2d ) + ENDIF +#else + WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings +#endif + ENDIF + END SUBROUTINE iom_p2d_sp + + SUBROUTINE iom_p2d_dp( cdname, pfield2d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(dp), DIMENSION(:,:), INTENT(in) :: pfield2d + IF( iom_use(cdname) ) THEN +#if defined key_xios + IF( is_tile(pfield2d) == 1 ) THEN + CALL xios_send_field( cdname, pfield2d, ntile - 1 ) + ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + CALL xios_send_field( cdname, pfield2d ) + ENDIF +#else + WRITE(numout,*) pfield2d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings +#endif + ENDIF + END SUBROUTINE iom_p2d_dp + + SUBROUTINE iom_p3d_sp( cdname, pfield3d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(sp), DIMENSION(:,:,:), INTENT(in) :: pfield3d + IF( iom_use(cdname) ) THEN +#if defined key_xios + IF( is_tile(pfield3d) == 1 ) THEN + CALL xios_send_field( cdname, pfield3d, ntile - 1 ) + ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + CALL xios_send_field( cdname, pfield3d ) + ENDIF +#else + WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings +#endif + ENDIF + END SUBROUTINE iom_p3d_sp + + SUBROUTINE iom_p3d_dp( cdname, pfield3d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(dp), DIMENSION(:,:,:), INTENT(in) :: pfield3d + IF( iom_use(cdname) ) THEN +#if defined key_xios + IF( is_tile(pfield3d) == 1 ) THEN + CALL xios_send_field( cdname, pfield3d, ntile - 1 ) + ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + CALL xios_send_field( cdname, pfield3d ) + ENDIF +#else + WRITE(numout,*) pfield3d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings +#endif + ENDIF + END SUBROUTINE iom_p3d_dp + + SUBROUTINE iom_p4d_sp( cdname, pfield4d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(sp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d + IF( iom_use(cdname) ) THEN +#if defined key_xios + IF( is_tile(pfield4d) == 1 ) THEN + CALL xios_send_field( cdname, pfield4d, ntile - 1 ) + ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + CALL xios_send_field( cdname, pfield4d ) + ENDIF +#else + WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings +#endif + ENDIF + END SUBROUTINE iom_p4d_sp + + SUBROUTINE iom_p4d_dp( cdname, pfield4d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d + IF( iom_use(cdname) ) THEN +#if defined key_xios + IF( is_tile(pfield4d) == 1 ) THEN + CALL xios_send_field( cdname, pfield4d, ntile - 1 ) + ELSE IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN + CALL xios_send_field( cdname, pfield4d ) + ENDIF +#else + WRITE(numout,*) pfield4d ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings +#endif + ENDIF + END SUBROUTINE iom_p4d_dp + +#if defined key_xios + !!---------------------------------------------------------------------- + !! 'key_xios' XIOS interface + !!---------------------------------------------------------------------- + + SUBROUTINE iom_set_domain_attr( cdid, ni_glo, nj_glo, ibegin, jbegin, ni, nj, & + & data_dim, data_ibegin, data_ni, data_jbegin, data_nj, lonvalue, latvalue, mask, & + & ntiles, tile_ibegin, tile_jbegin, tile_ni, tile_nj, & + & tile_data_ibegin, tile_data_jbegin, tile_data_ni, tile_data_nj, & + & nvertex, bounds_lon, bounds_lat, area ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in) :: cdid + INTEGER , OPTIONAL, INTENT(in) :: ni_glo, nj_glo, ibegin, jbegin, ni, nj + INTEGER, DIMENSION(:) , OPTIONAL, INTENT(in) :: tile_ibegin, tile_jbegin, tile_ni, tile_nj + INTEGER, DIMENSION(:) , OPTIONAL, INTENT(in) :: tile_data_ibegin, tile_data_jbegin, tile_data_ni, tile_data_nj + INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj + INTEGER , OPTIONAL, INTENT(in) :: nvertex, ntiles + REAL(dp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue + REAL(dp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area + LOGICAL , DIMENSION(:) , OPTIONAL, INTENT(in) :: mask + !!---------------------------------------------------------------------- + ! + IF( xios_is_valid_domain (cdid) ) THEN + CALL xios_set_domain_attr ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & + & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & + & ntiles=ntiles, tile_ibegin=tile_ibegin, tile_jbegin=tile_jbegin, tile_ni=tile_ni, tile_nj=tile_nj, & + & tile_data_ibegin=tile_data_ibegin, tile_data_jbegin=tile_data_jbegin, & + & tile_data_ni=tile_data_ni, tile_data_nj=tile_data_nj, & + & lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon, & + & bounds_lat_1D=bounds_lat, area=area, type='curvilinear') + ENDIF + IF( xios_is_valid_domaingroup(cdid) ) THEN + CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & + & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & + & ntiles=ntiles, tile_ibegin=tile_ibegin, tile_jbegin=tile_jbegin, tile_ni=tile_ni, tile_nj=tile_nj, & + & tile_data_ibegin=tile_data_ibegin, tile_data_jbegin=tile_data_jbegin, & + & tile_data_ni=tile_data_ni, tile_data_nj=tile_data_nj, & + & lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon, & + & bounds_lat_1D=bounds_lat, area=area, type='curvilinear' ) + ENDIF + ! + CALL xios_solve_inheritance() + ! + END SUBROUTINE iom_set_domain_attr + + + SUBROUTINE iom_set_zoom_domain_attr( cdid, ibegin, jbegin, ni, nj ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*), INTENT(in) :: cdid + INTEGER , INTENT(in) :: ibegin, jbegin, ni, nj + ! + TYPE(xios_gridgroup) :: gridgroup_hdl + TYPE(xios_grid) :: grid_hdl + TYPE(xios_domain) :: domain_hdl + TYPE(xios_axis) :: axis_hdl + CHARACTER(LEN=64) :: cldomrefid ! domain_ref name + CHARACTER(len=1) :: cl1 ! last character of this name + !!---------------------------------------------------------------------- + ! + IF( xios_is_valid_zoom_domain(cdid) ) THEN + ! define the zoom_domain attributs + CALL xios_set_zoom_domain_attr( cdid, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj ) + ! define a new 2D grid with this new domain + CALL xios_get_handle("grid_definition", gridgroup_hdl ) + CALL xios_add_child(gridgroup_hdl, grid_hdl, TRIM(cdid)//'_2D' ) ! add a new 2D grid to grid_definition + CALL xios_add_child(grid_hdl, domain_hdl, TRIM(cdid) ) ! add its domain + ! define a new 3D grid with this new domain + CALL xios_add_child(gridgroup_hdl, grid_hdl, TRIM(cdid)//'_3D' ) ! add a new 3D grid to grid_definition + CALL xios_add_child(grid_hdl, domain_hdl, TRIM(cdid) ) ! add its domain + ! vertical axis + cl1 = cdid(LEN_TRIM(cdid):) ! last letter of cdid + cl1 = CHAR(ICHAR(cl1)+32) ! from upper to lower case + CALL xios_add_child(grid_hdl, axis_hdl, 'depth'//cl1) ! add its axis + ENDIF + ! + END SUBROUTINE iom_set_zoom_domain_attr + + + SUBROUTINE iom_set_axis_attr( cdid, paxis, bounds ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in) :: cdid + REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: paxis + REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds + !!---------------------------------------------------------------------- + IF( PRESENT(paxis) ) THEN + IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) + IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) + ENDIF + IF( PRESENT(bounds) ) THEN + IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=real(bounds, dp) ) + IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=real(bounds, dp) ) + ELSE + IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid) + IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid) + END IF + CALL xios_solve_inheritance() + END SUBROUTINE iom_set_axis_attr + + + SUBROUTINE iom_set_field_attr( cdid, freq_op, freq_offset ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in) :: cdid + TYPE(xios_duration), OPTIONAL, INTENT(in) :: freq_op + TYPE(xios_duration), OPTIONAL, INTENT(in) :: freq_offset + !!---------------------------------------------------------------------- + IF( xios_is_valid_field (cdid) ) CALL xios_set_field_attr ( cdid, freq_op=freq_op, freq_offset=freq_offset ) + IF( xios_is_valid_fieldgroup(cdid) ) CALL xios_set_fieldgroup_attr( cdid, freq_op=freq_op, freq_offset=freq_offset ) + CALL xios_solve_inheritance() + END SUBROUTINE iom_set_field_attr + + + SUBROUTINE iom_set_file_attr( cdid, name, name_suffix ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in) :: cdid + CHARACTER(LEN=*),OPTIONAL , INTENT(in) :: name, name_suffix + !!---------------------------------------------------------------------- + IF( xios_is_valid_file (cdid) ) CALL xios_set_file_attr ( cdid, name=name, name_suffix=name_suffix ) + IF( xios_is_valid_filegroup(cdid) ) CALL xios_set_filegroup_attr( cdid, name=name, name_suffix=name_suffix ) + CALL xios_solve_inheritance() + END SUBROUTINE iom_set_file_attr + + + SUBROUTINE iom_get_file_attr( cdid, name, name_suffix, output_freq ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in ) :: cdid + CHARACTER(LEN=*),OPTIONAL , INTENT(out) :: name, name_suffix + TYPE(xios_duration), OPTIONAL , INTENT(out) :: output_freq + LOGICAL :: llexist1,llexist2,llexist3 + !--------------------------------------------------------------------- + IF( PRESENT( name ) ) name = '' ! default values + IF( PRESENT( name_suffix ) ) name_suffix = '' + IF( PRESENT( output_freq ) ) output_freq = xios_duration(0,0,0,0,0,0) + IF( xios_is_valid_file (cdid) ) THEN + CALL xios_solve_inheritance() + CALL xios_is_defined_file_attr ( cdid, name = llexist1, name_suffix = llexist2, output_freq = llexist3) + IF(llexist1) CALL xios_get_file_attr ( cdid, name = name ) + IF(llexist2) CALL xios_get_file_attr ( cdid, name_suffix = name_suffix ) + IF(llexist3) CALL xios_get_file_attr ( cdid, output_freq = output_freq ) + ENDIF + IF( xios_is_valid_filegroup(cdid) ) THEN + CALL xios_solve_inheritance() + CALL xios_is_defined_filegroup_attr( cdid, name = llexist1, name_suffix = llexist2, output_freq = llexist3) + IF(llexist1) CALL xios_get_filegroup_attr( cdid, name = name ) + IF(llexist2) CALL xios_get_filegroup_attr( cdid, name_suffix = name_suffix ) + IF(llexist3) CALL xios_get_filegroup_attr( cdid, output_freq = output_freq ) + ENDIF + END SUBROUTINE iom_get_file_attr + + + SUBROUTINE iom_set_grid_attr( cdid, mask ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in) :: cdid + LOGICAL, DIMENSION(:,:,:), OPTIONAL, INTENT(in) :: mask + !!---------------------------------------------------------------------- + IF( xios_is_valid_grid (cdid) ) CALL xios_set_grid_attr ( cdid, mask_3D=mask ) + IF( xios_is_valid_gridgroup(cdid) ) CALL xios_set_gridgroup_attr( cdid, mask_3D=mask ) + CALL xios_solve_inheritance() + END SUBROUTINE iom_set_grid_attr + + SUBROUTINE iom_setkt( kt, cdname ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt + CHARACTER(LEN=*), INTENT(in) :: cdname + !!---------------------------------------------------------------------- + CALL iom_swap( cdname ) ! swap to cdname context + CALL xios_update_calendar(kt) + IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( cxios_context ) ! return back to nemo context + END SUBROUTINE iom_setkt + + SUBROUTINE iom_context_finalize( cdname ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*), INTENT(in) :: cdname + CHARACTER(LEN=120) :: clname + !!---------------------------------------------------------------------- + clname = cdname + IF( TRIM(Agrif_CFixed()) .NE. '0' ) clname = TRIM(Agrif_CFixed())//"_"//clname + IF( xios_is_valid_context(clname) ) THEN + CALL iom_swap( cdname ) ! swap to cdname context + CALL xios_context_finalize() ! finalize the context + IF( cdname /= cxios_context ) CALL iom_swap( cxios_context ) ! return back to nemo context + ENDIF + ! + END SUBROUTINE iom_context_finalize + + + SUBROUTINE set_grid( cdgrd, plon, plat, ldxios, ldrxios ) + !!---------------------------------------------------------------------- + !! *** ROUTINE set_grid *** + !! + !! ** Purpose : define horizontal grids + !!---------------------------------------------------------------------- + CHARACTER(LEN=1) , INTENT(in) :: cdgrd + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plon + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat + ! + REAL(wp), DIMENSION(A2D(0),jpk) :: zmask + INTEGER :: jn + INTEGER, DIMENSION(nijtile) :: ini, inj, idb + LOGICAL, INTENT(IN) :: ldxios, ldrxios + !!---------------------------------------------------------------------- + ! + CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=Ni0glo,nj_glo=Nj0glo,ibegin=mig0(Nis0)-1,jbegin=mjg0(Njs0)-1,ni=Ni_0,nj=Nj_0) + CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = -nn_hls, data_ni=jpi, data_jbegin = -nn_hls, data_nj=jpj) + + CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", ni_glo = Ni0glo, nj_glo = Nj0glo, & + & ibegin = mig0(Nis0) - 1, jbegin = mjg0(Njs0) - 1, ni = Ni_0, nj = Nj_0) + CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", data_dim=2, data_ibegin = 0, data_ni=Ni_0, data_jbegin = 0, data_nj=Nj_0) + + IF( ln_tile ) THEN + DO jn = 1, nijtile + ini(jn) = ntei_a(jn) - ntsi_a(jn) + 1 ! Tile size in i and j + inj(jn) = ntej_a(jn) - ntsj_a(jn) + 1 + idb(jn) = -nn_hls ! Tile data offset (halo size) + END DO + + ! Tile_[ij]begin are defined with respect to the processor data domain, so data_[ij]begin is added + CALL iom_set_domain_attr("grid_"//cdgrd, ntiles=nijtile, & + & tile_ibegin=ntsi_a(1:nijtile) + idb(:) - 1, tile_jbegin=ntsj_a(1:nijtile) + idb(:) - 1, & + & tile_ni=ini(:), tile_nj=inj(:), & + & tile_data_ibegin=idb(:), tile_data_jbegin=idb(:), & + & tile_data_ni=ini(:) - 2 * idb(:), tile_data_nj=inj(:) - 2 * idb(:)) + CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", ntiles=nijtile, & + & tile_ibegin=ntsi_a(1:nijtile) + idb(:) - 1, tile_jbegin=ntsj_a(1:nijtile) + idb(:) - 1, & + & tile_ni=ini(:), tile_nj=inj(:), & + & tile_data_ibegin=idb(:), tile_data_jbegin=idb(:), & + & tile_data_ni=ini(:) - 2 * idb(:), tile_data_nj=inj(:) - 2 * idb(:)) + ENDIF + +!don't define lon and lat for restart reading context. + IF ( .NOT.ldrxios ) & + CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = real(RESHAPE(plon(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp), & + & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp )) + ! + IF ( ln_mskland .AND. (.NOT.ldxios) ) THEN + ! mask land points, keep values on coast line -> specific mask for U, V and W points + SELECT CASE ( cdgrd ) + CASE('T') ; zmask(:,:,:) = tmask(Nis0 :Nie0 , Njs0:Nje0,:) + CASE('U') ; zmask(:,:,:) = tmask(Nis0 :Nie0 , Njs0:Nje0,:) + tmask(Nis0+1:Nie0+1, Njs0 :Nje0 ,:) + CASE('V') ; zmask(:,:,:) = tmask(Nis0 :Nie0 , Njs0:Nje0,:) + tmask(Nis0 :Nie0 , Njs0+1:Nje0+1,:) + CASE('F') ; zmask(:,:,:) = tmask(Nis0 :Nie0 , Njs0:Nje0,:) + tmask(Nis0 :Nie0 , Njs0+1:Nje0+1,:) & + & + tmask(Nis0+1:Nie0+1, Njs0:Nje0,:) + tmask(Nis0+1:Nie0+1, Njs0+1:Nje0+1,:) + CASE('W') ; zmask(:,:,2:jpk) = tmask(Nis0:Nie0, Njs0:Nje0,1:jpkm1) + tmask(Nis0:Nie0, Njs0:Nje0,2:jpk) + zmask(:,:,1 ) = tmask(Nis0:Nie0, Njs0:Nje0,1) + END SELECT + ! + CALL iom_set_domain_attr( "grid_"//cdgrd , mask=RESHAPE(zmask(:,:,1),(/Ni_0*Nj_0 /)) /= 0. ) + CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D" , mask=RESHAPE(zmask(:,:,:),(/Ni_0,Nj_0,jpk/)) /= 0. ) + CALL iom_set_domain_attr( "grid_"//cdgrd//"_inner" , mask=RESHAPE(zmask(:,:,1),(/Ni_0*Nj_0 /)) /= 0. ) + CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D_inner", mask=RESHAPE(zmask(:,:,:),(/Ni_0,Nj_0,jpk/)) /= 0. ) + ENDIF + ! + END SUBROUTINE set_grid + + SUBROUTINE set_grid_bounds( cdgrd, plon_cnr, plat_cnr, plon_pnt, plat_pnt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE set_grid_bounds *** + !! + !! ** Purpose : define horizontal grid corners + !! + !!---------------------------------------------------------------------- + CHARACTER(LEN=1) , INTENT(in) :: cdgrd + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: plon_cnr, plat_cnr ! Lat/lon coord. of a contiguous vertex of cell (i,j) + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: plon_pnt, plat_pnt ! Lat/lon coord. of the point of cell (i,j) + ! + INTEGER :: ji, jj, jn + INTEGER :: icnr, jcnr ! Offset such that the vertex coordinate (i+icnr,j+jcnr) + ! ! represents the + ! bottom-left corner of + ! cell (i,j) + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: z_bnds ! Lat/lon coordinates of the vertices of cell (i,j) + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_fld ! Working array to determine where to rotate cells + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_rot ! Lat/lon working array for rotation of cells + !!---------------------------------------------------------------------- + ! + ALLOCATE( z_bnds(4,jpi,jpj,2), z_fld(jpi,jpj), z_rot(4,2) ) + ! + ! Offset of coordinate representing bottom-left corner + SELECT CASE ( TRIM(cdgrd) ) + CASE ('T', 'W') ; icnr = -1 ; jcnr = -1 + CASE ('U') ; icnr = 0 ; jcnr = -1 + CASE ('V') ; icnr = -1 ; jcnr = 0 + CASE ('F') ; icnr = 0 ; jcnr = 0 + END SELECT + ! + z_fld(:,:) = 1._wp + CALL lbc_lnk( 'iom', z_fld, cdgrd, -1.0_wp ) ! Working array for location of northfold + ! + ! Cell vertices that can be defined + DO_2D( 0, 0, 0, 0 ) + z_bnds(1,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr ) ! Bottom-left + z_bnds(2,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right + z_bnds(3,ji,jj,1) = plat_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right + z_bnds(4,ji,jj,1) = plat_cnr(ji+icnr, jj+jcnr+1) ! Top-left + z_bnds(1,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr ) ! Bottom-left + z_bnds(2,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr ) ! Bottom-right + z_bnds(3,ji,jj,2) = plon_cnr(ji+icnr+1,jj+jcnr+1) ! Top-right + z_bnds(4,ji,jj,2) = plon_cnr(ji+icnr, jj+jcnr+1) ! Top-left + END_2D + ! + DO_2D( 0, 0, 0, 0 ) + IF( z_fld(ji,jj) == -1. ) THEN + z_rot(1,:) = z_bnds(3,ji,jj,:) ; z_rot(2,:) = z_bnds(4,ji,jj,:) + z_rot(3,:) = z_bnds(1,ji,jj,:) ; z_rot(4,:) = z_bnds(2,ji,jj,:) + z_bnds(:,ji,jj,:) = z_rot(:,:) + ENDIF + END_2D + ! + CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = real(RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,1),(/ 4,Ni_0*Nj_0 /)), dp), & + & bounds_lon = real(RESHAPE(z_bnds(:,Nis0:Nie0,Njs0:Nje0,2),(/ 4,Ni_0*Nj_0 /)), dp), nvertex=4 ) + ! + DEALLOCATE( z_bnds, z_fld, z_rot ) + ! + END SUBROUTINE set_grid_bounds + + SUBROUTINE set_grid_znl( plat ) + !!---------------------------------------------------------------------- + !! *** ROUTINE set_grid_znl *** + !! + !! ** Purpose : define grids for zonal mean + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: plat + ! + INTEGER :: ix, iy + REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon + !!---------------------------------------------------------------------- + ! + ALLOCATE( zlon(Ni_0*Nj_0) ) ; zlon(:) = 0._wp + ! +! CALL dom_ngb( -168.53_wp, 65.03_wp, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) + CALL dom_ngb( 180.0_wp, 90.0_wp, ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) + CALL iom_set_domain_attr("gznl", ni_glo=Ni0glo, nj_glo=Nj0glo, ibegin=mig0(Nis0)-1, jbegin=mjg0(Njs0)-1, ni=Ni_0, nj=Nj_0) + CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = -nn_hls, data_ni = jpi, data_jbegin = -nn_hls, data_nj = jpj) + CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp), & + & latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp)) + CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=Nj0glo) + ! + CALL iom_update_file_name('ptr') + ! + END SUBROUTINE set_grid_znl + + + SUBROUTINE set_scalar + !!---------------------------------------------------------------------- + !! *** ROUTINE set_scalar *** + !! + !! ** Purpose : define fake grids for scalar point + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(1) :: zz = 1. + !!---------------------------------------------------------------------- + ! + CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea-1, jbegin=0, ni=1, nj=1) + CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) + ! + zz = REAL( narea, wp ) + CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) + ! + END SUBROUTINE set_scalar + + + SUBROUTINE set_xmlatt + !!---------------------------------------------------------------------- + !! *** ROUTINE set_xmlatt *** + !! + !! ** Purpose : automatic definitions of some of the xml attributs... + !! + !!---------------------------------------------------------------------- + CHARACTER(len=1),DIMENSION( 3) :: clgrd ! suffix name + CHARACTER(len=256) :: clsuff ! suffix name + CHARACTER(len=1) :: cl1 ! 1 character + CHARACTER(len=2) :: cl2 ! 2 characters + CHARACTER(len=3) :: cl3 ! 3 characters + INTEGER :: ji, jg ! loop counters + INTEGER :: ix, iy ! i-,j- index + REAL(wp) ,DIMENSION(11) :: zlontao ! longitudes of tao moorings + REAL(wp) ,DIMENSION( 7) :: zlattao ! latitudes of tao moorings + REAL(wp) ,DIMENSION( 4) :: zlonrama ! longitudes of rama moorings + REAL(wp) ,DIMENSION(11) :: zlatrama ! latitudes of rama moorings + REAL(wp) ,DIMENSION( 3) :: zlonpira ! longitudes of pirata moorings + REAL(wp) ,DIMENSION( 9) :: zlatpira ! latitudes of pirata moorings + TYPE(xios_duration) :: f_op, f_of + !!---------------------------------------------------------------------- + ! + ! frequency of the call of iom_put (attribut: freq_op) + f_op%timestep = 1 ; f_of%timestep = 0 ; CALL iom_set_field_attr('field_definition', freq_op=f_op, freq_offset=f_of) + f_op%timestep = 2 ; f_of%timestep = 0 ; CALL iom_set_field_attr('trendT_even' , freq_op=f_op, freq_offset=f_of) + f_op%timestep = 2 ; f_of%timestep = -1 ; CALL iom_set_field_attr('trendT_odd' , freq_op=f_op, freq_offset=f_of) + f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC' , freq_op=f_op, freq_offset=f_of) + f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC_scalar' , freq_op=f_op, freq_offset=f_of) + f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('ABL' , freq_op=f_op, freq_offset=f_of) + + ! output file names (attribut: name) + DO ji = 1, 9 + WRITE(cl1,'(i1)') ji + CALL iom_update_file_name('file'//cl1) + END DO + DO ji = 1, 99 + WRITE(cl2,'(i2.2)') ji + CALL iom_update_file_name('file'//cl2) + END DO + DO ji = 1, 999 + WRITE(cl3,'(i3.3)') ji + CALL iom_update_file_name('file'//cl3) + END DO + + ! Zooms... + clgrd = (/ 'T', 'U', 'W' /) + DO jg = 1, SIZE(clgrd) ! grid type + cl1 = clgrd(jg) + ! Equatorial section (attributs: jbegin, ni, name_suffix) + CALL dom_ngb( 0.0_wp, 0.0_wp, ix, iy, cl1 ) + CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni=Ni0glo, nj=1 ) + CALL iom_get_file_attr ('Eq'//cl1, name_suffix = clsuff ) + CALL iom_set_file_attr ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq') + CALL iom_update_file_name('Eq'//cl1) + END DO + ! TAO moorings (attributs: ibegin, jbegin, name_suffix) + zlontao = (/ 137.0, 147.0, 156.0, 165.0, -180.0, -170.0, -155.0, -140.0, -125.0, -110.0, -95.0 /) + zlattao = (/ -8.0, -5.0, -2.0, 0.0, 2.0, 5.0, 8.0 /) + CALL set_mooring( zlontao, zlattao ) + ! RAMA moorings (attributs: ibegin, jbegin, name_suffix) + zlonrama = (/ 55.0, 67.0, 80.5, 90.0 /) + zlatrama = (/ -16.0, -12.0, -8.0, -4.0, -1.5, 0.0, 1.5, 4.0, 8.0, 12.0, 15.0 /) + CALL set_mooring( zlonrama, zlatrama ) + ! PIRATA moorings (attributs: ibegin, jbegin, name_suffix) + zlonpira = (/ -38.0, -23.0, -10.0 /) + zlatpira = (/ -19.0, -14.0, -8.0, 0.0, 4.0, 8.0, 12.0, 15.0, 20.0 /) + CALL set_mooring( zlonpira, zlatpira ) + ! + END SUBROUTINE set_xmlatt + + + SUBROUTINE set_mooring( plon, plat ) + !!---------------------------------------------------------------------- + !! *** ROUTINE set_mooring *** + !! + !! ** Purpose : automatic definitions of moorings xml attributs... + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:), INTENT(in) :: plon, plat ! longitudes/latitudes oft the mooring + ! +!!$ CHARACTER(len=1),DIMENSION(4) :: clgrd = (/ 'T', 'U', 'V', 'W' /) ! suffix name + CHARACTER(len=1),DIMENSION(1) :: clgrd = (/ 'T' /) ! suffix name + CHARACTER(len=256) :: clname ! file name + CHARACTER(len=256) :: clsuff ! suffix name + CHARACTER(len=1) :: cl1 ! 1 character + CHARACTER(len=6) :: clon,clat ! name of longitude, latitude + INTEGER :: ji, jj, jg ! loop counters + INTEGER :: ix, iy ! i-,j- index + REAL(wp) :: zlon, zlat + !!---------------------------------------------------------------------- + DO jg = 1, SIZE(clgrd) + cl1 = clgrd(jg) + DO ji = 1, SIZE(plon) + DO jj = 1, SIZE(plat) + zlon = plon(ji) + zlat = plat(jj) + ! modifications for RAMA moorings + IF( zlon == 67. .AND. zlat == 15. ) zlon = 65. + IF( zlon == 90. .AND. zlat <= -4. ) zlon = 95. + IF( zlon == 95. .AND. zlat == -4. ) zlat = -5. + ! modifications for PIRATA moorings + IF( zlon == -38. .AND. zlat == -19. ) zlon = -34. + IF( zlon == -38. .AND. zlat == -14. ) zlon = -32. + IF( zlon == -38. .AND. zlat == -8. ) zlon = -30. + IF( zlon == -38. .AND. zlat == 0. ) zlon = -35. + IF( zlon == -23. .AND. zlat == 20. ) zlat = 21. + IF( zlon == -10. .AND. zlat == -14. ) zlat = -10. + IF( zlon == -10. .AND. zlat == -8. ) zlat = -6. + IF( zlon == -10. .AND. zlat == 4. ) THEN ; zlon = 0. ; zlat = 0. ; ENDIF + CALL dom_ngb( zlon, zlat, ix, iy, cl1 ) + IF( zlon >= 0. ) THEN + IF( zlon == REAL(NINT(zlon), wp) ) THEN ; WRITE(clon, '(i3, a)') NINT( zlon), 'e' + ELSE ; WRITE(clon, '(f5.1,a)') zlon , 'e' + ENDIF + ELSE + IF( zlon == REAL(NINT(zlon), wp) ) THEN ; WRITE(clon, '(i3, a)') NINT(-zlon), 'w' + ELSE ; WRITE(clon, '(f5.1,a)') -zlon , 'w' + ENDIF + ENDIF + IF( zlat >= 0. ) THEN + IF( zlat == REAL(NINT(zlat), wp) ) THEN ; WRITE(clat, '(i2, a)') NINT( zlat), 'n' + ELSE ; WRITE(clat, '(f4.1,a)') zlat , 'n' + ENDIF + ELSE + IF( zlat == REAL(NINT(zlat), wp) ) THEN ; WRITE(clat, '(i2, a)') NINT(-zlat), 's' + ELSE ; WRITE(clat, '(f4.1,a)') -zlat , 's' + ENDIF + ENDIF + clname = TRIM(ADJUSTL(clat))//TRIM(ADJUSTL(clon)) + CALL iom_set_zoom_domain_attr(TRIM(clname)//cl1, ibegin= ix-1, jbegin= iy-1, ni=1, nj=1) + + CALL iom_get_file_attr (TRIM(clname)//cl1, name_suffix = clsuff ) + CALL iom_set_file_attr (TRIM(clname)//cl1, name_suffix = TRIM(clsuff)//'_'//TRIM(clname)) + CALL iom_update_file_name(TRIM(clname)//cl1) + END DO + END DO + END DO + + END SUBROUTINE set_mooring + + + SUBROUTINE iom_update_file_name( cdid ) + !!---------------------------------------------------------------------- + !! *** ROUTINE iom_update_file_name *** + !! + !! ** Purpose : + !! + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in) :: cdid + ! + CHARACTER(LEN=256) :: clname + CHARACTER(LEN=20) :: clfreq + CHARACTER(LEN=20) :: cldate + INTEGER :: idx + INTEGER :: jn + INTEGER :: itrlen + INTEGER :: iyear, imonth, iday, isec + REAL(dp) :: zsec + LOGICAL :: llexist + TYPE(xios_duration) :: output_freq + !!---------------------------------------------------------------------- + ! + DO jn = 1, 2 + ! + output_freq = xios_duration(0,0,0,0,0,0) + IF( jn == 1 ) CALL iom_get_file_attr( cdid, name = clname, output_freq = output_freq ) + IF( jn == 2 ) CALL iom_get_file_attr( cdid, name_suffix = clname ) + ! + IF ( TRIM(clname) /= '' ) THEN + ! + idx = INDEX(clname,'@expname@') + INDEX(clname,'@EXPNAME@') + DO WHILE ( idx /= 0 ) + clname = clname(1:idx-1)//TRIM(cexper)//clname(idx+9:LEN_TRIM(clname)) + idx = INDEX(clname,'@expname@') + INDEX(clname,'@EXPNAME@') + END DO + ! + idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') + DO WHILE ( idx /= 0 ) + IF ( output_freq%timestep /= 0) THEN + WRITE(clfreq,'(I18,A2)')INT(output_freq%timestep),'ts' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%second /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%second),'s' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%minute /= 0 ) THEN + WRITE(clfreq,'(I18,A2)')INT(output_freq%minute),'mi' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%hour /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%hour),'h' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%day /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%day),'d' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%month /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%month),'m' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%year /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%year),'y' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE + CALL ctl_stop('error in the name of file id '//TRIM(cdid), & + & ' attribute output_freq is undefined -> cannot replace @freq@ in '//TRIM(clname) ) + ENDIF + clname = clname(1:idx-1)//TRIM(ADJUSTL(clfreq))//clname(idx+6:LEN_TRIM(clname)) + idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') + END DO + ! + idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') + DO WHILE ( idx /= 0 ) + cldate = iom_sdate( fjulday - rn_Dt / rday ) + clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+11:LEN_TRIM(clname)) + idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') + END DO + ! + idx = INDEX(clname,'@startdatefull@') + INDEX(clname,'@STARTDATEFULL@') + DO WHILE ( idx /= 0 ) + cldate = iom_sdate( fjulday - rn_Dt / rday, ldfull = .TRUE. ) + clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+15:LEN_TRIM(clname)) + idx = INDEX(clname,'@startdatefull@') + INDEX(clname,'@STARTDATEFULL@') + END DO + ! + idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@') + DO WHILE ( idx /= 0 ) + cldate = iom_sdate( fjulday + rn_Dt / rday * REAL( nitend - nit000, wp ), ld24 = .TRUE. ) + clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+9:LEN_TRIM(clname)) + idx = INDEX(clname,'@enddate@') + INDEX(clname,'@ENDDATE@') + END DO + ! + idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@') + DO WHILE ( idx /= 0 ) + cldate = iom_sdate( fjulday + rn_Dt / rday * REAL( nitend - nit000, wp ), ld24 = .TRUE., ldfull = .TRUE. ) + clname = clname(1:idx-1)//TRIM(cldate)//clname(idx+13:LEN_TRIM(clname)) + idx = INDEX(clname,'@enddatefull@') + INDEX(clname,'@ENDDATEFULL@') + END DO + ! + IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) + IF( jn == 1 ) CALL iom_set_file_attr( cdid, name = clname ) + IF( jn == 2 ) CALL iom_set_file_attr( cdid, name_suffix = clname ) + ! + ENDIF + ! + END DO + ! + END SUBROUTINE iom_update_file_name + + + FUNCTION iom_sdate( pjday, ld24, ldfull ) + !!---------------------------------------------------------------------- + !! *** ROUTINE iom_sdate *** + !! + !! ** Purpose : send back the date corresponding to the given julian day + !!---------------------------------------------------------------------- + REAL(dp), INTENT(in ) :: pjday ! julian day + LOGICAL , INTENT(in ), OPTIONAL :: ld24 ! true to force 24:00 instead of 00:00 + LOGICAL , INTENT(in ), OPTIONAL :: ldfull ! true to get the compleate date: yyyymmdd_hh:mm:ss + ! + CHARACTER(LEN=20) :: iom_sdate + CHARACTER(LEN=50) :: clfmt ! format used to write the date + INTEGER :: iyear, imonth, iday, ihour, iminute, isec + REAL(dp) :: zsec + LOGICAL :: ll24, llfull + !!---------------------------------------------------------------------- + ! + IF( PRESENT(ld24) ) THEN ; ll24 = ld24 + ELSE ; ll24 = .FALSE. + ENDIF + ! + IF( PRESENT(ldfull) ) THEN ; llfull = ldfull + ELSE ; llfull = .FALSE. + ENDIF + ! + CALL ju2ymds( pjday, iyear, imonth, iday, zsec ) + isec = NINT(zsec) + ! + IF ( ll24 .AND. isec == 0 ) THEN ! 00:00 of the next day -> move to 24:00 of the current day + CALL ju2ymds( pjday - 1.0_wp, iyear, imonth, iday, zsec ) + isec = 86400 + ENDIF + ! + IF( iyear < 10000 ) THEN ; clfmt = "i4.4,2i2.2" ! format used to write the date + ELSE ; WRITE(clfmt, "('i',i1,',2i2.2')") INT(LOG10(REAL(iyear,wp))) + 1 + ENDIF + ! +!$AGRIF_DO_NOT_TREAT + ! needed in the conv + IF( llfull ) THEN + clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2" + ihour = isec / 3600 + isec = MOD(isec, 3600) + iminute = isec / 60 + isec = MOD(isec, 60) + WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday, ihour, iminute, isec ! date of the end of run + ELSE + WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday ! date of the end of run + ENDIF +!$AGRIF_END_DO_NOT_TREAT + ! + END FUNCTION iom_sdate + +#else + !!---------------------------------------------------------------------- + !! NOT 'key_xios' a few dummy routines + !!---------------------------------------------------------------------- + SUBROUTINE iom_setkt( kt, cdname ) + INTEGER , INTENT(in):: kt + CHARACTER(LEN=*), INTENT(in) :: cdname + IF( .FALSE. ) WRITE(numout,*) kt, cdname ! useless test to avoid compilation warnings + END SUBROUTINE iom_setkt + + SUBROUTINE iom_context_finalize( cdname ) + CHARACTER(LEN=*), INTENT(in) :: cdname + IF( .FALSE. ) WRITE(numout,*) cdname ! useless test to avoid compilation warnings + END SUBROUTINE iom_context_finalize + + SUBROUTINE iom_update_file_name( cdid ) + CHARACTER(LEN=*), INTENT(in) :: cdid + IF( .FALSE. ) WRITE(numout,*) cdid ! useless test to avoid compilation warnings + END SUBROUTINE iom_update_file_name + +#endif + + LOGICAL FUNCTION iom_use( cdname ) + CHARACTER(LEN=*), INTENT(in) :: cdname +#if defined key_xios + iom_use = xios_field_is_active( cdname ) +#else + iom_use = .FALSE. +#endif + END FUNCTION iom_use + + SUBROUTINE iom_miss_val( cdname, pmiss_val ) + CHARACTER(LEN=*), INTENT(in ) :: cdname + REAL(wp) , INTENT(out) :: pmiss_val + REAL(dp) :: ztmp_pmiss_val +#if defined key_xios + ! get missing value + CALL xios_get_field_attr( cdname, default_value = ztmp_pmiss_val ) + pmiss_val = ztmp_pmiss_val +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pmiss_val ! useless test to avoid compilation warnings + IF( .FALSE. ) pmiss_val = 0._wp ! useless assignment to avoid compilation warnings +#endif + END SUBROUTINE iom_miss_val + + !!====================================================================== +END MODULE iom diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/iom_def.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/iom_def.F90 new file mode 100644 index 0000000..a533e6a --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/iom_def.F90 @@ -0,0 +1,72 @@ +MODULE iom_def + !!====================================================================== + !! *** MODULE iom_def *** + !! IOM variables definitions + !!====================================================================== + !! History : 9.0 ! 2006 09 (S. Masson) Original code + !! - ! 2007 07 (D. Storkey) Add uldname + !! 4.0 ! 2017-11 (M. Andrejczuk) Extend IOM interface to write any 3D fields + !!---------------------------------------------------------------------- + USE par_kind + USE netcdf + + IMPLICIT NONE + PRIVATE + + INTEGER, PARAMETER, PUBLIC :: jpdom_global = 1 !: ( 1 :Ni0glo, 1 :Nj0glo) + INTEGER, PARAMETER, PUBLIC :: jpdom_local = 2 !: (Nis0: Nie0 ,Njs0: Nje0 ) + INTEGER, PARAMETER, PUBLIC :: jpdom_unknown = 3 !: No dimension checking + INTEGER, PARAMETER, PUBLIC :: jpdom_auto = 4 !: + INTEGER, PARAMETER, PUBLIC :: jpdom_auto_xy = 5 !: Automatically set horizontal dimensions only + + INTEGER, PARAMETER, PUBLIC :: jp_r8 = 200 !: write REAL(8) + INTEGER, PARAMETER, PUBLIC :: jp_r4 = 201 !: write REAL(4) + INTEGER, PARAMETER, PUBLIC :: jp_i4 = 202 !: write INTEGER(4) + INTEGER, PARAMETER, PUBLIC :: jp_i2 = 203 !: write INTEGER(2) + INTEGER, PARAMETER, PUBLIC :: jp_i1 = 204 !: write INTEGER(1) + + INTEGER, PARAMETER, PUBLIC :: jpmax_files = 100 !: maximum number of simultaneously opened file + INTEGER, PARAMETER, PUBLIC :: jpmax_vars = 1200 !: maximum number of variables in one file + INTEGER, PARAMETER, PUBLIC :: jpmax_dims = 4 !: maximum number of dimensions for one variable + INTEGER, PARAMETER, PUBLIC :: jpmax_digits = 9 !: maximum number of digits for the cpu number in the file name + +!$AGRIF_DO_NOT_TREAT + INTEGER, PUBLIC :: iom_open_init = 0 !: used to initialize iom_file(:)%nfid to 0 +!XIOS write restart + LOGICAL, PUBLIC :: lwxios = .FALSE. !: write single file restart using XIOS + INTEGER, PUBLIC :: nxioso = 0 !: type of restart file when writing using XIOS 1 - single, 2 - multiple +!XIOS read restart + LOGICAL, PUBLIC :: lrxios = .FALSE. !: read single file restart using XIOS main switch + LOGICAL, PUBLIC :: lxios_sini = .FALSE. ! is restart in a single file + + + + TYPE, PUBLIC :: file_descriptor + CHARACTER(LEN=240) :: name !: name of the file + CHARACTER(LEN=3 ) :: comp !: name of component opening the file ('OCE', 'ICE'...) + INTEGER :: nfid !: identifier of the file (0 if closed) + !: jpioipsl option has been removed) + INTEGER :: nvars !: number of identified varibles in the file + INTEGER :: iduld !: id of the unlimited dimension + INTEGER :: lenuld !: length of the unlimited dimension (number of records in file) + INTEGER :: irec !: writing record position + CHARACTER(LEN=32) :: uldname !: name of the unlimited dimension + CHARACTER(LEN=32), DIMENSION(jpmax_vars) :: cn_var !: names of the variables + INTEGER, DIMENSION(jpmax_vars) :: nvid !: id of the variables + INTEGER, DIMENSION(jpmax_vars) :: ndims !: number of dimensions of the variables + LOGICAL, DIMENSION(jpmax_vars) :: luld !: variable using the unlimited dimension + INTEGER, DIMENSION(jpmax_dims,jpmax_vars) :: dimsz !: size of variables dimensions + REAL(kind=wp), DIMENSION(jpmax_vars) :: scf !: scale_factor of the variables + REAL(kind=wp), DIMENSION(jpmax_vars) :: ofs !: add_offset of the variables + END TYPE file_descriptor + TYPE(file_descriptor), DIMENSION(jpmax_files), PUBLIC :: iom_file !: array containing the info for all opened files +!$AGRIF_END_DO_NOT_TREAT + ! + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: iom_def.F90 14072 2020-12-04 07:48:38Z laurent $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE iom_def \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/iom_nf90.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/iom_nf90.F90 new file mode 100644 index 0000000..feb699e --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/iom_nf90.F90 @@ -0,0 +1,738 @@ +MODULE iom_nf90 + !!====================================================================== + !! *** MODULE iom_nf90 *** + !! Input/Output manager : Library to read input files with NF90 (only fliocom module) + !!====================================================================== + !! History : 9.0 ! 05 12 (J. Belier) Original code + !! 9.0 ! 06 02 (S. Masson) Adaptation to NEMO + !! " ! 07 07 (D. Storkey) Changes to iom_nf90_gettime + !! 3.6 ! 2015-15 (J. Harle) Added procedure to read REAL attributes + !! 4.0 ! 2017-11 (M. Andrejczuk) Extend IOM interface to write any 3D fields + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! iom_open : open a file read only + !! iom_close : close a file or all files opened by iom + !! iom_get : read a field (interfaced to several routines) + !! iom_varid : get the id of a variable in a file + !! iom_rstput : write a field in a restart file (interfaced to several routines) + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE sbc_oce, ONLY: ght_abl ! abl vertical level number and height + USE lbclnk ! lateal boundary condition / mpp exchanges + USE iom_def ! iom variables definitions + USE netcdf ! NetCDF library + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC iom_nf90_open , iom_nf90_close, iom_nf90_varid, iom_nf90_get, iom_nf90_rstput + PUBLIC iom_nf90_chkatt, iom_nf90_getatt, iom_nf90_putatt + PUBLIC iom_nf90_check + + INTERFACE iom_nf90_get + MODULE PROCEDURE iom_nf90_g0d_sp + MODULE PROCEDURE iom_nf90_g0d_dp, iom_nf90_g123d_dp + END INTERFACE + INTERFACE iom_nf90_rstput + MODULE PROCEDURE iom_nf90_rp0123d_dp + END INTERFACE + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: iom_nf90.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kdlev, cdcomp ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_open *** + !! + !! ** Purpose : open an input file with NF90 + !!--------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(inout) :: cdname ! File name + INTEGER , INTENT( out) :: kiomid ! nf90 identifier of the opened file + LOGICAL , INTENT(in ) :: ldwrt ! read or write the file? + LOGICAL , INTENT(in ) :: ldok ! check the existence + INTEGER , INTENT(in ), OPTIONAL :: kdlev ! size of the ice/abl third dimension + CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cdcomp ! name of component calling iom_nf90_open + + CHARACTER(LEN=256) :: clinfo ! info character + CHARACTER(LEN=256) :: cltmp ! temporary character + CHARACTER(LEN=12 ) :: clfmt ! writing format + CHARACTER(LEN=3 ) :: clcomp ! name of component calling iom_nf90_open + INTEGER :: idg ! number of digits + INTEGER :: iln ! lengths of character + INTEGER :: istop ! temporary storage of nstop + INTEGER :: if90id ! nf90 identifier of the opened file + INTEGER :: idmy ! dummy variable + INTEGER :: jl ! loop variable + INTEGER :: ichunk ! temporary storage of nn_chunksz + INTEGER :: imode ! creation mode flag: NF90_CLOBBER or NF90_NOCLOBBER or NF90_HDF5 + INTEGER :: ihdf5 ! local variable for retrieval of value for NF90_HDF5 + LOGICAL :: llclobber ! local definition of ln_clobber + !--------------------------------------------------------------------- + ! + clinfo = ' iom_nf90_open ~~~ ' + istop = nstop ! store the actual value of nstop + ! + ! !number of vertical levels + IF( PRESENT(cdcomp) ) THEN + IF( .NOT. PRESENT(kdlev) ) CALL ctl_stop( 'iom_nf90_open: cdcomp and kdlev must both be present' ) + clcomp = cdcomp ! use input value + ELSE + clcomp = 'OCE' ! by default + ENDIF + ! + IF( nn_chunksz > 0 ) THEN ; ichunk = nn_chunksz + ELSE ; ichunk = NF90_SIZEHINT_DEFAULT + ENDIF + ! + llclobber = ldwrt .AND. ln_clobber + IF( ldok .AND. .NOT. llclobber ) THEN !== Open existing file ==! + ! !=========================! + IF( ldwrt ) THEN ! ... in write mode + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' open existing file: '//TRIM(cdname)//' in WRITE mode' + IF( snc4set%luse ) THEN + CALL iom_nf90_check(NF90_OPEN( TRIM(cdname), NF90_WRITE , if90id ), clinfo) + ELSE + CALL iom_nf90_check(NF90_OPEN( TRIM(cdname), NF90_WRITE , if90id, chunksize = ichunk ), clinfo) + ENDIF + CALL iom_nf90_check(NF90_SET_FILL( if90id, NF90_NOFILL, idmy ), clinfo) + ELSE ! ... in read mode + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' open existing file: '//TRIM(cdname)//' in READ mode' + CALL iom_nf90_check(NF90_OPEN( TRIM(cdname), NF90_NOWRITE, if90id, chunksize = ichunk ), clinfo) + ENDIF + ELSE !== the file doesn't exist ==! (or we overwrite it) + ! !============================! + iln = INDEX( cdname, '.nc' ) + IF( ldwrt ) THEN !* the file should be open in write mode so we create it... + IF( jpnij > 1 ) THEN + idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' + WRITE(cltmp,clfmt) cdname(1:iln-1), '_', narea-1, '.nc' + cdname = TRIM(cltmp) + ENDIF + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' create new file: '//TRIM(cdname)//' in WRITE mode' + + IF( llclobber ) THEN ; imode = IOR( NF90_64BIT_OFFSET, NF90_CLOBBER ) + ELSE ; imode = IOR( NF90_64BIT_OFFSET, NF90_NOCLOBBER ) + ENDIF + IF( snc4set%luse ) THEN + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' creating file: '//TRIM(cdname)//' in hdf5 (netcdf4) mode' + CALL GET_NF90_SYMBOL("NF90_HDF5", ihdf5) + IF( llclobber ) THEN ; imode = IOR(ihdf5, NF90_CLOBBER) + ELSE ; imode = IOR(ihdf5, NF90_NOCLOBBER) + ENDIF + CALL iom_nf90_check(NF90_CREATE( TRIM(cdname), imode, if90id ), clinfo) + ELSE + CALL iom_nf90_check(NF90_CREATE( TRIM(cdname), imode, if90id, chunksize = ichunk ), clinfo) + ENDIF + CALL iom_nf90_check(NF90_SET_FILL( if90id, NF90_NOFILL, idmy ), clinfo) + ! define dimensions + CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'x', Ni_0, idmy ), clinfo) + CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'y', Nj_0, idmy ), clinfo) + SELECT CASE (clcomp) + CASE ('OCE') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', jpk, idmy ), clinfo) + CASE ('ICE') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numcat', kdlev, idmy ), clinfo) + CASE ('ABL') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', kdlev, idmy ), clinfo) + CASE ('SED') ; CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numsed', kdlev, idmy ), clinfo) + CASE DEFAULT ; CALL ctl_stop( 'iom_nf90_open unknown component type' ) + END SELECT + CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo) + ! global attributes + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig0(Nis0), mjg0(Njs0) /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig0(Nie0), mjg0(Nje0) /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ), clinfo) + ELSE !* the file should be open for read mode so it must exist... + CALL ctl_stop( TRIM(clinfo), ' should be impossible case...' ) + ENDIF + ENDIF + ! + ! start to fill file informations + ! ============= + IF( istop == nstop ) THEN ! no error within this routine +!does not work with some compilers kiomid = MINLOC(iom_file(:)%nfid, dim = 1) + kiomid = 0 + DO jl = jpmax_files, 1, -1 + IF( iom_file(jl)%nfid == 0 ) kiomid = jl + ENDDO + iom_file(kiomid)%name = TRIM(cdname) + iom_file(kiomid)%comp = clcomp + iom_file(kiomid)%nfid = if90id + iom_file(kiomid)%nvars = 0 + iom_file(kiomid)%irec = -1 ! useless for NetCDF files, used to know if the file is in define mode + CALL iom_nf90_check(NF90_Inquire(if90id, unlimitedDimId = iom_file(kiomid)%iduld), clinfo) + IF( iom_file(kiomid)%iduld .GE. 0 ) THEN + CALL iom_nf90_check(NF90_Inquire_Dimension(if90id, iom_file(kiomid)%iduld, & + & name = iom_file(kiomid)%uldname, & + & len = iom_file(kiomid)%lenuld ), clinfo ) + ENDIF + IF(lwp) WRITE(numout,*) ' ---> '//TRIM(cdname)//' OK' + ELSE + kiomid = 0 ! return error flag + ENDIF + ! + END SUBROUTINE iom_nf90_open + + + SUBROUTINE iom_nf90_close( kiomid ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_nf90_close *** + !! + !! ** Purpose : close an input file with NF90 + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: kiomid ! iom identifier of the file to be closed + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + clinfo = ' iom_nf90_close , file: '//TRIM(iom_file(kiomid)%name) + CALL iom_nf90_check(NF90_CLOSE(iom_file(kiomid)%nfid), clinfo) + END SUBROUTINE iom_nf90_close + + + FUNCTION iom_nf90_varid ( kiomid, cdvar, kiv, kdimsz, kndims, lduld ) + !!----------------------------------------------------------------------- + !! *** FUNCTION iom_varid *** + !! + !! ** Purpose : get the id of a variable in a file with NF90 + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! file Identifier + CHARACTER(len=*) , INTENT(in ) :: cdvar ! name of the variable + INTEGER , INTENT(in ) :: kiv ! + INTEGER, DIMENSION(:), INTENT( out), OPTIONAL :: kdimsz ! size of each dimension + INTEGER , INTENT( out), OPTIONAL :: kndims ! number of dimensions + LOGICAL , INTENT( out), OPTIONAL :: lduld ! true if the last dimension is unlimited (time) + ! + INTEGER :: iom_nf90_varid ! iom variable Id + INTEGER :: if90id ! nf90 file identifier + INTEGER :: ji ! dummy loop index + INTEGER :: ivarid ! NetCDF variable Id + INTEGER :: i_nvd ! number of dimension of the variable + INTEGER, DIMENSION(jpmax_dims) :: idimid ! dimension ids of the variable + LOGICAL :: llok ! ok test + CHARACTER(LEN=100) :: clinfo ! info character + !!----------------------------------------------------------------------- + clinfo = ' iom_nf90_varid, file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(cdvar) + iom_nf90_varid = 0 ! default definition + IF( PRESENT(kdimsz) ) kdimsz(:) = 0 ! default definition + if90id = iom_file(kiomid)%nfid ! get back NetCDF file id + ! + llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr ! does the variable exist in the file + IF( llok ) THEN + iom_nf90_varid = kiv + iom_file(kiomid)%nvars = kiv + iom_file(kiomid)%nvid(kiv) = ivarid + iom_file(kiomid)%cn_var(kiv) = TRIM(cdvar) + CALL iom_nf90_check(NF90_Inquire_Variable(if90id, ivarid, ndims = i_nvd), clinfo) ! number of dimensions + iom_file(kiomid)%ndims(kiv) = i_nvd + CALL iom_nf90_check(NF90_Inquire_Variable(if90id, ivarid, dimids = idimid(1:i_nvd)), clinfo) ! dimensions ids + iom_file(kiomid)%luld(kiv) = .FALSE. ! default value + iom_file(kiomid)%dimsz(:,kiv) = 0 ! reset dimsz in case previously used + DO ji = 1, i_nvd ! dimensions size + CALL iom_nf90_check(NF90_Inquire_Dimension(if90id, idimid(ji), len = iom_file(kiomid)%dimsz(ji,kiv)), clinfo) + IF( idimid(ji) == iom_file(kiomid)%iduld ) iom_file(kiomid)%luld(kiv) = .TRUE. ! unlimited dimension? + END DO + !---------- Deal with scale_factor and add_offset + llok = NF90_Inquire_attribute(if90id, ivarid, 'scale_factor') == nf90_noerr + IF( llok) THEN + CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, 'scale_factor', iom_file(kiomid)%scf(kiv)), clinfo) + ELSE + iom_file(kiomid)%scf(kiv) = 1. + END IF + llok = NF90_Inquire_attribute(if90id, ivarid, 'add_offset') == nf90_noerr + IF( llok ) THEN + CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, 'add_offset', iom_file(kiomid)%ofs(kiv)), clinfo) + ELSE + iom_file(kiomid)%ofs(kiv) = 0. + END IF + ! return the simension size + IF( PRESENT(kdimsz) ) THEN + IF( i_nvd <= SIZE(kdimsz) ) THEN + kdimsz(1:i_nvd) = iom_file(kiomid)%dimsz(1:i_nvd,kiv) + ELSE + WRITE(ctmp1,*) i_nvd, SIZE(kdimsz) + CALL ctl_stop( TRIM(clinfo), 'error in kdimsz size'//TRIM(ctmp1) ) + ENDIF + ENDIF + IF( PRESENT(kndims) ) kndims = iom_file(kiomid)%ndims(kiv) + IF( PRESENT( lduld) ) lduld = iom_file(kiomid)%luld(kiv) + ELSE + iom_nf90_varid = -1 ! variable not found, return error code: -1 + ENDIF + ! + END FUNCTION iom_nf90_varid + + !!---------------------------------------------------------------------- + !! INTERFACE iom_nf90_get + !!---------------------------------------------------------------------- + + SUBROUTINE iom_nf90_g0d_sp( kiomid, kvid, pvar, kstart ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_g0d *** + !! + !! ** Purpose : read a scalar with NF90 + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kvid ! variable id + REAL(sp), INTENT( out) :: pvar ! read field + INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis + ! + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) + CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) + END SUBROUTINE iom_nf90_g0d_sp + + SUBROUTINE iom_nf90_g0d_dp( kiomid, kvid, pvar, kstart ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_g0d *** + !! + !! ** Purpose : read a scalar with NF90 + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + INTEGER , INTENT(in ) :: kvid ! variable id + REAL(dp), INTENT( out) :: pvar ! read field + INTEGER , DIMENSION(1), INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis + ! + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) + CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) + END SUBROUTINE iom_nf90_g0d_dp + + SUBROUTINE iom_nf90_g123d_dp( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2, & + & pv_r1d, pv_r2d, pv_r3d ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_g123d *** + !! + !! ** Purpose : read a 1D/2D/3D variable with NF90 + !! + !! ** Method : read ONE record at each CALL + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! iom identifier of the file + INTEGER , INTENT(in ) :: kvid ! Name of the variable + INTEGER , INTENT(in ) :: knbdim ! number of dimensions of the variable + INTEGER , DIMENSION(:) , INTENT(in ) :: kstart ! start position of the reading in each axis + INTEGER , DIMENSION(:) , INTENT(in ) :: kcount ! number of points to be read in each axis + INTEGER , INTENT(in ) :: kx1, kx2, ky1, ky2 ! subdomain indexes + REAL(dp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) + REAL(dp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) + REAL(dp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) + ! + CHARACTER(LEN=100) :: clinfo ! info character + INTEGER :: if90id ! nf90 identifier of the opened file + INTEGER :: ivid ! nf90 variable id + !--------------------------------------------------------------------- + clinfo = 'iom_nf90_g123d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) + if90id = iom_file(kiomid)%nfid ! get back NetCDF file id + ivid = iom_file(kiomid)%nvid(kvid) ! get back NetCDF var id + ! + IF( PRESENT(pv_r1d) ) THEN + CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, pv_r1d(: ), start = kstart(1:knbdim), & + & count = kcount(1:knbdim)), clinfo ) + ELSEIF( PRESENT(pv_r2d) ) THEN + CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, pv_r2d(kx1:kx2,ky1:ky2 ), start = kstart(1:knbdim), & + & count = kcount(1:knbdim)), clinfo ) + ELSEIF( PRESENT(pv_r3d) ) THEN + CALL iom_nf90_check( NF90_GET_VAR(if90id, ivid, pv_r3d(kx1:kx2,ky1:ky2,:), start = kstart(1:knbdim), & + & count = kcount(1:knbdim)), clinfo ) + ENDIF + ! + END SUBROUTINE iom_nf90_g123d_dp + + + + SUBROUTINE iom_nf90_chkatt( kiomid, cdatt, llok, ksize, cdvar ) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_chkatt *** + !! + !! ** Purpose : check existence of attribute with NF90 + !! (either a global attribute (default) or a variable + !! attribute if optional variable name is supplied (cdvar)) + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdatt ! attribute name + LOGICAL , INTENT( out) :: llok ! error code + INTEGER , INTENT( out), OPTIONAL & + & :: ksize ! attribute size + CHARACTER(len=*), INTENT(in ), OPTIONAL & + & :: cdvar ! name of the variable + ! + INTEGER :: if90id ! temporary integer + INTEGER :: isize ! temporary integer + INTEGER :: ivarid ! NetCDF variable Id + !--------------------------------------------------------------------- + ! + if90id = iom_file(kiomid)%nfid + IF( PRESENT(cdvar) ) THEN + ! check the variable exists in the file + llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr + IF( llok ) & + ! check the variable has the attribute required + llok = NF90_Inquire_attribute(if90id, ivarid, cdatt, len=isize ) == nf90_noerr + ELSE + llok = NF90_Inquire_attribute(if90id, NF90_GLOBAL, cdatt, len=isize ) == nf90_noerr + ENDIF + ! + IF( PRESENT(ksize) ) ksize = isize + ! + IF( .not. llok) & + CALL ctl_warn('iom_nf90_chkatt: no attribute '//cdatt//' found') + ! + END SUBROUTINE iom_nf90_chkatt + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_nf90_getatt + !!---------------------------------------------------------------------- + + SUBROUTINE iom_nf90_getatt( kiomid, cdatt, katt0d, katt1d, patt0d, patt1d, cdatt0d, cdvar) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_getatt *** + !! + !! ** Purpose : read an attribute with NF90 + !! (either a global attribute (default) or a variable + !! attribute if optional variable name is supplied (cdvar)) + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! attribute name + INTEGER , INTENT( out), OPTIONAL :: katt0d ! read scalar integer + INTEGER, DIMENSION(:) , INTENT( out), OPTIONAL :: katt1d ! read 1d array integer + REAL(wp) , INTENT( out), OPTIONAL :: patt0d ! read scalar real + REAL(wp), DIMENSION(:), INTENT( out), OPTIONAL :: patt1d ! read 1d array real + CHARACTER(len=*) , INTENT( out), OPTIONAL :: cdatt0d ! read character + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! name of the variable + ! + INTEGER :: if90id ! temporary integer + INTEGER :: ivarid ! NetCDF variable Id + LOGICAL :: llok ! temporary logical + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + ! + if90id = iom_file(kiomid)%nfid + IF( PRESENT(cdvar) ) THEN + ! check the variable exists in the file + llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr + IF( llok ) THEN + ! check the variable has the attribute required + llok = NF90_Inquire_attribute(if90id, ivarid, cdatt) == nf90_noerr + ELSE + CALL ctl_warn('iom_nf90_getatt: no variable '//TRIM(cdvar)//' found') + ENDIF + ELSE + llok = NF90_Inquire_attribute(if90id, NF90_GLOBAL, cdatt) == nf90_noerr + ivarid = NF90_GLOBAL + ENDIF + ! + IF( llok) THEN + clinfo = 'iom_nf90_getatt, file: '//TRIM(iom_file(kiomid)%name)//', att: '//TRIM(cdatt) + IF(PRESENT( katt0d)) CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values = katt0d), clinfo) + IF(PRESENT( katt1d)) CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values = katt1d), clinfo) + IF(PRESENT( patt0d)) CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values = patt0d), clinfo) + IF(PRESENT( patt1d)) CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values = patt1d), clinfo) + IF(PRESENT(cdatt0d)) CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values = cdatt0d), clinfo) + ELSE + IF(PRESENT( katt0d)) katt0d = -999 + IF(PRESENT( katt1d)) katt1d(:) = -999 + IF(PRESENT( patt0d)) patt0d = -999._wp + IF(PRESENT( patt1d)) patt1d(:) = -999._wp + IF(PRESENT(cdatt0d)) cdatt0d = 'UNKNOWN' + ENDIF + ! + END SUBROUTINE iom_nf90_getatt + + + SUBROUTINE iom_nf90_putatt( kiomid, cdatt, katt0d, katt1d, patt0d, patt1d, cdatt0d, cdvar) + !!----------------------------------------------------------------------- + !! *** ROUTINE iom_nf90_putatt *** + !! + !! ** Purpose : write an attribute with NF90 + !! (either a global attribute (default) or a variable + !! attribute if optional variable name is supplied (cdvar)) + !!----------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! attribute name + INTEGER , INTENT(in ), OPTIONAL :: katt0d ! read scalar integer + INTEGER, DIMENSION(:) , INTENT(in ), OPTIONAL :: katt1d ! read 1d array integer + REAL(wp) , INTENT(in ), OPTIONAL :: patt0d ! read scalar real + REAL(wp), DIMENSION(:), INTENT(in ), OPTIONAL :: patt1d ! read 1d array real + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdatt0d ! read character + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! name of the variable + ! + INTEGER :: if90id ! temporary integer + INTEGER :: ivarid ! NetCDF variable Id + INTEGER :: isize ! Attribute size + INTEGER :: itype ! Attribute type + LOGICAL :: llok ! temporary logical + LOGICAL :: llatt ! temporary logical + LOGICAL :: lldata ! temporary logical + CHARACTER(LEN=100) :: clinfo ! info character + !--------------------------------------------------------------------- + ! + if90id = iom_file(kiomid)%nfid + IF( PRESENT(cdvar) ) THEN + llok = NF90_INQ_VARID( if90id, TRIM(cdvar), ivarid ) == nf90_noerr ! is the variable in the file? + IF( .NOT. llok ) THEN + CALL ctl_warn('iom_nf90_putatt: no variable '//TRIM(cdvar)//' found' & + & , ' no attribute '//cdatt//' written' ) + RETURN + ENDIF + ELSE + ivarid = NF90_GLOBAL + ENDIF + llatt = NF90_Inquire_attribute(if90id, ivarid, cdatt, len = isize, xtype = itype ) == nf90_noerr + ! + ! trick: irec used to know if the file is in define mode or not + lldata = iom_file(kiomid)%irec /= -1 ! default: go back in define mode if in data mode + IF( lldata .AND. llatt ) THEN ! attribute already there. Do we really need to go back in define mode? + ! do we have the appropriate type? + IF(PRESENT( katt0d) .OR. PRESENT( katt1d)) llok = itype == NF90_INT + IF(PRESENT( patt0d) .OR. PRESENT( patt1d)) llok = itype == NF90_DOUBLE + IF(PRESENT(cdatt0d) ) llok = itype == NF90_CHAR + ! and do we have the appropriate size? + IF(PRESENT( katt0d)) llok = llok .AND. isize == 1 + IF(PRESENT( katt1d)) llok = llok .AND. isize == SIZE(katt1d) + IF(PRESENT( patt0d)) llok = llok .AND. isize == 1 + IF(PRESENT( patt1d)) llok = llok .AND. isize == SIZE(patt1d) + IF(PRESENT(cdatt0d)) llok = llok .AND. isize == LEN_TRIM(cdatt0d) + ! + lldata = .NOT. llok + ENDIF + ! + clinfo = 'iom_nf90_putatt, file: '//TRIM(iom_file(kiomid)%name)//', att: '//TRIM(cdatt) + IF(lldata) CALL iom_nf90_check(NF90_REDEF( if90id ), clinfo) ! leave data mode to define mode + ! + IF(PRESENT( katt0d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = katt0d) , clinfo) + IF(PRESENT( katt1d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = katt1d) , clinfo) + IF(PRESENT( patt0d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = patt0d) , clinfo) + IF(PRESENT( patt1d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = patt1d) , clinfo) + IF(PRESENT(cdatt0d)) CALL iom_nf90_check(NF90_PUT_ATT(if90id, ivarid, cdatt, values = trim(cdatt0d)), clinfo) + ! + IF(lldata) CALL iom_nf90_check(NF90_ENDDEF( if90id ), clinfo) ! leave define mode to data mode + ! + END SUBROUTINE iom_nf90_putatt + + SUBROUTINE iom_nf90_rp0123d_dp( kt, kwrite, kiomid, cdvar , kvid , ktype, & + & pv_r0d, pv_r1d, pv_r2d, pv_r3d ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_nf90_rstput *** + !! + !! ** Purpose : read the time axis cdvar in the file + !!-------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + INTEGER , INTENT(in) :: kwrite ! writing time-step + INTEGER , INTENT(in) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in) :: cdvar ! variable name + INTEGER , INTENT(in) :: kvid ! variable id + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable type (default R8) + REAL(dp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field + REAL(dp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field + REAL(dp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field + REAL(dp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field + ! + INTEGER :: idims ! number of dimension + INTEGER :: idvar ! variable id + INTEGER :: jd ! dimension loop counter + INTEGER :: ix1, ix2, iy1, iy2 ! subdomain indexes + INTEGER, DIMENSION(4) :: idimsz ! dimensions size + INTEGER, DIMENSION(4) :: idimid ! dimensions id + CHARACTER(LEN=256) :: clinfo ! info character + INTEGER :: if90id ! nf90 file identifier + INTEGER :: itype ! variable type + INTEGER, DIMENSION(4) :: ichunksz ! NetCDF4 chunk sizes. Will be computed using + ! ! nn_nchunks_[i,j,k,t] namelist parameters + INTEGER :: ichunkalg, ishuffle, ideflate, ideflate_level + ! ! NetCDF4 internally fixed parameters + LOGICAL :: lchunk ! logical switch to activate chunking and compression + ! ! when appropriate (currently chunking is applied to 4d fields only) + INTEGER :: idlv ! local variable + !--------------------------------------------------------------------- + ! + clinfo = ' iom_nf90_rp0123d, file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(cdvar) + if90id = iom_file(kiomid)%nfid + ! + ! define dimension variables if it is not already done + ! ========================== + IF( iom_file(kiomid)%nvars == 0 ) THEN + ! are we in define mode? + IF( iom_file(kiomid)%irec /= -1 ) THEN ! trick: irec used to know if the file is in define mode or not + CALL iom_nf90_check(NF90_REDEF( if90id ), clinfo) ; iom_file(kiomid)%irec = -1 + ENDIF + ! define the dimension variables if it is not already done + DO jd = 1, 2 + CALL iom_nf90_check(NF90_INQUIRE_DIMENSION(if90id,jd,iom_file(kiomid)%cn_var(jd),iom_file(kiomid)%dimsz(jd,jd)),clinfo) + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(iom_file(kiomid)%cn_var(jd)), NF90_FLOAT , (/ 1, 2 /), & + & iom_file(kiomid)%nvid(jd) ), clinfo) + END DO + iom_file(kiomid)%dimsz(2,1) = iom_file(kiomid)%dimsz(2,2) ! second dim of first variable + iom_file(kiomid)%dimsz(1,2) = iom_file(kiomid)%dimsz(1,1) ! first dim of second variable + DO jd = 3, 4 + CALL iom_nf90_check(NF90_INQUIRE_DIMENSION(if90id,jd,iom_file(kiomid)%cn_var(jd),iom_file(kiomid)%dimsz(1,jd)), clinfo) + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(iom_file(kiomid)%cn_var(jd)), NF90_FLOAT , (/ jd /), & + & iom_file(kiomid)%nvid(jd) ), clinfo) + END DO + ! update informations structure related the dimension variable we just added... + iom_file(kiomid)%nvars = 4 + iom_file(kiomid)%luld(1:4) = (/ .FALSE., .FALSE., .FALSE., .TRUE. /) + iom_file(kiomid)%ndims(1:4) = (/ 2, 2, 1, 1 /) + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' define dimension variables done' + ENDIF + ! define the data if it is not already done + ! =============== + IF( kvid <= 0 ) THEN + ! + ! NetCDF4 chunking and compression fixed settings + ichunkalg = 0 + ishuffle = 1 + ideflate = 1 + ideflate_level = 1 + ! + idvar = iom_file(kiomid)%nvars + 1 + ! are we in define mode? + IF( iom_file(kiomid)%irec /= -1 ) THEN ! trick: irec used to know if the file is in define mode or not + CALL iom_nf90_check(NF90_REDEF( if90id ), clinfo) ; iom_file(kiomid)%irec = -1 + ENDIF + ! variable definition + IF( PRESENT(pv_r0d) ) THEN ; idims = 0 + ELSEIF( PRESENT(pv_r1d) ) THEN + idims = 2 ; idimid(1:idims) = (/3,4/) + ELSEIF( PRESENT(pv_r2d) ) THEN ; idims = 3 ; idimid(1:idims) = (/1,2,4/) + ELSEIF( PRESENT(pv_r3d) ) THEN + idims = 4 ; idimid(1:idims) = (/1,2,3,4/) + ENDIF + IF( PRESENT(ktype) ) THEN ! variable external type + SELECT CASE (ktype) + CASE (jp_r8) ; itype = NF90_DOUBLE + CASE (jp_r4) ; itype = NF90_FLOAT + CASE (jp_i4) ; itype = NF90_INT + CASE (jp_i2) ; itype = NF90_SHORT + CASE (jp_i1) ; itype = NF90_BYTE + CASE DEFAULT ; CALL ctl_stop( TRIM(clinfo)//' unknown variable type' ) + END SELECT + ELSE + itype = NF90_DOUBLE + ENDIF + IF( PRESENT(pv_r0d) ) THEN + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, & + & iom_file(kiomid)%nvid(idvar) ), clinfo ) + ELSE + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, idimid(1:idims), & + & iom_file(kiomid)%nvid(idvar) ), clinfo ) + ENDIF + lchunk = .false. + IF( snc4set%luse .AND. idims == 4 ) lchunk = .true. + ! update informations structure related the new variable we want to add... + iom_file(kiomid)%nvars = idvar + iom_file(kiomid)%cn_var(idvar) = TRIM(cdvar) + iom_file(kiomid)%scf(idvar) = 1. + iom_file(kiomid)%ofs(idvar) = 0. + iom_file(kiomid)%ndims(idvar) = idims + IF( .NOT. PRESENT(pv_r0d) ) THEN ; iom_file(kiomid)%luld(idvar) = .TRUE. + ELSE ; iom_file(kiomid)%luld(idvar) = .FALSE. + ENDIF + DO jd = 1, idims + CALL iom_nf90_check(NF90_INQUIRE_DIMENSION( if90id, idimid(jd), len = iom_file(kiomid)%dimsz(jd,idvar) ), clinfo) + IF ( lchunk ) ichunksz(jd) = iom_file(kiomid)%dimsz(jd,idvar) + END DO + IF ( lchunk ) THEN + ! Calculate chunk sizes by partitioning each dimension as requested in namnc4 namelist + ! Disallow very small chunk sizes and prevent chunk sizes larger than each individual dimension + ichunksz(1) = MIN( ichunksz(1),MAX( (ichunksz(1)-1)/snc4set%ni + 1 ,16 ) ) ! Suggested default nc4set%ni=4 + ichunksz(2) = MIN( ichunksz(2),MAX( (ichunksz(2)-1)/snc4set%nj + 1 ,16 ) ) ! Suggested default nc4set%nj=2 + ichunksz(3) = MIN( ichunksz(3),MAX( (ichunksz(3)-1)/snc4set%nk + 1 , 1 ) ) ! Suggested default nc4set%nk=6 + ichunksz(4) = 1 ! Do not allow chunks to span the + ! ! unlimited dimension + CALL iom_nf90_check(SET_NF90_DEF_VAR_CHUNKING(if90id, idvar, ichunkalg, ichunksz), clinfo) + CALL iom_nf90_check(SET_NF90_DEF_VAR_DEFLATE(if90id, idvar, ishuffle, ideflate, ideflate_level), clinfo) + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' chunked ok. Chunks sizes: ', ichunksz + ENDIF + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' defined ok' + ELSE + idvar = kvid + ENDIF + ! + ! time step kwrite : write the variable + IF( kt == kwrite ) THEN + ! are we in write mode? + IF( iom_file(kiomid)%irec == -1 ) THEN ! trick: irec used to know if the file is in define mode or not + CALL iom_nf90_check(NF90_ENDDEF( if90id ), clinfo) ; iom_file(kiomid)%irec = 0 + ENDIF + ! on what kind of domain must the data be written? + IF( PRESENT(pv_r2d) .OR. PRESENT(pv_r3d) ) THEN + idimsz(1:2) = iom_file(kiomid)%dimsz(1:2,idvar) + IF( idimsz(1) == Ni_0 .AND. idimsz(2) == Nj_0 ) THEN + ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0 + ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN + ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj + ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN + ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj + ELSE + CALL ctl_stop( 'iom_nf90_rp0123d: should have been an impossible case...' ) + ENDIF + + ! write dimension variables if it is not already done + ! ============= + ! trick: is defined to 0 => dimension variable are defined but not yet written + IF( iom_file(kiomid)%dimsz(1, 4) == 0 ) THEN ! time_counter = 0 + CALL iom_nf90_check( NF90_PUT_VAR( if90id, 1, glamt(ix1:ix2, iy1:iy2) ), clinfo ) + CALL iom_nf90_check( NF90_PUT_VAR( if90id, 2, gphit(ix1:ix2, iy1:iy2) ), clinfo ) + SELECT CASE (iom_file(kiomid)%comp) + CASE ('OCE') + CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, gdept_1d ), clinfo ) + CASE ('ABL') + CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, ght_abl ), clinfo ) + CASE DEFAULT + CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, (/ (idlv, idlv = 1,iom_file(kiomid)%dimsz(1,3)) /) ), clinfo ) + END SELECT + ! "wrong" value: to be improved but not really useful... + CALL iom_nf90_check( NF90_PUT_VAR( if90id, 4, kt ), clinfo ) + ! update the size of the variable corresponding to the unlimited dimension + iom_file(kiomid)%dimsz(1, 4) = 1 ! so we don't enter this IF case any more... + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' write dimension variables done' + ENDIF + ENDIF + + ! write the data + ! ============= + IF( PRESENT(pv_r0d) ) THEN + CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r0d ), clinfo ) + ELSEIF( PRESENT(pv_r1d) ) THEN + CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r1d(:) ), clinfo ) + ELSEIF( PRESENT(pv_r2d) ) THEN + CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r2d(ix1:ix2,iy1:iy2) ), clinfo ) + ELSEIF( PRESENT(pv_r3d) ) THEN + CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r3d(ix1:ix2,iy1:iy2,:) ), clinfo ) + ENDIF + ! add 1 to the size of the temporal dimension (not really useful...) + IF( iom_file(kiomid)%luld(idvar) ) iom_file(kiomid)%dimsz(iom_file(kiomid)%ndims(idvar), idvar) & + & = iom_file(kiomid)%dimsz(iom_file(kiomid)%ndims(idvar), idvar) + 1 + IF(lwp) WRITE(numout,*) TRIM(clinfo)//' written ok' + ENDIF + ! + END SUBROUTINE iom_nf90_rp0123d_dp + + + SUBROUTINE iom_nf90_check( kstatus, cdinfo ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE iom_nf90_check *** + !! + !! ** Purpose : check nf90 errors + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: kstatus + CHARACTER(LEN=*), INTENT(in) :: cdinfo + !--------------------------------------------------------------------- + IF(kstatus /= nf90_noerr) CALL ctl_stop( 'iom_nf90_check : '//TRIM(nf90_strerror(kstatus)), TRIM(cdinfo) ) + END SUBROUTINE iom_nf90_check + + !!====================================================================== +END MODULE iom_nf90 \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/prtctl.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/prtctl.F90 new file mode 100644 index 0000000..26e3308 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/prtctl.F90 @@ -0,0 +1,488 @@ +MODULE prtctl + !!====================================================================== + !! *** MODULE prtctl *** + !! Ocean system : print all SUM trends for each processor domain + !!====================================================================== + !! History : 9.0 ! 05-07 (C. Talandier) original code + !! 3.4 ! 11-11 (C. Harris) decomposition changes for running with CICE + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain variables + USE domutl, ONLY : is_tile + USE in_out_manager ! I/O manager + USE mppini ! distributed memory computing + USE lib_mpp ! distributed memory computing + + IMPLICIT NONE + PRIVATE + + INTEGER , DIMENSION( :), ALLOCATABLE :: numprt_oce, numprt_top + INTEGER , DIMENSION( :), ALLOCATABLE :: nall_ictls, nall_ictle ! first, last indoor index for each i-domain + INTEGER , DIMENSION( :), ALLOCATABLE :: nall_jctls, nall_jctle ! first, last indoor index for each j-domain + REAL(wp), DIMENSION( :), ALLOCATABLE :: t_ctl , s_ctl ! previous tracer trend values + REAL(wp), DIMENSION( :), ALLOCATABLE :: u_ctl , v_ctl ! previous velocity trend values + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tra_ctl ! previous top trend values + ! + PUBLIC prt_ctl ! called by all subroutines + PUBLIC prt_ctl_info ! called by all subroutines + PUBLIC prt_ctl_init ! called by nemogcm.F90 and prt_ctl_trc_init + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: prtctl.F90 15148 2021-07-27 09:40:32Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE prt_ctl (tab2d_1, tab3d_1, tab4d_1, tab2d_2, tab3d_2, mask1, mask2, & + & clinfo, clinfo1, clinfo2, clinfo3, kdim ) + !! + REAL(dp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1 + REAL(dp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_1 + REAL(dp), DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d_1 + REAL(dp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2 + REAL(dp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_2 + REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1 + REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2 + CHARACTER(len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array + CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo1 + CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo2 + CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo3 + INTEGER , INTENT(in), OPTIONAL :: kdim + ! + IF( PRESENT(tab2d_2) ) THEN + CALL prt_ctl_t(ktab2d_1 = is_tile(tab2d_1), ktab3d_1 = 0, ktab4d_1 = 0, ktab2d_2 = is_tile(tab2d_2), ktab3d_2 = 0, & + & tab2d_1 = REAL(tab2d_1, dp), tab2d_2 = REAL(tab2d_2, dp), & + & mask1 = mask1, mask2 = mask2, & + & clinfo = clinfo, clinfo1 = clinfo1, clinfo2 = clinfo2, clinfo3 = clinfo3 ) + ELSEIF( PRESENT(tab3d_2) ) THEN + CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = is_tile(tab3d_1), ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = is_tile(tab3d_2), & + & tab3d_1 = REAL(tab3d_1, dp), tab3d_2 = REAL(tab3d_2, dp), & + & mask1 = mask1, mask2 = mask2, & + & clinfo = clinfo, clinfo1 = clinfo1, clinfo2 = clinfo2, clinfo3 = clinfo3, kdim = kdim ) + ELSEIF( PRESENT(tab2d_1) ) THEN + CALL prt_ctl_t(ktab2d_1 = is_tile(tab2d_1), ktab3d_1 = 0, ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = 0, & + & tab2d_1 = REAL(tab2d_1,dp), & + & mask1 = mask1, & + & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3 ) + ELSEIF( PRESENT(tab3d_1) ) THEN + CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = is_tile(tab3d_1), ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = 0, & + & tab3d_1 = REAL(tab3d_1, dp), & + & mask1 = mask1, & + & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3, kdim = kdim ) + ELSEIF( PRESENT(tab4d_1) ) THEN + CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = 0, ktab4d_1 = is_tile(tab4d_1), ktab2d_2 = 0, ktab3d_2 = 0, & + & tab4d_1 = REAL(tab4d_1, dp), & + & mask1 = mask1, & + & clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3, kdim = kdim ) + ENDIF + + END SUBROUTINE prt_ctl + + + SUBROUTINE prt_ctl_t (tab2d_1, ktab2d_1, tab3d_1, ktab3d_1, tab4d_1, ktab4d_1, tab2d_2, ktab2d_2, tab3d_2, ktab3d_2, & + & mask1, mask2, clinfo, clinfo1, clinfo2, clinfo3, kdim ) + !!---------------------------------------------------------------------- + !! *** ROUTINE prt_ctl *** + !! + !! ** Purpose : - print sum control of 2D or 3D arrays over the same area + !! in mono and mpp case. This way can be usefull when + !! debugging a new parametrization in mono or mpp. + !! + !! ** Method : 2 possibilities exist when setting the sn_cfctl%prtctl parameter to + !! .true. in the ocean namelist: + !! - to debug a MPI run .vs. a mono-processor one; + !! the control print will be done over each sub-domain. + !! The nictl[se] and njctl[se] parameters in the namelist must + !! be set to zero and [ij]splt to the corresponding splitted + !! domain in MPI along respectively i-, j- directions. + !! - to debug a mono-processor run over the whole domain/a specific area; + !! in the first case the nictl[se] and njctl[se] parameters must be set + !! to zero else to the indices of the area to be controled. In both cases + !! isplt and jsplt must be set to 1. + !! - All arguments of the above calling sequence are optional so their + !! name must be explicitly typed if used. For instance if the 3D + !! array tn(:,:,:) must be passed through the prt_ctl subroutine, + !! it must look like: CALL prt_ctl(tab3d_1=tn). + !! + !! tab2d_1 : first 2D array + !! tab3d_1 : first 3D array + !! tab4d_1 : first 4D array + !! mask1 : mask (3D) to apply to the tab[23]d_1 array + !! clinfo1 : information about the tab[23]d_1 array + !! tab2d_2 : second 2D array + !! tab3d_2 : second 3D array + !! mask2 : mask (3D) to apply to the tab[23]d_2 array + !! clinfo2 : information about the tab[23]d_2 array + !! kdim : k- direction for 3D arrays + !! clinfo3 : additional information + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: ktab2d_1, ktab3d_1, ktab4d_1, ktab2d_2, ktab3d_2 + REAL(dp), DIMENSION(A2D_T(ktab2d_1)) , INTENT(in), OPTIONAL :: tab2d_1 + REAL(dp), DIMENSION(A2D_T(ktab3d_1),:) , INTENT(in), OPTIONAL :: tab3d_1 + REAL(dp), DIMENSION(A2D_T(ktab4d_1),:,:), INTENT(in), OPTIONAL :: tab4d_1 + REAL(dp), DIMENSION(A2D_T(ktab2d_2)) , INTENT(in), OPTIONAL :: tab2d_2 + REAL(dp), DIMENSION(A2D_T(ktab3d_2),:) , INTENT(in), OPTIONAL :: tab3d_2 + REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1 + REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2 + CHARACTER(len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array + CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo1 + CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo2 + CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo3 + INTEGER , INTENT(in), OPTIONAL :: kdim + ! + CHARACTER(len=30) :: cl1, cl2 + CHARACTER(len=6) :: clfmt + INTEGER :: jn, jl, kdir + INTEGER :: iis, iie, jjs, jje + INTEGER :: itra, inum + REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2 + !!---------------------------------------------------------------------- + ! + ! Arrays, scalars initialization + cl1 = '' + cl2 = '' + kdir = jpkm1 + itra = 1 + + ! Control of optional arguments + IF( PRESENT(clinfo1) ) cl1 = clinfo1 + IF( PRESENT(clinfo2) ) cl2 = clinfo2 + IF( PRESENT(kdim) ) kdir = kdim + IF( PRESENT(tab4d_1) ) itra = SIZE(tab4d_1,dim=4) + + IF( wp == sp ) clfmt = 'D23.16' ! 16 significant numbers + IF( wp == dp ) clfmt = 'D41.34' ! 34 significant numbers + + ! Loop over each sub-domain, i.e. the total number of processors ijsplt + DO jl = 1, SIZE(nall_ictls) + + ! define shoter names... + iis = MAX( nall_ictls(jl), ntsi ) + iie = MIN( nall_ictle(jl), ntei ) + jjs = MAX( nall_jctls(jl), ntsj ) + jje = MIN( nall_jctle(jl), ntej ) + + IF( PRESENT(clinfo) ) THEN ; inum = numprt_top(jl) + ELSE ; inum = numprt_oce(jl) + ENDIF + + ! Compute the sum control only where the tile domain and control print area overlap + IF( iie >= iis .AND. jje >= jjs ) THEN + DO jn = 1, itra + + IF( PRESENT(clinfo3) ) THEN + IF ( clinfo3 == 'tra-ta' ) THEN + zvctl1 = t_ctl(jl) + ELSEIF( clinfo3 == 'tra' ) THEN + zvctl1 = t_ctl(jl) + zvctl2 = s_ctl(jl) + ELSEIF( clinfo3 == 'dyn' ) THEN + zvctl1 = u_ctl(jl) + zvctl2 = v_ctl(jl) + ELSE + zvctl1 = tra_ctl(jn,jl) + ENDIF + ENDIF + + ! 2D arrays + IF( PRESENT(tab2d_1) ) THEN + IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) ) + ELSE ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) ) + ENDIF + ENDIF + IF( PRESENT(tab2d_2) ) THEN + IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) ) + ELSE ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) ) + ENDIF + ENDIF + + ! 3D arrays + IF( PRESENT(tab3d_1) ) THEN + IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) ) + ELSE ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) ) + ENDIF + ENDIF + IF( PRESENT(tab3d_2) ) THEN + IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) ) + ELSE ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) ) + ENDIF + ENDIF + + ! 4D arrays + IF( PRESENT(tab4d_1) ) THEN + IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) ) + ELSE ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) ) + ENDIF + ENDIF + + ! Print the result + IF( PRESENT(clinfo ) ) cl1 = clinfo(jn) + IF( PRESENT(clinfo3) ) THEN + ! + IF( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN + WRITE(inum, "(3x,a,' : ',"//clfmt//",3x,a,' : ',"//clfmt//")") cl1, zsum1 - zvctl1, cl2, zsum2 - zvctl2 + ELSE + WRITE(inum, "(3x,a,' : ',"//clfmt//" )") cl1, zsum1 - zvctl1 + ENDIF + ! + SELECT CASE( clinfo3 ) + CASE ( 'tra-ta' ) + t_ctl(jl) = zsum1 + CASE ( 'tra' ) + t_ctl(jl) = zsum1 + s_ctl(jl) = zsum2 + CASE ( 'dyn' ) + u_ctl(jl) = zsum1 + v_ctl(jl) = zsum2 + CASE default + tra_ctl(jn,jl) = zsum1 + END SELECT + ELSEIF ( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN + WRITE(inum, "(3x,a,' : ',"//clfmt//",3x,a,' : ',"//clfmt//")") cl1, zsum1, cl2, zsum2 + ELSE + WRITE(inum, "(3x,a,' : ',"//clfmt//" )") cl1, zsum1 + ENDIF + + END DO + ENDIF + IF( jpnij == 1 ) CALL FLUSH(inum) + END DO + ! + END SUBROUTINE prt_ctl_t + + + SUBROUTINE prt_ctl_info (clinfo, ivar, cdcomp ) + !!---------------------------------------------------------------------- + !! *** ROUTINE prt_ctl_info *** + !! + !! ** Purpose : - print information without any computation + !! + !! ** Action : - input arguments + !! clinfo : information about the ivar + !! ivar : value to print + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: clinfo + INTEGER , OPTIONAL, INTENT(in) :: ivar + CHARACTER(len=3), OPTIONAL, INTENT(in) :: cdcomp ! only 'top' is accepted + ! + CHARACTER(len=3) :: clcomp + INTEGER :: jl, inum + !!---------------------------------------------------------------------- + ! + IF( PRESENT(cdcomp) ) THEN ; clcomp = cdcomp + ELSE ; clcomp = 'oce' + ENDIF + ! + DO jl = 1, SIZE(nall_ictls) + ! + IF( clcomp == 'oce' ) inum = numprt_oce(jl) + IF( clcomp == 'top' ) inum = numprt_top(jl) + ! + IF ( PRESENT(ivar) ) THEN ; WRITE(inum,*) clinfo, ivar + ELSE ; WRITE(inum,*) clinfo + ENDIF + ! + END DO + ! + END SUBROUTINE prt_ctl_info + + + SUBROUTINE prt_ctl_init( cdcomp, kntra ) + !!---------------------------------------------------------------------- + !! *** ROUTINE prt_ctl_init *** + !! + !! ** Purpose : open ASCII files & compute indices + !!---------------------------------------------------------------------- + CHARACTER(len=3), OPTIONAL, INTENT(in ) :: cdcomp ! only 'top' is accepted + INTEGER , OPTIONAL, INTENT(in ) :: kntra ! only for 'top': number of tracers + ! + INTEGER :: ji, jj, jl + INTEGER :: inum, idg, idg2 + INTEGER :: ijsplt, iimax, ijmax + INTEGER, DIMENSION(:,:), ALLOCATABLE :: iimppt, ijmppt, ijpi, ijpj, iproc + INTEGER, DIMENSION( :), ALLOCATABLE :: iipos, ijpos + LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisoce + CHARACTER(len=64) :: clfile_out + CHARACTER(LEN=64) :: clfmt, clfmt2, clfmt3, clfmt4 + CHARACTER(len=32) :: clname, cl_run + CHARACTER(len= 3) :: clcomp + !!---------------------------------------------------------------------- + ! + clname = 'output' + IF( PRESENT(cdcomp) ) THEN + clname = TRIM(clname)//'.'//TRIM(cdcomp) + clcomp = cdcomp + ELSE + clcomp = 'oce' + ENDIF + ! + IF( jpnij > 1 ) THEN ! MULTI processor run + cl_run = 'MULTI processor run' + idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg ! '(a,ix.x)' + WRITE(clfile_out,clfmt) 'mpp.'//trim(clname)//'_', narea - 1 + ijsplt = 1 + ELSE ! MONO processor run + cl_run = 'MONO processor run ' + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'prt_ctl_init: sn_cfctl%l_prtctl parameters' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + IF( nn_ictls+nn_ictle+nn_jctls+nn_jctle == 0 ) THEN ! print control done over the default area + nn_isplt = MAX(1, nn_isplt) ! number of processors following i-direction + nn_jsplt = MAX(1, nn_jsplt) ! number of processors following j-direction + ijsplt = nn_isplt * nn_jsplt ! total number of processors ijsplt + IF( ijsplt == 1 ) CALL ctl_warn( 'nn_isplt & nn_jsplt are equal to 1 -> control sum done over the whole domain' ) + IF(lwp) WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt + IF(lwp) WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt + idg = MAX( INT(LOG10(REAL(MAX(1,ijsplt-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg ! '(a,ix.x)' + IF( ijsplt == 1 ) WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', 0 + ELSE ! print control done over a specific area + ijsplt = 1 + IF( nn_ictls < 1 .OR. nn_ictls > Ni0glo ) THEN + CALL ctl_warn( ' - nictls must be 1<=nictls>=Ni0glo, it is forced to 1' ) + nn_ictls = 1 + ENDIF + IF( nn_ictle < 1 .OR. nn_ictle > Ni0glo ) THEN + CALL ctl_warn( ' - nictle must be 1<=nictle>=Ni0glo, it is forced to Ni0glo' ) + nn_ictle = Ni0glo + ENDIF + IF( nn_jctls < 1 .OR. nn_jctls > Nj0glo ) THEN + CALL ctl_warn( ' - njctls must be 1<=njctls>=Nj0glo, it is forced to 1' ) + nn_jctls = 1 + ENDIF + IF( nn_jctle < 1 .OR. nn_jctle > Nj0glo ) THEN + CALL ctl_warn( ' - njctle must be 1<=njctle>=Nj0glo, it is forced to Nj0glo' ) + nn_jctle = Nj0glo + ENDIF + WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls + WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle + WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls + WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle + idg = MAXVAL( (/ nn_ictls,nn_ictle,nn_jctls,nn_jctle /) ) ! temporary use of idg to store the largest index + idg = MAX( INT(LOG10(REAL(idg,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(4(a,i', i1, '.', i1, '))')") idg, idg ! '(4(a,ix.x))' + WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', nn_ictls, '_', nn_ictle, '_', nn_jctls, '_', nn_jctle + ENDIF + ENDIF + + ! Allocate arrays + IF( .NOT. ALLOCATED(nall_ictls) ) ALLOCATE( nall_ictls(ijsplt), nall_ictle(ijsplt), nall_jctls(ijsplt), nall_jctle(ijsplt) ) + + IF( jpnij > 1 ) THEN ! MULTI processor run + ! + nall_ictls(1) = Nis0 + nall_ictle(1) = Nie0 + nall_jctls(1) = Njs0 + nall_jctle(1) = Nje0 + ! + ELSE ! MONO processor run + ! + IF( nn_ictls+nn_ictle+nn_jctls+nn_jctle == 0 ) THEN ! print control done over the default area + ! + ALLOCATE( iimppt(nn_isplt,nn_jsplt), ijmppt(nn_isplt,nn_jsplt), ijpi(nn_isplt,nn_jsplt), ijpj(nn_isplt,nn_jsplt), & + & llisoce(nn_isplt,nn_jsplt), iproc(nn_isplt,nn_jsplt), iipos(nn_isplt*nn_jsplt), ijpos(nn_isplt*nn_jsplt) ) + CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, nn_isplt, nn_jsplt, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj ) + CALL mpp_is_ocean( llisoce ) + CALL mpp_getnum( llisoce, iproc, iipos, ijpos ) + ! + DO jj = 1,nn_jsplt + DO ji = 1, nn_isplt + jl = iproc(ji,jj) + 1 + nall_ictls(jl) = iimppt(ji,jj) - 1 + 1 + nn_hls + nall_ictle(jl) = iimppt(ji,jj) - 1 + ijpi(ji,jj) - nn_hls + nall_jctls(jl) = ijmppt(ji,jj) - 1 + 1 + nn_hls + nall_jctle(jl) = ijmppt(ji,jj) - 1 + ijpj(ji,jj) - nn_hls + END DO + END DO + ! + DEALLOCATE( iimppt, ijmppt, ijpi, ijpj, llisoce, iproc, iipos, ijpos ) + ! + ELSE ! print control done over a specific area + ! + nall_ictls(1) = nn_ictls + nn_hls + nall_ictle(1) = nn_ictle + nn_hls + nall_jctls(1) = nn_jctls + nn_hls + nall_jctle(1) = nn_jctle + nn_hls + ! + ENDIF + ENDIF + + ! Initialization + IF( clcomp == 'oce' ) THEN + ALLOCATE( t_ctl(ijsplt), s_ctl(ijsplt), u_ctl(ijsplt), v_ctl(ijsplt), numprt_oce(ijsplt) ) + t_ctl(:) = 0.e0 + s_ctl(:) = 0.e0 + u_ctl(:) = 0.e0 + v_ctl(:) = 0.e0 + ENDIF + IF( clcomp == 'top' ) THEN + ALLOCATE( tra_ctl(kntra,ijsplt), numprt_top(ijsplt) ) + tra_ctl(:,:) = 0.e0 + ENDIF + + DO jl = 1,ijsplt + + IF( ijsplt > 1 ) WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', jl-1 + + CALL ctl_opn( inum, clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. ) + IF( clcomp == 'oce' ) numprt_oce(jl) = inum + IF( clcomp == 'top' ) numprt_top(jl) = inum + WRITE(inum,*) + WRITE(inum,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC' + WRITE(inum,*) ' NEMO team' + WRITE(inum,*) ' Ocean General Circulation Model' + IF( clcomp == 'oce' ) WRITE(inum,*) ' NEMO version 4.x (2020) ' + IF( clcomp == 'top' ) WRITE(inum,*) ' TOP vversion x (2020) ' + WRITE(inum,*) + IF( ijsplt > 1 ) & + & WRITE(inum,*) ' MPI-subdomain number: ', jl-1 + IF( jpnij > 1 ) & + & WRITE(inum,*) ' MPI-subdomain number: ', narea-1 + WRITE(inum,*) + WRITE(inum,'(19x,a20)') cl_run + WRITE(inum,*) + WRITE(inum,*) 'prt_ctl : Sum control indices' + WRITE(inum,*) '~~~~~~~' + WRITE(inum,*) + ! + ! clfmt2: ' ----- jctle = XXX (YYY) -----' -> '(18x, 13a1, a9, iM, a2, iN, a2, 13a1)' + ! clfmt3: ' | |' -> '(18x, a1, Nx, a1)' + ! clfmt4: ' ictls = XXX (YYY) ictle = XXX (YYY)' -> '(Nx, a9, iM, a2, iP, a2, Qx, a9, iM, a2, iP, a2)' + ! ' | |' + ! ' ----- jctle = XXX (YYY) -----' + ! clfmt5: ' njmpp = XXX' -> '(Nx, a9, iM)' + ! clfmt6: ' nimpp = XXX' -> '(Nx, a9, iM)' + ! + idg = MAXVAL( (/ nall_ictls(jl), nall_ictle(jl), nall_jctls(jl), nall_jctle(jl) /) ) ! temporary use of idg + idg = INT(LOG10(REAL(idg,wp))) + 1 ! how many digits do we use? + idg2 = MAXVAL( (/ mig0(nall_ictls(jl)), mig0(nall_ictle(jl)), mjg0(nall_jctls(jl)), mjg0(nall_jctle(jl)) /) ) + idg2 = INT(LOG10(REAL(idg2,wp))) + 1 ! how many digits do we use? + WRITE(clfmt2, "('(18x, 13a1, a9, i', i1, ', a2, i',i1,', a2, 13a1)')") idg, idg2 + WRITE(clfmt3, "('(18x, a1, ', i2,'x, a1)')") 13+9+idg+2+idg2+2+13 - 2 + WRITE(clfmt4, "('(', i2,'x, a9, i', i1,', a2, i', i1,', a2, ', i2,'x, a9, i', i1,', a2, i', i1,', a2)')") & + & 18-7, idg, idg2, 13+9+idg+2+idg2+2+13 - (2+idg+2+idg2+2+8), idg, idg2 + WRITE(inum,clfmt2) ('-', ji=1,13), ' jctle = ', nall_jctle(jl), ' (', mjg0(nall_jctle(jl)), ') ', ('-', ji=1,13) + WRITE(inum,clfmt3) '|', '|' + WRITE(inum,clfmt3) '|', '|' + WRITE(inum,clfmt3) '|', '|' + WRITE(inum,clfmt4) ' ictls = ', nall_ictls(jl), ' (', mig0(nall_ictls(jl)), ') ', & + & ' ictle = ', nall_ictle(jl), ' (', mig0(nall_ictle(jl)), ') ' + WRITE(inum,clfmt3) '|', '|' + WRITE(inum,clfmt3) '|', '|' + WRITE(inum,clfmt3) '|', '|' + WRITE(inum,clfmt2) ('-', ji=1,13), ' jctls = ', nall_jctls(jl), ' (', mjg0(nall_jctls(jl)), ') ', ('-', ji=1,13) + WRITE(inum,*) + WRITE(inum,*) + ! + END DO + ! + END SUBROUTINE prt_ctl_init + + + !!====================================================================== +END MODULE prtctl diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/restart.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/restart.F90 new file mode 100644 index 0000000..1df1802 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/IOM/restart.F90 @@ -0,0 +1,440 @@ +MODULE restart + !!====================================================================== + !! *** MODULE restart *** + !! Ocean restart : write the ocean restart file + !!====================================================================== + !! History : OPA ! 1999-11 (M. Imbard) Original code + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form + !! 2.0 ! 2006-07 (S. Masson) use IOM for restart + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) modified LF-RA + !! - - ! 2010-10 (C. Ethe, G. Madec) TRC-TRA merge (T-S in 4D) + !! 3.7 ! 2014-01 (G. Madec) suppression of curl and hdiv from the restart + !! - ! 2014-12 (G. Madec) remove KPP scheme + !! 4.1 ! 2020-11 (S. Techene, G. Madec) move ssh initiatlisation in rst_read_ssh + !! - ! add restart in Shallow Water Eq. case + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! rst_opn : open the ocean restart file for writting + !! rst_write : write the ocean restart file + !! rst_read_open : open the restart file for reading + !! rst_read : read the ocean restart file + !! rst_read_ssh : ssh set from restart or domcfg.nc file or usr_def_istat_ssh + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_ice ! only lk_si3 + USE phycst ! physical constants + USE eosbn2 ! equation of state + USE wet_dry ! Wetting/Drying flux limiting + USE usrdef_istate, ONLY : usr_def_istate_ssh ! user defined ssh initial state + USE trdmxl_oce ! ocean active mixed layer tracers trends variables + USE diu_bulk ! ??? +#if defined key_agrif + USE agrif_oce_interp +#endif + ! + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE lib_mpp ! distribued memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC rst_opn ! called by step.F90 + PUBLIC rst_write ! called by step.F90 + PUBLIC rst_read_open ! called in rst_read_ssh + PUBLIC rst_read ! called by istate.F90 + PUBLIC rst_read_ssh ! called by domain.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: restart.F90 15141 2021-07-23 14:20:12Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE rst_opn( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE rst_opn *** + !! + !! ** Purpose : + initialization (should be read in the namelist) of nitrst + !! + open the restart when we are one time step before nitrst + !! - restart header is defined when kt = nitrst-1 + !! - restart data are written when kt = nitrst + !! + define lrst_oce to .TRUE. when we need to define or write the restart + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step + !! + CHARACTER(LEN=20) :: clkt ! ocean time-step deine as a character + CHARACTER(LEN=50) :: clname ! ocean output restart file name + CHARACTER(lc) :: clpath ! full path to ocean output restart file + CHARACTER(LEN=52) :: clpname ! ocean output restart file name including prefix for AGRIF + CHARACTER(LEN=256) :: clinfo ! info character + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN ! default definitions + lrst_oce = .FALSE. + IF( ln_rst_list ) THEN + nrst_lst = 1 + nitrst = nn_stocklist( nrst_lst ) + ELSE + nitrst = nitend + ENDIF + ENDIF + + IF( .NOT. ln_rst_list .AND. nn_stock == -1 ) RETURN ! we will never do any restart + + ! frequency-based restart dumping (nn_stock) + IF( .NOT. ln_rst_list .AND. MOD( kt - 1, nn_stock ) == 0 ) THEN + ! we use kt - 1 and not kt - nit000 to keep the same periodicity from the beginning of the experiment + nitrst = kt + nn_stock - 1 ! define the next value of nitrst for restart writing + IF( nitrst > nitend ) nitrst = nitend ! make sure we write a restart at the end of the run + ENDIF + ! to get better performances with NetCDF format: + ! we open and define the ocean restart file one time step before writing the data (-> at nitrst - 1) + ! except if we write ocean restart files every time step or if an ocean restart file was writen at nitend - 1 + IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. ( kt == nitend .AND. .NOT. lrst_oce ) ) THEN + IF( nitrst <= nitend .AND. nitrst > 0 ) THEN + ! beware of the format used to write kt (default is i8.8, that should be large enough...) + IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst + ELSE ; WRITE(clkt, '(i8.8)') nitrst + ENDIF + ! create the file + clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_ocerst_out) + clpath = TRIM(cn_ocerst_outdir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + IF(lwp) THEN + WRITE(numout,*) + IF(.NOT.lwxios) THEN + WRITE(numout,*) ' open ocean restart NetCDF file: ',TRIM(clpath)//TRIM(clname) + IF ( snc4set%luse ) WRITE(numout,*) ' opened for NetCDF4 chunking and compression' + IF( kt == nitrst - 1 ) THEN ; WRITE(numout,*) ' kt = nitrst - 1 = ', kt + ELSE ; WRITE(numout,*) ' kt = ' , kt + ENDIF + ENDIF + ENDIF + ! + IF(.NOT.lwxios) THEN + CALL iom_open( TRIM(clpath)//TRIM(clname), numrow, ldwrt = .TRUE. ) + ELSE +#if defined key_xios + cw_ocerst_cxt = "rstw_"//TRIM(ADJUSTL(clkt)) + IF( TRIM(Agrif_CFixed()) == '0' ) THEN + clpname = clname + ELSE + clpname = TRIM(Agrif_CFixed())//"_"//clname + ENDIF + numrow = iom_xios_setid(TRIM(clpath)//TRIM(clpname)) + CALL iom_init( cw_ocerst_cxt, kdid = numrow, ld_closedef = .false. ) + CALL iom_swap( cxios_context ) +#else + clinfo = 'Can not use XIOS in rst_opn' + CALL ctl_stop(TRIM(clinfo)) +#endif + ENDIF + lrst_oce = .TRUE. + ENDIF + ENDIF + ! + END SUBROUTINE rst_opn + + + SUBROUTINE rst_write( kt, Kbb, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE rstwrite *** + !! + !! ** Purpose : Write restart fields in NetCDF format + !! + !! ** Method : Write in numrow when kt == nitrst in NetCDF + !! file, save fields which are necessary for restart + !! + !! NB: ssh is written here (rst_write) + !! but is read or set in rst_read_ssh + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + !!---------------------------------------------------------------------- + ! + CALL iom_rstput( kt, nitrst, numrow, 'rdt' , rn_Dt ) ! dynamics time step + ! + IF( .NOT.lwxios ) CALL iom_delay_rst( 'WRITE', 'OCE', numrow ) ! save only ocean delayed global communication variables + ! + IF( .NOT.ln_diurnal_only ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'sshb', ssh(:,: ,Kbb) ) ! before fields + CALL iom_rstput( kt, nitrst, numrow, 'ub' , uu(:,:,: ,Kbb) ) + CALL iom_rstput( kt, nitrst, numrow, 'vb' , vv(:,:,: ,Kbb) ) + CALL iom_rstput( kt, nitrst, numrow, 'tb' , ts(:,:,:,jp_tem,Kbb) ) + CALL iom_rstput( kt, nitrst, numrow, 'sb' , ts(:,:,:,jp_sal,Kbb) ) + ! +#if ! defined key_RK3 + CALL iom_rstput( kt, nitrst, numrow, 'sshn', ssh(:,: ,Kmm) ) ! now fields + CALL iom_rstput( kt, nitrst, numrow, 'un' , uu(:,:,: ,Kmm) ) + CALL iom_rstput( kt, nitrst, numrow, 'vn' , vv(:,:,: ,Kmm) ) + CALL iom_rstput( kt, nitrst, numrow, 'tn' , ts(:,:,:,jp_tem,Kmm) ) + CALL iom_rstput( kt, nitrst, numrow, 'sn' , ts(:,:,:,jp_sal,Kmm) ) + IF( .NOT.lk_SWE ) CALL iom_rstput( kt, nitrst, numrow, 'rhop', rhop ) +#endif + ENDIF + + IF( ln_diurnal ) CALL iom_rstput( kt, nitrst, numrow, 'Dsst', x_dsst ) + IF( kt == nitrst ) THEN + IF( .NOT.lwxios ) THEN + CALL iom_close( numrow ) ! close the restart file (only at last time step) + ELSE + CALL iom_context_finalize( cw_ocerst_cxt ) + iom_file(numrow)%nfid = 0 + numrow = 0 + ENDIF +!!gm IF( .NOT. lk_trdmld ) lrst_oce = .FALSE. +!!gm not sure what to do here ===>>> ask to Sebastian + lrst_oce = .FALSE. + IF( ln_rst_list ) THEN + nrst_lst = MIN(nrst_lst + 1, SIZE(nn_stocklist,1)) + nitrst = nn_stocklist( nrst_lst ) + ENDIF + ENDIF + ! + END SUBROUTINE rst_write + + + SUBROUTINE rst_read_open + !!---------------------------------------------------------------------- + !! *** ROUTINE rst_read_open *** + !! + !! ** Purpose : Open read files for NetCDF restart + !! + !! ** Method : Use a non-zero, positive value of numror to assess whether or not + !! the file has already been opened + !!---------------------------------------------------------------------- + LOGICAL :: llok + CHARACTER(len=lc) :: clpath ! full path to ocean output restart file + CHARACTER(len=lc+2) :: clpname ! file name including agrif prefix + !!---------------------------------------------------------------------- + ! + IF( numror <= 0 ) THEN + IF(lwp) THEN ! Contol prints + WRITE(numout,*) + WRITE(numout,*) 'rst_read : read oce NetCDF restart file' + IF ( snc4set%luse ) WRITE(numout,*) 'rst_read : configured with NetCDF4 support' + WRITE(numout,*) '~~~~~~~~' + ENDIF + lxios_sini = .FALSE. + clpath = TRIM(cn_ocerst_indir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + CALL iom_open( TRIM(clpath)//cn_ocerst_in, numror ) +! are we using XIOS to read the data? Part above will have to modified once XIOS +! can handle checking if variable is in the restart file (there will be no need to open +! restart) + lrxios = lrxios.AND.lxios_sini + + IF( lrxios) THEN + cr_ocerst_cxt = 'oce_rst' + IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS' +! IF( TRIM(Agrif_CFixed()) == '0' ) THEN +! clpname = cn_ocerst_in +! ELSE +! clpname = TRIM(Agrif_CFixed())//"_"//cn_ocerst_in +! ENDIF + CALL iom_init( cr_ocerst_cxt, kdid = numror, ld_closedef = .TRUE. ) + CALL iom_swap( cxios_context ) + ENDIF + + ENDIF + + END SUBROUTINE rst_read_open + + + SUBROUTINE rst_read( Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE rst_read *** + !! + !! ** Purpose : Read velocity and T-S fields in the restart file + !! + !! ** Method : Read in restart.nc fields which are necessary for restart + !! + !! NB: restart file openned in DOM/domain.F90:dom_init + !! before field in restart tested in DOM/domain.F90:dom_init + !! (sshb) + !! + !! NB: ssh is read or set in rst_read_ssh + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: Kbb, Kmm ! ocean time level indices + INTEGER :: jk + REAL(wp), DIMENSION(jpi, jpj, jpk) :: w3d + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zgdept ! 3D workspace for QCO + !!---------------------------------------------------------------------- + ! + IF(.NOT.lrxios ) CALL iom_delay_rst( 'READ', 'OCE', numror ) ! read only ocean delayed global communication variables + ! + ! !* Diurnal DSST + IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst ) + IF( ln_diurnal_only ) THEN + IF(lwp) WRITE( numout, * ) & + & "rst_read:- ln_diurnal_only set, setting rhop=rho0" + rhop = rho0 + CALL iom_get( numror, jpdom_auto, 'tn' , w3d ) + ts(:,:,1,jp_tem,Kmm) = w3d(:,:,1) + RETURN + ENDIF + ! +#if defined key_RK3 + ! !* Read Kbb fields (NB: in RK3 Kmm = Kbb = Nbb) + IF(lwp) WRITE(numout,*) ' Kbb u, v and T-S fields read in the restart file' + CALL iom_get( numror, jpdom_auto, 'ub', uu(:,:,: ,Kbb), cd_type = 'U', psgn = -1._wp ) + CALL iom_get( numror, jpdom_auto, 'vb', vv(:,:,: ,Kbb), cd_type = 'V', psgn = -1._wp ) + CALL iom_get( numror, jpdom_auto, 'tb', ts(:,:,:,jp_tem,Kbb) ) + CALL iom_get( numror, jpdom_auto, 'sb', ts(:,:,:,jp_sal,Kbb) ) +#else + ! !* Read Kmm fields (MLF only) + IF(lwp) WRITE(numout,*) ' Kmm u, v and T-S fields read in the restart file' + CALL iom_get( numror, jpdom_auto, 'un', uu(:,:,: ,Kmm), cd_type = 'U', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'vn', vv(:,:,: ,Kmm), cd_type = 'V', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'tn', ts(:,:,:,jp_tem,Kmm) ) + CALL iom_get( numror, jpdom_auto, 'sn', ts(:,:,:,jp_sal,Kmm) ) + ! + IF( l_1st_euler ) THEN !* Euler restart (MLF only) + IF(lwp) WRITE(numout,*) ' Kbb u, v and T-S fields set to Kmm values' + uu(:,:,: ,Kbb) = uu(:,:,: ,Kmm) ! all before fields set to now values + vv(:,:,: ,Kbb) = vv(:,:,: ,Kmm) + ts(:,:,:,:,Kbb) = ts(:,:,:,:,Kmm) + ! + ELSE !* Leap frog restart (MLF only) + IF(lwp) WRITE(numout,*) ' Kbb u, v and T-S fields read in the restart file' + CALL iom_get( numror, jpdom_auto, 'ub', uu(:,:,: ,Kbb), cd_type = 'U', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'vb', vv(:,:,: ,Kbb), cd_type = 'V', psgn = -1._dp ) + CALL iom_get( numror, jpdom_auto, 'tb', ts(:,:,:,jp_tem,Kbb) ) + CALL iom_get( numror, jpdom_auto, 'sb', ts(:,:,:,jp_sal,Kbb) ) + ENDIF +#endif + ! + IF( .NOT.lk_SWE ) THEN + IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, jpdom_auto, 'rhop' , rhop ) ! now potential density + ELSE +#if defined key_qco + ALLOCATE( zgdept(jpi,jpj,jpk) ) + DO jk = 1, jpk + zgdept(:,:,jk) = gdept(:,:,jk,Kmm) + END DO + CALL eos( ts(:,:,:,:,Kmm), rhd, rhop, zgdept ) + DEALLOCATE( zgdept ) +#else + CALL eos( ts(:,:,:,:,Kmm), rhd, rhop, gdept(:,:,:,Kmm) ) +#endif + ENDIF + ENDIF + ! + END SUBROUTINE rst_read + + + SUBROUTINE rst_read_ssh( Kbb, Kmm, Kaa ) + !!--------------------------------------------------------------------- + !! *** ROUTINE rst_read_ssh *** + !! + !! ** Purpose : ssh initialization of the sea surface height (ssh) + !! + !! ** Method : set ssh from restart or read configuration, or user_def + !! * ln_rstart = T + !! USE of IOM library to read ssh in the restart file + !! Leap-Frog: Kbb and Kmm are read except for l_1st_euler=T + !! + !! * otherwise + !! call user defined ssh or + !! set to -ssh_ref in wet and drying case with domcfg.nc + !! + !! NB: ssh_b/n are written by restart.F90 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices + ! + INTEGER :: ji, jj, jk + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'rst_read_ssh : ssh initialization' + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + ! + ! !=============================! + IF( ln_rstart ) THEN !== Read the restart file ==! + ! !=============================! + ! +#if defined key_RK3 + ! !* RK3: Read ssh at Kbb + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Kbb sea surface height read in the restart file' + CALL iom_get( numror, jpdom_auto, 'sshb' , ssh(:,:,Kbb) ) + ! + ! !* RK3: Set ssh at Kmm for AGRIF + ssh(:,:,Kmm) = 0._wp +#else + ! !* MLF: Read ssh at Kmm + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Kmm sea surface height read in the restart file' + CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) ) + ! + IF( l_1st_euler ) THEN !* MLF: Euler at first time-step + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Euler first time step : ssh(Kbb) = ssh(Kmm)' + ssh(:,:,Kbb) = ssh(:,:,Kmm) +#if defined key_agrif + ! Set ghosts points from parent + IF (.NOT.Agrif_Root()) CALL Agrif_istate_ssh( Kbb, Kmm, Kaa, .true. ) +#endif + ! + ELSE !* MLF: read ssh at Kbb + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Kbb sea surface height read in the restart file' + CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb) ) + ENDIF +#endif + ! !============================! + ELSE !== Initialize at "rest" ==! + ! !============================! + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' initialization at rest' + ! + IF( ll_wd ) THEN !* wet and dry + ! + IF( ln_read_cfg ) THEN ! read configuration : ssh_ref is read in domain_cfg file +!!st why ssh is not masked : i.e. ssh(:,:,Kmm) = -ssh_ref*ssmask(:,:), +!!st since at the 1st time step lbclnk will be applied on ssh at Kaa but not initially at Kbb and Kmm + ssh(:,:,Kbb) = -ssh_ref + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth + ssh(ji,jj,Kbb) = rn_wdmin1 - ht_0(ji,jj) + ENDIF + END_2D + ELSE ! user define configuration case + CALL usr_def_istate_ssh( tmask, ssh(:,:,Kbb) ) + ENDIF + ! + ELSE !* user defined configuration + CALL usr_def_istate_ssh( tmask, ssh(:,:,Kbb) ) + ! + ENDIF +#if defined key_agrif + ! Set ghosts points from parent + IF (.NOT.Agrif_Root()) CALL Agrif_istate_ssh( Kbb, Kmm, Kaa, .true. ) +#endif +#if defined key_RK3 + ssh(:,:,Kmm) = 0._wp !* RK3: set Kmm to 0 for AGRIF +#else + ssh(:,:,Kmm) = ssh(:,:,Kbb) !* MLF: set now values from to before ones +#endif + ENDIF + ! + ! !==========================! + ssh(:,:,Kaa) = 0._wp !== Set to 0 for AGRIF ==! + ! !==========================! + ! + END SUBROUTINE rst_read_ssh + + !!===================================================================== +END MODULE restart diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isf_oce.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isf_oce.F90 new file mode 100644 index 0000000..3c27e9e --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isf_oce.F90 @@ -0,0 +1,271 @@ +MODULE isf_oce + !!====================================================================== + !! *** MODULE isf_oce *** + !! Ice shelves : ice shelves variables defined in memory + !!====================================================================== + !! History : 3.2 ! 2011-02 (C.Harris ) Original code isf cav + !! X.X ! 2006-02 (C. Wang ) Original code bg03 + !! 3.4 ! 2013-03 (P. Mathiot) Merging + parametrization + !! 4.1 ! 2019-09 (P. Mathiot) Split param/explicit ice shelf and re-organisation + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isf : define and allocate ice shelf variables + !!---------------------------------------------------------------------- + USE par_kind + USE par_oce , ONLY: jpi, jpj, jpk + USE in_out_manager, ONLY: wp, jpts ! I/O manager + USE lib_mpp , ONLY: ctl_stop, mpp_sum ! MPP library + USE fldread ! read input fields + + IMPLICIT NONE + + PRIVATE + + PUBLIC isf_alloc, isf_alloc_par, isf_alloc_cav, isf_alloc_cpl, isf_dealloc_cpl + ! + !------------------------------------------------------- + ! 0 : namelist parameter + !------------------------------------------------------- + ! + ! 0.1 -------- ice shelf cavity parameter -------------- + CHARACTER(LEN=256), PUBLIC :: cn_isfdir + LOGICAL , PUBLIC :: ln_isf + LOGICAL , PUBLIC :: ln_isfdebug + ! + ! 0.2 -------- ice shelf cavity opened namelist parameter ------------- + LOGICAL , PUBLIC :: ln_isfcav_mlt !: logical for the use of ice shelf parametrisation + REAL(wp) , PUBLIC :: rn_gammat0 !: temperature exchange coeficient [] + REAL(wp) , PUBLIC :: rn_gammas0 !: salinity exchange coeficient [] + REAL(wp) , PUBLIC :: rn_htbl !: Losch top boundary layer thickness [m] + REAL(wp) , PUBLIC :: rn_isfload_T !: + REAL(wp) , PUBLIC :: rn_isfload_S !: + CHARACTER(LEN=256), PUBLIC :: cn_gammablk !: gamma formulation + CHARACTER(LEN=256), PUBLIC :: cn_isfcav_mlt !: melt formulation (cavity/param) + CHARACTER(LEN=256), PUBLIC :: cn_isfload !: ice shelf load computation method + TYPE(FLD_N) , PUBLIC :: sn_isfcav_fwf !: information about the isf melting file to be read + ! + ! 0.3 -------- ice shelf cavity parametrised namelist parameter ------------- + LOGICAL , PUBLIC :: ln_isfpar_mlt !: logical for the computation of melt inside the cavity + REAL(wp) , PUBLIC :: rn_isfpar_bg03_gt0 !: temperature exchange coeficient [m/s] + CHARACTER(LEN=256), PUBLIC :: cn_isfpar_mlt !: melt formulation (cavity/param) + TYPE(FLD_N) , PUBLIC :: sn_isfpar_fwf !: information about the isf melting file to be read + TYPE(FLD_N) , PUBLIC :: sn_isfpar_zmax !: information about the grounding line depth file to be read + TYPE(FLD_N) , PUBLIC :: sn_isfpar_zmin !: information about the calving line depth file to be read + TYPE(FLD_N) , PUBLIC :: sn_isfpar_Leff !: information about the effective length file to be read + ! + ! 0.4 -------- coupling namelist parameter ------------- + LOGICAL, PUBLIC :: ln_isfcpl !: + LOGICAL, PUBLIC :: ln_isfcpl_cons !: + INTEGER, PUBLIC :: nn_drown !: + ! + !------------------------------------------------------- + ! 1 : ice shelf parameter + !------------------------------------------------------- + ! + REAL(wp), PARAMETER, PUBLIC :: rLfusisf = 0.334e6_wp !: latent heat of fusion of ice shelf [J/kg] + REAL(wp), PARAMETER, PUBLIC :: rcpisf = 2000.0_wp !: specific heat of ice shelf [J/kg/K] + REAL(wp), PARAMETER, PUBLIC :: rkappa = 1.54e-6_wp !: heat diffusivity through the ice-shelf [m2/s] + REAL(wp), PARAMETER, PUBLIC :: rhoisf = 920.0_wp !: volumic mass of ice shelf [kg/m3] + REAL(wp), PARAMETER, PUBLIC :: rtsurf = -20.0 !: surface temperature [C] + ! + !------------------------------------------------------- + ! 2 : ice shelf global variables + !------------------------------------------------------- + ! + ! 2.1 -------- ice shelf cavity parameter -------------- + LOGICAL , PUBLIC :: l_isfoasis = .FALSE. + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfload !: ice shelf load + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_oasis + ! + ! 2.2 -------- ice shelf cavity melt namelist parameter ------------- + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_cav !: + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_cav , misfkb_cav !: + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_cav, rfrac_tbl_cav !: + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_cav , fwfisf_cav_b !: before and now net fwf from the ice shelf [kg/m2/s] + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_cav_tsc , risf_cav_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s] + TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfcav_fwf !: + ! + REAL(wp) , PUBLIC :: risf_lamb1, risf_lamb2, risf_lamb3 ! freezing point linearization coeficient + ! + ! 2.3 -------- ice shelf param. melt namelist parameter ------------- + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mskisf_par !: + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt_par , misfkb_par !: + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl_par, rfrac_tbl_par !: + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwfisf_par , fwfisf_par_b !: before and now net fwf from the ice shelf [kg/m2/s] + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_par_tsc , risf_par_tsc_b !: before and now T & S isf contents [K.m/s & PSU.m/s] + TYPE(FLD), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sf_isfpar_fwf !: + ! + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf0_tbl_par !: thickness of tbl (initial value) [m] + REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfLeff !: + ! + ! 2.4 -------- coupling namelist parameter ------------- + INTEGER , PUBLIC :: nstp_iscpl !: + REAL(wp), PUBLIC :: rdt_iscpl !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfcpl_ssh, risfcpl_cons_ssh, risfcpl_cons_ssh_b !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risfcpl_vol, risfcpl_cons_vol, risfcpl_cons_vol_b !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: risfcpl_tsc, risfcpl_cons_tsc, risfcpl_cons_tsc_b !: + ! + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE isf_alloc_par() + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_alloc_par *** + !! + !! ** Purpose : + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr, ialloc + !!---------------------------------------------------------------------- + ierr = 0 ! set to zero if no array to be allocated + ! + ALLOCATE(risfLeff(jpi,jpj), STAT=ialloc) + ierr = ierr + ialloc + ! + ALLOCATE(misfkt_par(jpi,jpj), misfkb_par(jpi,jpj), STAT=ialloc ) + ierr = ierr + ialloc + ! + ALLOCATE( rfrac_tbl_par(jpi,jpj), STAT=ialloc) + ierr = ierr + ialloc + ! + ALLOCATE( rhisf_tbl_par(jpi,jpj), rhisf0_tbl_par(jpi,jpj), STAT=ialloc) + ierr = ierr + ialloc + ! + ALLOCATE( mskisf_par(jpi,jpj), STAT=ialloc) + ierr = ierr + ialloc + ! + CALL mpp_sum ( 'isf', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'isf: failed to allocate arrays.' ) + ! + END SUBROUTINE isf_alloc_par + + + SUBROUTINE isf_alloc_cav() + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_alloc_cav *** + !! + !! ** Purpose : + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr, ialloc + !!---------------------------------------------------------------------- + ierr = 0 ! set to zero if no array to be allocated + ! + ALLOCATE(misfkt_cav(jpi,jpj), misfkb_cav(jpi,jpj), STAT=ialloc ) + ierr = ierr + ialloc + ! + ALLOCATE( rfrac_tbl_cav(jpi,jpj), STAT=ialloc) + ierr = ierr + ialloc + ! + ALLOCATE( rhisf_tbl_cav(jpi,jpj), STAT=ialloc) + ierr = ierr + ialloc + ! + CALL mpp_sum ( 'isf', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'isf: failed to allocate arrays.' ) + ! + END SUBROUTINE isf_alloc_cav + + + SUBROUTINE isf_alloc_cpl() + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_alloc_cpl *** + !! + !! ** Purpose : allocate array use for the ice sheet coupling + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr, ialloc + !!---------------------------------------------------------------------- + ierr = 0 + ! + ALLOCATE( risfcpl_ssh(jpi,jpj) , risfcpl_tsc(jpi,jpj,jpk,jpts) , risfcpl_vol(jpi,jpj,jpk) , STAT=ialloc ) + ierr = ierr + ialloc + ! + risfcpl_tsc(:,:,:,:) = 0._wp ; risfcpl_vol(:,:,:) = 0._wp ; risfcpl_ssh(:,:) = 0._wp + + IF ( ln_isfcpl_cons ) THEN + ALLOCATE( risfcpl_cons_tsc(jpi,jpj,jpk,jpts) , risfcpl_cons_vol(jpi,jpj,jpk) , risfcpl_cons_ssh(jpi,jpj) , STAT=ialloc ) + ierr = ierr + ialloc + ! + risfcpl_cons_tsc(:,:,:,:) = 0._wp ; risfcpl_cons_vol(:,:,:) = 0._wp ; risfcpl_cons_ssh(:,:) = 0._wp + ! + END IF + ! + CALL mpp_sum ( 'isf', ierr ) + IF( ierr /= 0 ) CALL ctl_stop('STOP','isfcpl: failed to allocate arrays.') + ! + END SUBROUTINE isf_alloc_cpl + + + SUBROUTINE isf_dealloc_cpl() + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_dealloc_cpl *** + !! + !! ** Purpose : de-allocate useless public 3d array used for ice sheet coupling + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr, ialloc + !!---------------------------------------------------------------------- + ierr = 0 + ! + DEALLOCATE( risfcpl_ssh , risfcpl_tsc , risfcpl_vol , STAT=ialloc ) + ierr = ierr + ialloc + ! + CALL mpp_sum ( 'isf', ierr ) + IF( ierr /= 0 ) CALL ctl_stop('STOP','isfcpl: failed to deallocate arrays.') + ! + END SUBROUTINE isf_dealloc_cpl + + + SUBROUTINE isf_alloc() + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_alloc *** + !! + !! ** Purpose : allocate array used for the ice shelf cavity (cav and par) + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr, ialloc + !!---------------------------------------------------------------------- + ! + ierr = 0 ! set to zero if no array to be allocated + ! + ALLOCATE( fwfisf_par (jpi,jpj) , fwfisf_par_b(jpi,jpj) , & + & fwfisf_cav (jpi,jpj) , fwfisf_cav_b(jpi,jpj) , & + & fwfisf_oasis(jpi,jpj) , STAT=ialloc ) + ierr = ierr + ialloc + ! + ALLOCATE( risf_par_tsc(jpi,jpj,jpts) , risf_par_tsc_b(jpi,jpj,jpts) , STAT=ialloc ) + ierr = ierr + ialloc + ! + ALLOCATE( risf_cav_tsc(jpi,jpj,jpts) , risf_cav_tsc_b(jpi,jpj,jpts) , STAT=ialloc ) + ierr = ierr + ialloc + ! + ALLOCATE( risfload(jpi,jpj) , STAT=ialloc ) + ierr = ierr + ialloc + ! + ALLOCATE( mskisf_cav(jpi,jpj) , STAT=ialloc ) + ierr = ierr + ialloc + ! + CALL mpp_sum ( 'isf', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'isf: failed to allocate arrays.' ) + ! + ! initalisation of fwf and tsc array to 0 + risfload (:,:) = 0._wp + fwfisf_oasis(:,:) = 0._wp + fwfisf_par (:,:) = 0._wp ; fwfisf_par_b (:,:) = 0._wp + fwfisf_cav (:,:) = 0._wp ; fwfisf_cav_b (:,:) = 0._wp + risf_cav_tsc(:,:,:) = 0._wp ; risf_cav_tsc_b(:,:,:) = 0._wp + risf_par_tsc(:,:,:) = 0._wp ; risf_par_tsc_b(:,:,:) = 0._wp + ! + END SUBROUTINE isf_alloc + + !!====================================================================== +END MODULE isf_oce \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcav.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcav.F90 new file mode 100644 index 0000000..a100225 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcav.F90 @@ -0,0 +1,269 @@ +MODULE isfcav + !!====================================================================== + !! *** MODULE isfcav *** + !! Ice shelf cavity module : update ice shelf melting under ice + !! shelf + !!====================================================================== + !! History : 3.2 ! 2011-02 (C.Harris ) Original code isf cav + !! 3.4 ! 2013-03 (P. Mathiot) Merging + parametrization + !! 4.1 ! 2019-09 (P. Mathiot) Split ice shelf cavity and ice shelf parametrisation + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isf_cav : update ice shelf melting under ice shelf + !!---------------------------------------------------------------------- + USE isf_oce ! ice shelf public variables + ! + USE isfrst , ONLY: isfrst_write, isfrst_read ! ice shelf restart read/write subroutine + USE isfutils , ONLY: debug ! ice shelf debug subroutine + USE isftbl , ONLY: isf_tbl ! ice shelf top boundary layer properties subroutine + USE isfcavmlt, ONLY: isfcav_mlt ! ice shelf melt formulation subroutine + USE isfcavgam, ONLY: isfcav_gammats ! ice shelf melt exchange coeficient subroutine + USE isfdiags , ONLY: isf_diags_flx ! ice shelf diags subroutine + ! + USE oce , ONLY: ts, uu, vv, rn2 ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE par_oce , ONLY: jpi,jpj ! ocean space and time domain + USE phycst , ONLY: grav,rho0,rho0_rcp,r1_rho0_rcp ! physical constants + USE eosbn2 , ONLY: ln_teos10 ! use ln_teos10 or not + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE fldread ! read input field at current time step + USE lbclnk ! lbclnk + USE lib_mpp ! MPP library + + IMPLICIT NONE + + PRIVATE + + PUBLIC isf_cav, isf_cav_init ! routine called in isfmlt + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE isf_cav( kt, Kmm, ptsc, pqfwf ) + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_cav *** + !! + !! ** Purpose : handle surface boundary condition under ice shelf + !! + !! ** Method : based on Mathiot et al. (2017) + !! + !! ** Action : - compute geometry of the Losch top bournary layer (see Losch et al. 2008) + !! - depending on the chooses option + !! - compute temperature/salt in the tbl + !! - compute exchange coeficient + !! - compute heat and fwf fluxes + !! - output + !! + !! ** Convention : all fluxes are from isf to oce + !! + !!--------------------------------------------------------------------- + !!-------------------------- OUT -------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: pqfwf ! ice shelf fwf + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(inout) :: ptsc ! T & S ice shelf cavity contents + !!-------------------------- IN -------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + INTEGER, INTENT(in) :: kt ! ocean time step + !!--------------------------------------------------------------------- + LOGICAL :: lit + INTEGER :: nit, ji, jj, ikt + REAL(wp) :: zerr + REAL(wp) :: zcoef, zdku, zdkv + REAL(wp), DIMENSION(jpi,jpj) :: zqlat, zqoce, zqhc, zqh ! heat fluxes + REAL(wp), DIMENSION(jpi,jpj) :: zqh_b, zRc ! + REAL(wp), DIMENSION(jpi,jpj) :: zgammat, zgammas ! exchange coeficient + REAL(wp), DIMENSION(jpi,jpj) :: zttbl, zstbl ! temp. and sal. in top boundary layer + !!--------------------------------------------------------------------- + ! + ! compute T/S/U/V for the top boundary layer + CALL isf_tbl(Kmm, ts(:,:,:,jp_tem,Kmm), zttbl(:,:),'T', misfkt_cav, rhisf_tbl_cav, misfkb_cav, rfrac_tbl_cav ) + CALL isf_tbl(Kmm, ts(:,:,:,jp_sal,Kmm), zstbl(:,:),'T', misfkt_cav, rhisf_tbl_cav, misfkb_cav, rfrac_tbl_cav ) + ! + ! output T/S/U/V for the top boundary layer + CALL iom_put('ttbl_cav',zttbl(:,:) * mskisf_cav(:,:)) + CALL iom_put('stbl' ,zstbl(:,:) * mskisf_cav(:,:)) + ! + ! initialisation + IF ( TRIM(cn_gammablk) == 'vel_stab' ) THEN + zqoce(:,:) = -pqfwf(:,:) * rLfusisf ! + zqh_b(:,:) = ptsc(:,:,jp_tem) * rho0_rcp ! last time step total heat fluxes (to speed up convergence) + + DO_2D( 0, 0, 0, 0 ) + ikt = mikt(ji,jj) + ! compute Rc number (as done in zdfric.F90) +!!gm better to do it like in the new zdfric.F90 i.e. avm weighted Ri computation + zcoef = 0.5_wp / e3w(ji,jj,ikt+1,Kmm) + ! ! shear of horizontal velocity + zdku = zcoef * ( uu(ji-1,jj ,ikt ,Kmm) + uu(ji,jj,ikt ,Kmm) & + & -uu(ji-1,jj ,ikt+1,Kmm) - uu(ji,jj,ikt+1,Kmm) ) + zdkv = zcoef * ( vv(ji ,jj-1,ikt ,Kmm) + vv(ji,jj,ikt ,Kmm) & + & -vv(ji ,jj-1,ikt+1,Kmm) - vv(ji,jj,ikt+1,Kmm) ) + ! ! richardson number (minimum value set to zero) + zRc(ji,jj) = MAX(rn2(ji,jj,ikt+1), 1.e-20_wp) / MAX( zdku*zdku + zdkv*zdkv, 1.e-20_wp ) + END_2D + CALL lbc_lnk( 'isfmlt', zRc, 'T', 1._wp ) + ENDIF + ! + ! compute ice shelf melting + nit = 1 ; lit = .TRUE. + DO WHILE ( lit ) ! maybe just a constant number of iteration as in blk_core is fine + ! + ! compute gammat everywhere (2d) + ! useless if melt specified + IF ( TRIM(cn_isfcav_mlt) .NE. 'spe' ) THEN + CALL isfcav_gammats( Kmm, zttbl, zstbl, zqoce , pqfwf, zRc, & + & zgammat, zgammas ) + END IF + ! + ! compute tfrz, latent heat and melt (2d) + CALL isfcav_mlt(kt, zgammat, zgammas, zttbl, zstbl, & + & zqhc , zqoce, pqfwf ) + ! + ! define if we need to iterate + SELECT CASE ( cn_gammablk ) + CASE ( 'spe','vel' ) + ! no convergence needed + lit = .FALSE. + CASE ( 'vel_stab' ) + ! compute error between 2 iterations + zerr = 0._wp + DO_2D( 0, 0, 0, 0 ) + zerr = MAX( zerr, ABS(zqhc(ji,jj)+zqoce(ji,jj) - zqh_b(ji,jj)) ) + END_2D + CALL mpp_max( 'isfcav', zerr ) ! max over the global domain + ! + ! define if iteration needed + IF (nit >= 100) THEN ! too much iteration + CALL ctl_stop( 'STOP', 'isf_cav: vel_stab gamma formulation had too many iterations ...' ) + ELSE IF ( zerr <= 0.01_wp ) THEN ! convergence is achieve + lit = .FALSE. + ELSE ! converge is not yet achieve + nit = nit + 1 + zqh_b(:,:) = zqhc(:,:)+zqoce(:,:) + END IF + END SELECT + ! + END DO + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! compute heat and water flux ( > 0 from isf to oce) + pqfwf(ji,jj) = pqfwf(ji,jj) * mskisf_cav(ji,jj) + zqoce(ji,jj) = zqoce(ji,jj) * mskisf_cav(ji,jj) + zqhc (ji,jj) = zqhc(ji,jj) * mskisf_cav(ji,jj) + ! + ! compute heat content flux ( > 0 from isf to oce) + zqlat(ji,jj) = - pqfwf(ji,jj) * rLfusisf ! 2d latent heat flux (W/m2) + ! + ! total heat flux ( > 0 from isf to oce) + zqh(ji,jj) = ( zqhc (ji,jj) + zqoce(ji,jj) ) + ! + ! set temperature content + ptsc(ji,jj,jp_tem) = zqh(ji,jj) * r1_rho0_rcp + END_2D + CALL lbc_lnk( 'isfmlt', pqfwf, 'T', 1.0_wp) + ! + ! output fluxes + CALL isf_diags_flx( Kmm, misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, 'cav', pqfwf, zqoce, zqlat, zqhc) + ! + ! write restart variables (qoceisf, qhcisf, fwfisf for now and before) + IF (lrst_oce) CALL isfrst_write(kt, 'cav', ptsc, pqfwf) + ! + IF ( ln_isfdebug ) THEN + IF(lwp) WRITE(numout,*) '' + CALL debug('isf_cav: ptsc T',ptsc(:,:,1)) + CALL debug('isf_cav: ptsc S',ptsc(:,:,2)) + CALL debug('isf_cav: pqfwf fwf',pqfwf(:,:)) + IF(lwp) WRITE(numout,*) '' + END IF + ! + END SUBROUTINE isf_cav + + SUBROUTINE isf_cav_init + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_cav_init *** + !! + !! ** Purpose : initialisation of variable needed to compute melt under an ice shelf + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr + !!--------------------------------------------------------------------- + ! + !============== + ! 0: allocation + !============== + ! + CALL isf_alloc_cav() + ! + !================== + ! 1: initialisation + !================== + ! + ! top and bottom level of the 'top boundary layer' + misfkt_cav(:,:) = mikt(:,:) ; misfkb_cav(:,:) = 1 + ! + ! thickness of 'tbl' and fraction of bottom cell affected by 'tbl' + rhisf_tbl_cav(:,:) = 0.0_wp ; rfrac_tbl_cav(:,:) = 0.0_wp + ! + ! cavity mask + mskisf_cav(:,:) = (1._wp - tmask(:,:,1)) * ssmask(:,:) + !================ + ! 2: activate restart + !================ + ! + !================ + ! 3: read restart + !================ + ! + ! read cav variable from restart + IF ( ln_rstart ) CALL isfrst_read('cav', risf_cav_tsc, fwfisf_cav, risf_cav_tsc_b, fwfisf_cav_b) + ! + !========================================== + ! 3: specific allocation and initialisation (depending of scheme choice) + !========================================== + ! + SELECT CASE ( TRIM(cn_isfcav_mlt) ) + CASE( 'spe' ) + + ALLOCATE( sf_isfcav_fwf(1), STAT=ierr ) + ALLOCATE( sf_isfcav_fwf(1)%fnow(jpi,jpj,1), sf_isfcav_fwf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_isfcav_fwf, (/ sn_isfcav_fwf /), cn_isfdir, 'isf_cav_init', 'read fresh water flux isf data', 'namisf' ) + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>> The ice shelf melt inside the cavity is read from forcing files' + + CASE( '2eq' ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>> The original ISOMIP melt formulation is used to compute melt under the ice shelves' + + CASE( '3eq' ) + ! coeficient for linearisation of potential tfreez + ! Crude approximation for pressure (but commonly used) + IF ( ln_teos10 ) THEN ! linearisation from Jourdain et al. (2017) + risf_lamb1 =-0.0564_wp + risf_lamb2 = 0.0773_wp + risf_lamb3 =-7.8633e-8 * grav * rho0 + ELSE ! linearisation from table 4 (Asay-Davis et al., 2015) + risf_lamb1 =-0.0573_wp + risf_lamb2 = 0.0832_wp + risf_lamb3 =-7.5300e-8 * grav * rho0 + ENDIF + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>> The 3 equations melt formulation is used to compute melt under the ice shelves' + + CASE DEFAULT + CALL ctl_stop(' cn_isfcav_mlt method unknown (spe, 2eq, 3eq), check namelist') + END SELECT + ! + END SUBROUTINE isf_cav_init + +END MODULE isfcav \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcavgam.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcavgam.F90 new file mode 100644 index 0000000..e58a521 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcavgam.F90 @@ -0,0 +1,253 @@ +MODULE isfcavgam + !!====================================================================== + !! *** MODULE isfgammats *** + !! Ice shelf gamma module : compute exchange coeficient at the ice/ocean interface + !!====================================================================== + !! History : 4.1 ! (P. Mathiot) original + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isfcav_gammats : compute exchange coeficient gamma + !!---------------------------------------------------------------------- + USE isf_oce + USE isfutils, ONLY: debug + USE isftbl , ONLY: isf_tbl + + USE oce , ONLY: uu, vv ! ocean dynamics + USE phycst , ONLY: grav, vkarmn ! physical constant + USE eosbn2 , ONLY: eos_rab ! equation of state + USE zdfdrg , ONLY: rCd0_top, r_ke0_top ! vertical physics: top/bottom drag coef. + USE iom , ONLY: iom_put ! + USE lib_mpp , ONLY: ctl_stop + + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + ! + IMPLICIT NONE + ! + PRIVATE + ! + PUBLIC isfcav_gammats + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + ! + !!----------------------------------------------------------------------------------------------------- + !! PUBLIC SUBROUTINES + !!----------------------------------------------------------------------------------------------------- + ! + SUBROUTINE isfcav_gammats( Kmm, pttbl, pstbl, pqoce, pqfwf, pRc, pgt, pgs ) + !!---------------------------------------------------------------------- + !! ** Purpose : compute the coefficient echange for heat and fwf flux + !! + !! ** Method : select the gamma formulation + !! 3 method available (cst, vel and vel_stab) + !!--------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt , pgs ! gamma t and gamma s + !!-------------------------- IN ------------------------------------- + INTEGER :: Kmm ! ocean time level index + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqoce, pqfwf ! isf heat and fwf + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! top boundary layer tracer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pRc ! Richardson number + !!--------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: zutbl, zvtbl ! top boundary layer velocity + !!--------------------------------------------------------------------- + ! + !========================================== + ! 1.: compute velocity in the tbl if needed + !========================================== + ! + SELECT CASE ( cn_gammablk ) + CASE ( 'spe' ) + ! gamma is constant (specified in namelist) + ! nothing to do + CASE ('vel', 'vel_stab') + ! compute velocity in tbl + CALL isf_tbl(Kmm, uu(:,:,:,Kmm) ,zutbl(:,:),'U', miku, rhisf_tbl_cav) + CALL isf_tbl(Kmm, vv(:,:,:,Kmm) ,zvtbl(:,:),'V', mikv, rhisf_tbl_cav) + ! + ! mask velocity in tbl with ice shelf mask + zutbl(:,:) = zutbl(:,:) * mskisf_cav(:,:) + zvtbl(:,:) = zvtbl(:,:) * mskisf_cav(:,:) + ! + ! output + CALL iom_put('utbl',zutbl(:,:)) + CALL iom_put('vtbl',zvtbl(:,:)) + CASE DEFAULT + CALL ctl_stop('STOP','method to compute gamma (cn_gammablk) is unknown (should not see this)') + END SELECT + ! + !========================================== + ! 2.: compute gamma + !========================================== + ! + SELECT CASE ( cn_gammablk ) + CASE ( 'spe' ) ! gamma is constant (specified in namelist) + pgt(:,:) = rn_gammat0 + pgs(:,:) = rn_gammas0 + CASE ( 'vel' ) ! gamma is proportional to u* + CALL gammats_vel ( zutbl, zvtbl, rCd0_top, r_ke0_top, pgt, pgs ) + CASE ( 'vel_stab' ) ! gamma depends of stability of boundary layer and u* + CALL gammats_vel_stab (Kmm, pttbl, pstbl, zutbl, zvtbl, rCd0_top, r_ke0_top, pqoce, pqfwf, pRc, pgt, pgs ) + CASE DEFAULT + CALL ctl_stop('STOP','method to compute gamma (cn_gammablk) is unknown (should not see this)') + END SELECT + ! + !========================================== + ! 3.: output and debug + !========================================== + ! + CALL iom_put('isfgammat', pgt(:,:)) + CALL iom_put('isfgammas', pgs(:,:)) + ! + IF (ln_isfdebug) THEN + CALL debug( 'isfcav_gam pgt:', pgt(:,:) ) + CALL debug( 'isfcav_gam pgs:', pgs(:,:) ) + END IF + ! + END SUBROUTINE isfcav_gammats + ! + !!----------------------------------------------------------------------------------------------------- + !! PRIVATE SUBROUTINES + !!----------------------------------------------------------------------------------------------------- + ! + SUBROUTINE gammats_vel( putbl, pvtbl, pCd, pke2, & ! <<== in + & pgt, pgs ) ! ==>> out gammats [m/s] + !!---------------------------------------------------------------------- + !! ** Purpose : compute the coefficient echange coefficient + !! + !! ** Method : gamma is velocity dependent ( gt= gt0 * Ustar ) + !! + !! ** Reference : Asay-Davis et al., Geosci. Model Dev., 9, 2471-2497, 2016 + !!--------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt, pgs ! gammat and gammas [m/s] + !!-------------------------- IN ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: putbl, pvtbl ! velocity in the losch top boundary layer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pCd ! drag coefficient + REAL(wp), INTENT(in ) :: pke2 ! background velocity + !!--------------------------------------------------------------------- + INTEGER :: ji, jj ! loop index + REAL(wp), DIMENSION(jpi,jpj) :: zustar + !!--------------------------------------------------------------------- + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! compute ustar (AD15 eq. 27) + zustar(ji,jj) = SQRT( pCd(ji,jj) * ( putbl(ji,jj) * putbl(ji,jj) + pvtbl(ji,jj) * pvtbl(ji,jj) + pke2 ) ) * mskisf_cav(ji,jj) + ! + ! Compute gammats + pgt(ji,jj) = zustar(ji,jj) * rn_gammat0 + pgs(ji,jj) = zustar(ji,jj) * rn_gammas0 + END_2D + ! + ! output ustar + CALL iom_put('isfustar',zustar(:,:)) + ! + END SUBROUTINE gammats_vel + + SUBROUTINE gammats_vel_stab( Kmm, pttbl, pstbl, putbl, pvtbl, pCd, pke2, pqoce, pqfwf, pRc, & ! <<== in + & pgt , pgs ) ! ==>> out gammats [m/s] + !!---------------------------------------------------------------------- + !! ** Purpose : compute the coefficient echange coefficient + !! + !! ** Method : gamma is velocity dependent and stability dependent + !! + !! ** Reference : Holland and Jenkins, 1999, JPO, p1787-1800 + !!--------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pgt, pgs ! gammat and gammas + !!-------------------------- IN ------------------------------------- + INTEGER :: Kmm ! ocean time level index + REAL(wp), INTENT(in ) :: pke2 ! background velocity squared + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqoce, pqfwf ! surface heat flux and fwf flux + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pCd ! drag coeficient + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: putbl, pvtbl ! velocity in the losch top boundary layer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! tracer in the losch top boundary layer + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pRc ! Richardson number + !!--------------------------------------------------------------------- + INTEGER :: ji, jj ! loop index + INTEGER :: ikt ! local integer + REAL(wp) :: zdku, zdkv ! U, V shear + REAL(wp) :: zPr, zSc ! Prandtl and Scmidth number + REAL(wp) :: zmob, zmols ! Monin Obukov length, coriolis factor at T point + REAL(wp) :: zbuofdep, zhnu ! Bouyancy length scale, sublayer tickness + REAL(wp) :: zhmax ! limitation of mol + REAL(wp) :: zetastar ! stability parameter + REAL(wp) :: zgmolet, zgmoles, zgturb ! contribution of modelecular sublayer and turbulence + REAL(wp) :: zcoef ! temporary coef + REAL(wp) :: zdep + REAL(wp) :: zeps = 1.0e-20_wp + REAL(wp), PARAMETER :: zxsiN = 0.052_wp ! dimensionless constant + REAL(wp), PARAMETER :: znu = 1.95e-6_wp ! kinamatic viscosity of sea water (m2.s-1) + REAL(wp), DIMENSION(2) :: zts, zab + REAL(wp), DIMENSION(jpi,jpj) :: zustar ! friction velocity + !!--------------------------------------------------------------------- + ! + ! compute Pr and Sc number (eq ??) + zPr = 13.8_wp + zSc = 2432.0_wp + ! + ! compute gamma mole (eq ??) + zgmolet = 12.5_wp * zPr ** (2.0/3.0) - 6.0_wp + zgmoles = 12.5_wp * zSc ** (2.0/3.0) - 6.0_wp + ! + ! compute gamma + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + + ikt = mikt(ji,jj) + + ! compute ustar + zustar(ji,jj) = SQRT( pCd(ji,jj) * ( putbl(ji,jj) * putbl(ji,jj) + pvtbl(ji,jj) * pvtbl(ji,jj) + pke2 ) ) + + IF( zustar(ji,jj) == 0._wp ) THEN ! only for kt = 1 I think + pgt(ji,jj) = rn_gammat0 + pgs(ji,jj) = rn_gammas0 + ELSE + ! compute bouyancy + zts(jp_tem) = pttbl(ji,jj) + zts(jp_sal) = pstbl(ji,jj) + zdep = gdepw(ji,jj,ikt,Kmm) + ! + CALL eos_rab( zts, zdep, zab, Kmm ) + ! + ! compute length scale (Eq ??) + zbuofdep = grav * ( zab(jp_tem) * pqoce(ji,jj) - zab(jp_sal) * pqfwf(ji,jj) ) + ! + ! compute Monin Obukov Length + ! Maximum boundary layer depth (Eq ??) + zhmax = gdept(ji,jj,mbkt(ji,jj),Kmm) - gdepw(ji,jj,mikt(ji,jj),Kmm) -0.001_wp + ! + ! Compute Monin obukhov length scale at the surface and Ekman depth: (Eq ??) + zmob = zustar(ji,jj) ** 3 / (vkarmn * (zbuofdep + zeps)) + zmols = SIGN(1._wp, zmob) * MIN(ABS(zmob), zhmax) * tmask(ji,jj,ikt) + ! + ! compute eta* (stability parameter) (Eq ??) + zetastar = 1._wp / ( SQRT(1._wp + MAX( 0._wp, zxsiN * zustar(ji,jj) & + & / MAX( 1.e-20, ABS(ff_t(ji,jj)) * zmols * pRc(ji,jj) ) ))) + ! + ! compute the sublayer thickness (Eq ??) + zhnu = 5 * znu / MAX( 1.e-20, zustar(ji,jj) ) + ! + ! compute gamma turb (Eq ??) + zgturb = 1._wp / vkarmn * LOG(zustar(ji,jj) * zxsiN * zetastar * zetastar / MAX( 1.e-10, ABS(ff_t(ji,jj)) * zhnu )) & + & + 1._wp / ( 2 * zxsiN * zetastar ) - 1._wp / vkarmn + ! + ! compute gammats + pgt(ji,jj) = zustar(ji,jj) / (zgturb + zgmolet) + pgs(ji,jj) = zustar(ji,jj) / (zgturb + zgmoles) + END IF + END_2D + ! output ustar + CALL iom_put('isfustar',zustar(:,:)) + + END SUBROUTINE gammats_vel_stab + +END MODULE isfcavgam \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcavmlt.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcavmlt.F90 new file mode 100644 index 0000000..b6c8d30 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcavmlt.F90 @@ -0,0 +1,314 @@ +MODULE isfcavmlt + !!====================================================================== + !! *** MODULE isfcavmlt *** + !! ice shelf module : update surface ocean boundary condition under ice + !! shelves + !!====================================================================== + !! History : 4.0 ! 2019-09 (P. Mathiot) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isfcav_mlt : compute or read ice shelf fwf/heat fluxes from isf + !! to oce + !!---------------------------------------------------------------------- + + USE isf_oce ! ice shelf + USE isftbl , ONLY: isf_tbl ! ice shelf depth average + USE isfutils,ONLY: debug ! debug subroutine + + USE dom_oce ! ocean space and time domain + USE phycst , ONLY: rcp, rho0, rho0_rcp ! physical constants + USE eosbn2 , ONLY: eos_fzp ! equation of state + + USE in_out_manager ! I/O manager + USE iom , ONLY: iom_put ! I/O library + USE fldread , ONLY: fld_read, FLD, FLD_N ! + USE lib_fortran, ONLY: glob_sum ! + USE lib_mpp , ONLY: ctl_stop ! + + IMPLICIT NONE + PRIVATE + + PUBLIC isfcav_mlt + + !! * Substitutions +# include "single_precision_substitute.h90" +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +! ------------------------------------------------------------------------------------------------------- +! -------------------------------- PUBLIC SUBROUTINE ---------------------------------------------------- +! ------------------------------------------------------------------------------------------------------- + + SUBROUTINE isfcav_mlt(kt, pgt, pgs , pttbl, pstbl, & + & pqhc, pqoce, pqfwf ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE isfcav_mlt *** + !! + !! ** Purpose : compute or read ice shelf fwf/heat fluxes in the ice shelf cavity + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat and fwf fluxes + !!-------------------------- IN ------------------------------------- + INTEGER, INTENT(in) :: kt + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt , pgs ! gamma t and gamma s + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! top boundary layer tracer + !!--------------------------------------------------------------------- + ! + ! compute latent heat and melt (2d) + SELECT CASE ( cn_isfcav_mlt ) + CASE ( 'spe' ) ! ice shelf melt specified (read input file, and heat fluxes derived from + CALL isfcav_mlt_spe( kt, pstbl, & + & pqhc, pqoce, pqfwf ) + CASE ( '2eq' ) ! ISOMIP formulation (2 equations) for volume flux (Hunter et al., 2006) + CALL isfcav_mlt_2eq( pgt, pttbl, pstbl, & + & pqhc , pqoce, pqfwf ) + CASE ( '3eq' ) ! ISOMIP+ formulation (3 equations) for volume flux (Asay-Davis et al., 2015) + CALL isfcav_mlt_3eq( pgt, pgs , pttbl, pstbl, & + & pqhc, pqoce, pqfwf ) + CASE ( 'oasis' ) ! fwf pass trough oasis + CALL isfcav_mlt_oasis( kt, pstbl, & + & pqhc, pqoce, pqfwf ) + CASE DEFAULT + CALL ctl_stop('STOP', 'unknown isf melt formulation : cn_isfcav (should not see this)') + END SELECT + ! + IF (ln_isfdebug) THEN + IF(lwp) WRITE(numout,*) '' + CALL debug( 'isfcav_mlt qhc :', pqhc (:,:) ) + CALL debug( 'isfcav_mlt qoce :', pqoce(:,:) ) + CALL debug( 'isfcav_mlt qfwf :', pqfwf(:,:) ) + IF(lwp) WRITE(numout,*) '' + END IF + ! + END SUBROUTINE isfcav_mlt + +! ------------------------------------------------------------------------------------------------------- +! -------------------------------- PRIVATE SUBROUTINE --------------------------------------------------- +! ------------------------------------------------------------------------------------------------------- + + SUBROUTINE isfcav_mlt_spe(kt, pstbl, & ! <<== in + & pqhc , pqoce, pqfwf ) ! ==>> out + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE isfcav_mlt_spe *** + !! + !! ** Purpose : - read ice shelf melt from forcing file + !! - compute ocea-ice heat flux (assuming it is equal to latent heat) + !! - compute heat content flux + !!--------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes + !!-------------------------- IN ------------------------------------- + INTEGER , INTENT(in ) :: kt ! current time step + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pstbl ! salinity in tbl + !!-------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature + !!-------------------------------------------------------------------- + ! + ! Compute freezing temperature + CALL eos_fzp( pstbl(:,:), ztfrz(:,:), CASTDP(risfdep(:,:)) ) + ! + ! read input file of fwf (from isf to oce; ie melt) + CALL fld_read ( kt, 1, sf_isfcav_fwf ) + ! + ! define fwf and qoce + ! ocean heat flux is assume to be equal to the latent heat + pqfwf(:,:) = sf_isfcav_fwf(1)%fnow(:,:,1) ! fwf ( > 0 from isf to oce) + pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean heat flux ( > 0 from isf to oce) + pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce) + ! + ! output freezing point at the interface + CALL iom_put('isftfrz_cav', ztfrz(:,:) * mskisf_cav(:,:) ) + ! + END SUBROUTINE isfcav_mlt_spe + + SUBROUTINE isfcav_mlt_2eq(pgt , pttbl, pstbl, & ! <<== in + & pqhc, pqoce, pqfwf ) ! ==>> out + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE isfcav_mlt_2eq *** + !! + !! ** Purpose : Compute ice shelf fwf/heqt fluxes using ISOMIP formulation (Hunter et al., 2006) + !! + !! ** Method : The ice shelf melt latent heat is defined as being equal to the ocean/ice heat flux. + !! From this we can derived the fwf, ocean/ice heat flux and the heat content flux as being : + !! qfwf = Gammat * rho0 * Cp * ( Tw - Tfrz ) / Lf + !! qhoce = qlat + !! qhc = qfwf * Cp * Tfrz + !! + !! ** Reference : Hunter, J. R.: Specification for test models of ice shelf cavities, + !! Tech. Rep. June, Antarctic Climate & Ecosystems Cooperative Research Centre, available at: + !! http://staff.acecrc.org.au/~bkgalton/ISOMIP/test_cavities.pdf (last access: 21 July 2016), 2006. + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! hean content, ocean-ice heat and fwf fluxes + !!-------------------------- IN ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt ! temperature exchange coeficient + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! temperature and salinity in top boundary layer + !!-------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing temperature + REAL(wp), DIMENSION(jpi,jpj) :: zthd ! thermal driving + !!-------------------------------------------------------------------- + ! + ! Calculate freezing temperature + CALL eos_fzp( pstbl(:,:), ztfrz(:,:), CASTDP(risfdep(:,:)) ) + ! + ! thermal driving + zthd (:,:) = ( pttbl(:,:) - ztfrz(:,:) ) * mskisf_cav(:,:) + ! + ! compute ocean-ice heat flux and then derive fwf assuming that ocean heat flux equal latent heat + pqfwf(:,:) = pgt(:,:) * rho0_rcp * zthd(:,:) / rLfusisf ! fresh water flux ( > 0 from isf to oce) + pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocea-ice flux ( > 0 from isf to oce) + pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce) + ! + ! output thermal driving and freezinpoint at the ice shelf interface + CALL iom_put('isfthermald_cav', zthd ) + CALL iom_put('isftfrz_cav' , ztfrz(:,:) * mskisf_cav(:,:) ) + ! + END SUBROUTINE isfcav_mlt_2eq + + SUBROUTINE isfcav_mlt_3eq(pgt, pgs , pttbl, pstbl, & ! <<== in + & pqhc, pqoce, pqfwf ) ! ==>> out + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE isfcav_mlt_3eq *** + !! + !! ** Purpose : Compute ice shelf fwf/heqt fluxes using the 3 equation formulation + !! + !! ** Method : The melt rate is determined considering the heat balance, the salt balance + !! at the phase change interface and a linearisation of the equation of state. + !! + !! ** Reference : - Holland, D. M. and Jenkins, A., + !! Modeling Thermodynamic Ice-Ocean Interactions at the Base of an Ice Shelf, + !! J. Phys. Oceanogr., 29, 1999. + !! - Asay-Davis, X. S., Cornford, S. L., Durand, G., Galton-Fenzi, B. K., Gladstone, + !! R. M., Gudmundsson, G. H., Hattermann, T., Holland, D. M., Holland, D., Holland, + !! P. R., Martin, D. F., Mathiot, P., Pattyn, F., and Seroussi, H.: + !! Experimental design for three interrelated marine ice sheet and ocean model intercomparison projects: + !! MISMIP v. 3 (MISMIP +), ISOMIP v. 2 (ISOMIP +) and MISOMIP v. 1 (MISOMIP1), + !! Geosci. Model Dev., 9, 2471-2497, https://doi.org/10.5194/gmd-9-2471-2016, 2016. + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! latent heat and fwf fluxes + !!-------------------------- IN ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pgt , pgs ! heat/salt exchange coeficient + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pttbl, pstbl ! mean temperature and salinity in top boundary layer + !!-------------------------------------------------------------------- + REAL(wp) :: zeps1,zeps2,zeps3,zeps4,zeps6,zeps7 ! dummy local scalar for quadratic equation resolution + REAL(wp) :: zaqe,zbqe,zcqe,zaqer,zdis,zsfrz,zcfac ! dummy local scalar for quadratic equation resolution + REAL(wp) :: zeps = 1.e-20 + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point + REAL(wp), DIMENSION(jpi,jpj) :: zqcon ! conductive flux through the ice shelf + REAL(wp), DIMENSION(jpi,jpj) :: zthd ! thermal driving + ! + INTEGER :: ji, jj ! dummy loop indices + !!-------------------------------------------------------------------- + ! + ! compute upward heat flux zhtflx and upward water flux zwflx + ! Resolution of a 3d equation from equation 24, 25 and 26 (note conduction through the ice has been added to Eq 24) + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + ! compute coeficient to solve the 2nd order equation + zeps1 = rho0_rcp * pgt(ji,jj) + zeps2 = rLfusisf * rho0 * pgs(ji,jj) + zeps3 = rhoisf * rcpisf * rkappa / MAX(risfdep(ji,jj),zeps) + zeps4 = risf_lamb2 + risf_lamb3 * risfdep(ji,jj) + zeps6 = zeps4 - pttbl(ji,jj) + zeps7 = zeps4 - rtsurf + ! + ! solve the 2nd order equation to find zsfrz + zaqe = risf_lamb1 * (zeps1 + zeps3) + zaqer = 0.5_wp / MIN(zaqe,-zeps) + zbqe = zeps1 * zeps6 + zeps3 * zeps7 - zeps2 + zcqe = zeps2 * pstbl(ji,jj) + zdis = zbqe * zbqe - 4.0_wp * zaqe * zcqe + ! + ! Presumably zdis can never be negative because gammas is very small compared to gammat + zsfrz=(-zbqe - SQRT(zdis)) * zaqer + IF ( zsfrz < 0.0_wp ) zsfrz=(-zbqe + SQRT(zdis)) * zaqer ! check this if this if is needed + ! + ! compute t freeze (eq. 25) + ztfrz(ji,jj) = zeps4 + risf_lamb1 * zsfrz + ! + ! thermal driving + zthd(ji,jj) = ( pttbl(ji,jj) - ztfrz(ji,jj) ) + ! + ! compute the upward water and heat flux (eq. 24 and eq. 26) + pqfwf(ji,jj) = - rho0 * pgs(ji,jj) * ( zsfrz - pstbl(ji,jj) ) / MAX(zsfrz,zeps) ! fresh water flux ( > 0 from isf to oce) + pqoce(ji,jj) = - rho0_rcp * pgt(ji,jj) * zthd (ji,jj) ! ocean-ice heat flux ( > 0 from isf to oce) + pqhc (ji,jj) = rcp * pqfwf(ji,jj) * ztfrz(ji,jj) ! heat content flux ( > 0 from isf to oce) + ! + zqcon(ji,jj) = zeps3 * ( ztfrz(ji,jj) - rtsurf ) + ! + END_2D + ! + ! output conductive heat flux through the ice + CALL iom_put('qconisf', zqcon(:,:) * mskisf_cav(:,:) ) + ! + ! output thermal driving and freezing point at the interface + CALL iom_put('isfthermald_cav', zthd (:,:) * mskisf_cav(:,:) ) + CALL iom_put('isftfrz_cav' , ztfrz(:,:) * mskisf_cav(:,:) ) + ! + END SUBROUTINE isfcav_mlt_3eq + + SUBROUTINE isfcav_mlt_oasis(kt, pstbl, & ! <<== in + & pqhc , pqoce, pqfwf ) ! ==>> out + !!---------------------------------------------------------------------- + !! *** ROUTINE isfcav_mlt_oasis *** + !! + !! ** Purpose : scale the fwf read from input file by the total amount received by the sbccpl interface + !! + !! ** Purpose : - read ice shelf melt from forcing file => pattern + !! - total amount of fwf is given by sbccpl (fwfisf_cpl) + !! - scale fwf and compute heat fluxes + !! + !!--------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes + !!-------------------------- IN ------------------------------------- + INTEGER , INTENT(in ) :: kt ! current time step + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pstbl ! salinity in tbl + !!-------------------------------------------------------------------- + REAL(wp) :: zfwf_fld, zfwf_oasis ! total fwf in the forcing fields (pattern) and from the oasis interface (amount) + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature + REAL(wp), DIMENSION(jpi,jpj) :: zfwf ! 2d fwf map after scaling + !!-------------------------------------------------------------------- + ! + ! Calculate freezing temperature + CALL eos_fzp( pstbl(:,:), ztfrz(:,:), CASTDP(risfdep(:,:)) ) + ! + ! read input file of fwf from isf to oce + CALL fld_read ( kt, 1, sf_isfcav_fwf ) + ! + ! ice shelf 2d map + zfwf(:,:) = sf_isfcav_fwf(1)%fnow(:,:,1) + ! + ! compute glob sum from input file + ! (PM) should consider delay sum as in fwb (1 time step offset if I well understood) + zfwf_fld = glob_sum('isfcav_mlt', e1e2t(:,:) * zfwf(:,:)) + ! + ! compute glob sum from atm->oce ice shelf fwf + ! (PM) should consider delay sum as in fwb (1 time step offset if I well understood) + zfwf_oasis = glob_sum('isfcav_mlt', e1e2t(:,:) * fwfisf_oasis(:,:)) + ! + ! scale fwf + zfwf(:,:) = zfwf(:,:) * zfwf_oasis / zfwf_fld + ! + ! define fwf and qoce + ! ocean heat flux is assume to be equal to the latent heat + pqfwf(:,:) = zfwf(:,:) ! fwf ( > 0 from isf to oce) + pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean heat flux ( > 0 from isf to oce) + pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce) + ! + CALL iom_put('isftfrz_cav', ztfrz * mskisf_cav(:,:) ) + ! + END SUBROUTINE isfcav_mlt_oasis + +END MODULE isfcavmlt \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcpl.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcpl.F90 new file mode 100644 index 0000000..5a70f9f --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfcpl.F90 @@ -0,0 +1,778 @@ +MODULE isfcpl + !!====================================================================== + !! *** MODULE isfcpl *** + !! + !! iceshelf coupling module : module managing the coupling between NEMO and an ice sheet model + !! + !!====================================================================== + !! History : 4.1 ! 2019-07 (P. Mathiot) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isfrst : read/write iceshelf variables in/from restart + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers +#if defined key_qco + USE domqco , ONLY : dom_qco_zgr ! vertical scale factor interpolation +#elif defined key_linssh + ! ! fix in time coordinate +#else + USE domvvl , ONLY : dom_vvl_zgr ! vertical scale factor interpolation +#endif + USE domutl , ONLY : dom_ngb ! find the closest grid point from a given lon/lat position + USE isf_oce ! ice shelf variable + USE isfutils, ONLY : debug + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lib_mpp , ONLY : mpp_sum, mpp_max ! mpp routine + ! + IMPLICIT NONE + + PRIVATE + + PUBLIC isfcpl_rst_write, isfcpl_init ! iceshelf restart read and write + PUBLIC isfcpl_ssh, isfcpl_tra, isfcpl_vol, isfcpl_cons ! iceshelf correction for ssh, tra, dyn and conservation + + TYPE isfcons + INTEGER :: ii ! i global + INTEGER :: jj ! j global + INTEGER :: kk ! k level + REAL(wp):: dvol ! volume increment + REAL(wp):: dsal ! salt increment + REAL(wp):: dtem ! heat increment + REAL(wp):: lon ! lon + REAL(wp):: lat ! lat + INTEGER :: ngb ! 0/1 (valid location or not (ie on halo or no neigbourg)) + END TYPE + ! + !! * Substitutions +# include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE isfcpl_init(Kbb, Kmm, Kaa) + !!--------------------------------------------------------------------- + !! *** ROUTINE iscpl_init *** + !! + !! ** Purpose : correct ocean state for new wet cell and horizontal divergence + !! correction for the dynamical adjustement + !! + !! ** Action : - compute ssh on new wet cell + !! - compute T/S on new wet cell + !! - compute horizontal divergence correction as a volume flux + !! - compute the T/S/vol correction increment to keep trend to 0 + !! + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices + !!--------------------------------------------------------------------- + INTEGER :: id + !!---------------------------------------------------------------------- + ! + ! start on an euler time step + l_1st_euler = .TRUE. + ! + ! allocation and initialisation to 0 + CALL isf_alloc_cpl() + ! + ! check presence of variable needed for coupling + ! iom_varid return 0 if not found + id = 1 + id = id * iom_varid(numror, 'ssmask', ldstop = .false.) + id = id * iom_varid(numror, 'tmask' , ldstop = .false.) + id = id * iom_varid(numror, 'e3t_n' , ldstop = .false.) + id = id * iom_varid(numror, 'e3u_n' , ldstop = .false.) + id = id * iom_varid(numror, 'e3v_n' , ldstop = .false.) + IF(lwp) WRITE(numout,*) ' isfcpl_init:', id + IF (id == 0) THEN + IF(lwp) WRITE(numout,*) ' isfcpl_init: restart variables for ice sheet coupling are missing, skip coupling for this leg ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) '' + ELSE + ! extrapolation ssh + CALL isfcpl_ssh(Kbb, Kmm, Kaa) + ! + ! extrapolation tracer properties + CALL isfcpl_tra(Kmm) + ! + ! correction of the horizontal divergence and associated temp. and salt content flux + ! Need to : - include in the cpl cons the risfcpl_vol/tsc contribution + ! - decide how to manage thickness level change in conservation + CALL isfcpl_vol(Kmm) + ! + ! apply the 'conservation' method + IF ( ln_isfcpl_cons ) CALL isfcpl_cons(Kmm) + ! + END IF + ! + ! mask velocity properly (mask used in restart not compatible with new mask) + uu(:,:,:,Kmm) = uu(:,:,:,Kmm) * umask(:,:,:) + vv(:,:,:,Kmm) = vv(:,:,:,Kmm) * vmask(:,:,:) + ! + ! all before fields set to now values + ts (:,:,:,:,Kbb) = ts (:,:,:,:,Kmm) + uu (:,:,:,Kbb) = uu (:,:,:,Kmm) + vv (:,:,:,Kbb) = vv (:,:,:,Kmm) + ssh (:,:,Kbb) = ssh (:,:,Kmm) +#if ! defined key_qco && ! defined key_linssh + e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) +#endif + END SUBROUTINE isfcpl_init + + + SUBROUTINE isfcpl_rst_write( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE iscpl_rst_write *** + !! + !! ** Purpose : write icesheet coupling variables in restart + !! + !!-------------------------- IN -------------------------------------- + INTEGER, INTENT(in) :: kt + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!---------------------------------------------------------------------- + INTEGER :: jk ! loop index + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw ! for qco substitution + !!---------------------------------------------------------------------- + ! + DO jk = 1, jpk + ze3t(:,:,jk) = e3t(:,:,jk,Kmm) + ze3u(:,:,jk) = e3u(:,:,jk,Kmm) + ze3v(:,:,jk) = e3v(:,:,jk,Kmm) + ! + zgdepw(:,:,jk) = gdepw(:,:,jk,Kmm) + END DO + ! + CALL iom_rstput( kt, nitrst, numrow, 'tmask' , tmask ) + CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask ) + CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , ze3t ) + CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , ze3u ) + CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , ze3v ) + CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', zgdepw ) + ! + END SUBROUTINE isfcpl_rst_write + + + SUBROUTINE isfcpl_ssh(Kbb, Kmm, Kaa) + !!---------------------------------------------------------------------- + !! *** ROUTINE iscpl_ssh *** + !! + !! ** Purpose : basic guess of ssh in new wet cell + !! + !! ** Method : basic extrapolation from neigbourg cells + !! + !!---------------------------------------------------------------------- + !! + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jd, jk !! loop index + INTEGER :: jip1, jim1, jjp1, jjm1 + !! + REAL(wp):: zsummsk + REAL(wp), DIMENSION(jpi,jpj) :: zdssmask, zssmask0, zssmask_b, zssh + !!---------------------------------------------------------------------- + ! + CALL iom_get( numror, jpdom_auto, 'ssmask' , zssmask_b ) ! need to extrapolate T/S + + ! compute new ssh if we open a full water column + ! rude average of the closest neigbourgs (e1e2t not taking into account) + ! + zssh(:,:) = ssh(:,:,Kmm) + zssmask0(:,:) = zssmask_b(:,:) + ! + DO jd = 1, nn_drown + ! + zdssmask(:,:) = ssmask(:,:) - zssmask0(:,:) + DO_2D( 0, 0, 0, 0 ) + jip1=ji+1 ; jim1=ji-1 + jjp1=jj+1 ; jjm1=jj-1 + ! + zsummsk = zssmask0(jip1,jj) + zssmask0(jim1,jj) + zssmask0(ji,jjp1) + zssmask0(ji,jjm1) + ! + IF (zdssmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp) THEN + ssh(ji,jj,Kmm)=( zssh(jip1,jj)*zssmask0(jip1,jj) & + & + zssh(jim1,jj)*zssmask0(jim1,jj) & + & + zssh(ji,jjp1)*zssmask0(ji,jjp1) & + & + zssh(ji,jjm1)*zssmask0(ji,jjm1)) / zsummsk + zssmask_b(ji,jj) = 1._wp + ENDIF + END_2D + CALL lbc_lnk( 'isfcpl', ssh(:,:,Kmm), 'T', 1.0_dp) + CALL lbc_lnk( 'isfcpl', zssmask_b(:,:), 'T', 1.0_wp ) + ! + zssh(:,:) = ssh(:,:,Kmm) + zssmask0(:,:) = zssmask_b(:,:) + ! + ! + END DO + ! + ! update ssh(:,:,Kmm) + ssh(:,:,Kmm) = zssh(:,:) * ssmask(:,:) + ! + ssh(:,:,Kbb) = ssh(:,:,Kmm) + ! + IF ( ln_isfdebug ) CALL debug('isfcpl_ssh: sshn',CASTSP(ssh(:,:,Kmm))) + ! + ! recompute the vertical scale factor, depth and water thickness + IF(lwp) write(numout,*) 'isfcpl_ssh : recompute scale factor from ssh (new wet cell,Kmm)' + IF(lwp) write(numout,*) '~~~~~~~~~~~' +#if defined key_qco + CALL dom_qco_zgr(Kbb, Kmm) +#elif defined key_linssh + ! linear ssh : fix in time coord. +#else + DO jk = 1, jpk + e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + (ht_0(:,:) + ssh(:,:,Kmm)) * r1_ht_0(:,:) ) + END DO + e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) + CALL dom_vvl_zgr(Kbb, Kmm, Kaa) +#endif + ! + END SUBROUTINE isfcpl_ssh + + + SUBROUTINE isfcpl_tra(Kmm) + !!---------------------------------------------------------------------- + !! *** ROUTINE iscpl_tra *** + !! + !! ** Purpose : compute new tn, sn in case of evolving geometry of ice shelves + !! + !! ** Method : tn, sn : basic extrapolation from neigbourg cells + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b + !REAL(wp), DIMENSION(:,:,: ), INTENT(in ) :: pdepw_b !! depth w before + !! + INTEGER :: ji, jj, jk, jd !! loop index + INTEGER :: jip1, jim1, jjp1, jjm1, jkp1, jkm1 + !! + REAL(wp):: zsummsk + REAL(wp):: zdz, zdzm1, zdzp1 + !! + REAL(wp), DIMENSION(jpi,jpj) :: zdmask + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask0, zwmaskn + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask1, zwmaskb, ztmp3d + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts0 + !!---------------------------------------------------------------------- + ! + CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b ) ! need to extrapolate T/S + !CALL iom_get( numror, jpdom_auto, 'wmask' , zwmask_b ) ! need to extrapolate T/S + !CALL iom_get( numror, jpdom_auto, 'gdepw_n', zdepw_b(:,:,:) ) ! need to interpol vertical profile (vvl) + ! + ! + ! compute new T/S (interpolation) if vvl only for common wet cell in before and after wmask + !PM: Is this IF needed since change to VVL by default + !bugged : to be corrected (PM) + ! back up original t/s/mask + !tsb (:,:,:,:) = ts(:,:,:,:,Kmm) + ! + ! compute new T/S (interpolation) if vvl only for common wet cell in before and after wmask + +! IF (.NOT.ln_linssh) THEN +! DO jk = 2,jpk-1 +! DO jj = 1,jpj +! DO ji = 1,jpi +! IF (wmask(ji,jj,jk) * zwmaskb(ji,jj,jk) == 1._wp .AND. (tmask(ji,jj,1)==0._wp .OR. ztmask_b(ji,jj,1)==0._wp) ) THEN +! +! !compute weight +! zdzp1 = MAX(0._wp,pdepw_b(ji,jj,jk+1) - gdepw(ji,jj,jk+1,Kmm)) +! zdzm1 = MAX(0._wp,gdepw(ji,jj,jk ,Kmm) - pdepw_b(ji,jj,jk )) +! zdz = e3t(ji,jj,jk,Kmm) - zdzp1 - zdzm1 ! if isf : e3t = gdepw(ji,jj,jk+1,Kmm)- gdepw(ji,jj,jk,Kmm) +! +! IF (zdz .LT. 0._wp) THEN +! CALL ctl_stop( 'STOP', 'rst_iscpl : unable to compute the interpolation' ) +! END IF +! +! ts(ji,jj,jk,jp_tem,Kmm) = ( zdzp1*ts(ji,jj,jk+1,jp_tem,Kbb) & +! & + zdz *ts(ji,jj,jk ,jp_tem,Kbb) & +! & + zdzm1*ts(ji,jj,jk-1,jp_tem,Kbb) )/e3t(ji,jj,jk,Kmm) +! +! ts(ji,jj,jk,jp_sal,Kmm) = ( zdzp1*ts(ji,jj,jk+1,jp_sal,Kbb) & +! & + zdz *ts(ji,jj,jk ,jp_sal,Kbb) & +! & + zdzm1*ts(ji,jj,jk-1,jp_sal,Kbb) )/e3t(ji,jj,jk,Kmm) +! +! END IF +! END DO +! END DO +! END DO +! END IF + + zts0(:,:,:,:) = ts(:,:,:,:,Kmm) + ztmask0(:,:,:) = ztmask_b(:,:,:) + ztmask1(:,:,:) = ztmask_b(:,:,:) + ! + ! iterate the extrapolation processes nn_drown times + DO jd = 1,nn_drown ! resolution dependent (OK for ISOMIP+ case) + DO jk = 1,jpk-1 + ! + ! define new wet cell + zdmask(:,:) = tmask(:,:,jk) - ztmask0(:,:,jk); + ! + DO_2D( 0, 0, 0, 0 ) + jip1=ji+1; jim1=ji-1; + jjp1=jj+1; jjm1=jj-1; + ! + ! check if a wet neigbourg cell is present + zsummsk = ztmask0(jip1,jj ,jk) + ztmask0(jim1,jj ,jk) & + + ztmask0(ji ,jjp1,jk) + ztmask0(ji ,jjm1,jk) + ! + ! if neigbourg wet cell available at the same level + IF ( zdmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp ) THEN + ! + ! horizontal basic extrapolation + ts(ji,jj,jk,1,Kmm)=( zts0(jip1,jj ,jk,1) * ztmask0(jip1,jj ,jk) & + & + zts0(jim1,jj ,jk,1) * ztmask0(jim1,jj ,jk) & + & + zts0(ji ,jjp1,jk,1) * ztmask0(ji ,jjp1,jk) & + & + zts0(ji ,jjm1,jk,1) * ztmask0(ji ,jjm1,jk) ) / zsummsk + ts(ji,jj,jk,2,Kmm)=( zts0(jip1,jj ,jk,2) * ztmask0(jip1,jj ,jk) & + & + zts0(jim1,jj ,jk,2) * ztmask0(jim1,jj ,jk) & + & + zts0(ji ,jjp1,jk,2) * ztmask0(ji ,jjp1,jk) & + & + zts0(ji ,jjm1,jk,2) * ztmask0(ji ,jjm1,jk) ) / zsummsk + ! + ! update mask for next pass + ztmask1(ji,jj,jk)=1 + ! + ! in case no neigbourg wet cell available at the same level + ! check if a wet cell is available below + ELSEIF (zdmask(ji,jj) == 1._wp .AND. zsummsk == 0._wp) THEN + ! + ! vertical extrapolation if horizontal extrapolation failed + jkm1=max(1,jk-1) ; jkp1=min(jpk,jk+1) + ! + ! check if a wet neigbourg cell is present + zsummsk = ztmask0(ji,jj,jkm1) + ztmask0(ji,jj,jkp1) + IF (zdmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp ) THEN + ts(ji,jj,jk,1,Kmm)=( zts0(ji,jj,jkp1,1)*ztmask0(ji,jj,jkp1) & + & + zts0(ji,jj,jkm1,1)*ztmask0(ji,jj,jkm1)) / zsummsk + ts(ji,jj,jk,2,Kmm)=( zts0(ji,jj,jkp1,2)*ztmask0(ji,jj,jkp1) & + & + zts0(ji,jj,jkm1,2)*ztmask0(ji,jj,jkm1)) / zsummsk + ! + ! update mask for next pass + ztmask1(ji,jj,jk)=1._wp + END IF + END IF + END_2D + END DO + ! + CALL lbc_lnk( 'isfcpl', ts(:,:,:,jp_tem,Kmm), 'T', 1.0_dp, ts(:,:,:,jp_sal,Kmm), 'T', 1.0_dp) + CALL lbc_lnk( 'isfcpl', ztmask1, 'T', 1.0_wp) + ! + ! update temperature and salinity and mask + zts0(:,:,:,:) = ts(:,:,:,:,Kmm) + ztmask0(:,:,:) = ztmask1(:,:,:) + ! + ! + END DO ! nn_drown + ! + ! mask new ts(:,:,:,:,Kmm) field + ts(:,:,:,jp_tem,Kmm) = zts0(:,:,:,jp_tem) * tmask(:,:,:) + ts(:,:,:,jp_sal,Kmm) = zts0(:,:,:,jp_sal) * tmask(:,:,:) + ! + ! sanity check + ! ----------------------------------------------------------------------------------------- + ! case we open a cell but no neigbour cells available to get an estimate of T and S + DO_3D( 0, 0, 0, 0, 1,jpk-1 ) + IF (tmask(ji,jj,jk) == 1._wp .AND. ts(ji,jj,jk,2,Kmm) == 0._wp) & + & CALL ctl_stop('STOP', 'failing to fill all new weet cell, & + & try increase nn_drown or activate XXXX & + & in your domain cfg computation' ) + END_3D + ! + END SUBROUTINE isfcpl_tra + + + SUBROUTINE isfcpl_vol(Kmm) + !!---------------------------------------------------------------------- + !! *** ROUTINE iscpl_vol *** + !! + !! ** Purpose : compute the correction of the local divergence to apply + !! during the first time step after the coupling. + !! + !! ** Method : - compute horizontal vol div. before/after coupling + !! - compute vertical input + !! - compute correction + !! + !!---------------------------------------------------------------------- + !! + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk + INTEGER :: ikb, ikt + !! + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zqvolb, zqvoln ! vol flux div. before/after coupling + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3u_b, ze3v_b ! vertical scale factor before/after coupling + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b ! mask before coupling + !!---------------------------------------------------------------------- + ! + CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b ) + CALL iom_get( numror, jpdom_auto, 'e3u_n' , ze3u_b ) + CALL iom_get( numror, jpdom_auto, 'e3v_n' , ze3v_b ) + ! + ! 1.0: compute horizontal volume flux divergence difference before-after coupling + ! + DO jk = 1, jpk ! Horizontal slab + ! 1.1: get volume flux before coupling (>0 out) + DO_2D( 0, 0, 0, 0 ) + zqvolb(ji,jj,jk) = & + & ( e2u(ji ,jj ) * ze3u_b(ji ,jj ,jk) * uu(ji ,jj ,jk,Kmm) & + & - e2u(ji-1,jj ) * ze3u_b(ji-1,jj ,jk) * uu(ji-1,jj ,jk,Kmm) & + & + e1v(ji ,jj ) * ze3v_b(ji ,jj ,jk) * vv(ji ,jj ,jk,Kmm) & + & - e1v(ji ,jj-1) * ze3v_b(ji ,jj-1,jk) * vv(ji ,jj-1,jk,Kmm) ) & + & * ztmask_b(ji,jj,jk) + END_2D + ! + ! 1.2: get volume flux after coupling (>0 out) + ! properly mask velocity + ! (velocity are still mask with old mask at this stage) + uu(:,:,jk,Kmm) = uu(:,:,jk,Kmm) * umask(:,:,jk) + vv(:,:,jk,Kmm) = vv(:,:,jk,Kmm) * vmask(:,:,jk) + ! compute volume flux divergence after coupling + DO_2D( 0, 0, 0, 0 ) + zqvoln(ji,jj,jk) = & + & ( e2u(ji ,jj ) * e3u(ji ,jj ,jk,Kmm) * uu(ji ,jj ,jk,Kmm) & + & - e2u(ji-1,jj ) * e3u(ji-1,jj ,jk,Kmm) * uu(ji-1,jj ,jk,Kmm) & + & + e1v(ji ,jj ) * e3v(ji ,jj ,jk,Kmm) * vv(ji ,jj ,jk,Kmm) & + & - e1v(ji ,jj-1) * e3v(ji ,jj-1,jk,Kmm) * vv(ji ,jj-1,jk,Kmm) ) & + & * tmask(ji,jj,jk) + ! + ! 1.3: get 3d volume flux difference (before - after cpl) (>0 out) + ! correction to add is _b - _n + risfcpl_vol(ji,jj,jk) = zqvolb(ji,jj,jk) - zqvoln(ji,jj,jk) + END_2D + END DO + ! + ! 2.0: include the contribution of the vertical velocity in the volume flux correction + ! + DO_2D( 0, 0, 0, 0 ) + ! + ikt = mikt(ji,jj) + IF ( ikt > 1 .AND. ssmask(ji,jj) == 1 ) THEN + risfcpl_vol(ji,jj,ikt) = risfcpl_vol(ji,jj,ikt) + SUM(zqvolb(ji,jj,1:ikt-1)) ! test sign + ENDIF + ! + END_2D + ! + CALL lbc_lnk( 'isfcpl', risfcpl_vol, 'T', 1.0_wp ) + ! + ! 3.0: set total correction (div, tr(:,:,:,:,Krhs), ssh) + ! + ! 3.1: mask volume flux divergence correction + risfcpl_vol(:,:,:) = risfcpl_vol(:,:,:) * tmask(:,:,:) + ! + ! 3.2: get 3d tr(:,:,:,:,Krhs) increment to apply at the first time step + ! temperature and salt content flux computed using local ts(:,:,:,:,Kmm) + ! (very simple advection scheme) + ! (>0 out) + risfcpl_tsc(:,:,:,jp_tem) = -risfcpl_vol(:,:,:) * ts(:,:,:,jp_tem,Kmm) + risfcpl_tsc(:,:,:,jp_sal) = -risfcpl_vol(:,:,:) * ts(:,:,:,jp_sal,Kmm) + ! + ! 3.3: ssh correction (for dynspg_ts) + risfcpl_ssh(:,:) = 0.0 + DO jk = 1,jpk + risfcpl_ssh(:,:) = risfcpl_ssh(:,:) + risfcpl_vol(:,:,jk) * r1_e1e2t(:,:) + END DO + ! + END SUBROUTINE isfcpl_vol + + + SUBROUTINE isfcpl_cons(Kmm) + !!---------------------------------------------------------------------- + !! *** ROUTINE iscpl_cons *** + !! + !! ** Purpose : compute the corrective increment in volume/salt/heat to put back the vol/heat/salt + !! removed or added during the coupling processes (wet or dry new cell) + !! + !! ** Method : - compare volume/heat/salt before and after + !! - look for the closest wet cells (share amoung neigbourgs if there are) + !! - build the correction increment to applied at each time step + !! + !!---------------------------------------------------------------------- + ! + TYPE(isfcons), DIMENSION(:),ALLOCATABLE :: zisfpts ! list of point receiving a correction + ! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!---------------------------------------------------------------------- + INTEGER :: ji , jj , jk , jproc ! loop index + INTEGER :: jip1 , jim1, jjp1, jjm1 ! dummy indices + INTEGER :: iig , ijg, ik ! dummy indices + INTEGER :: jisf ! start, end and current position in the increment array + INTEGER :: ingb, ifind ! 0/1 target found or need to be found + INTEGER :: nisfl_area ! global number of cell concerned by the wet->dry case + INTEGER, DIMENSION(jpnij) :: nisfl ! local number of cell concerned by the wet->dry case + ! + REAL(wp) :: z1_sum, z1_rdtiscpl + REAL(wp) :: zdtem, zdsal, zdvol, zratio ! tem, sal, vol increment + REAL(wp) :: zlon , zlat ! target location + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b ! mask before + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t_b ! scale factor before + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zt_b ! scale factor before + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zs_b ! scale factor before + !!---------------------------------------------------------------------- + + !============================================================================== + ! 1.0: initialisation + !============================================================================== + + ! get restart variable + CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b(:,:,:) ) ! need to extrapolate T/S + CALL iom_get( numror, jpdom_auto, 'e3t_n' , ze3t_b(:,:,:) ) + CALL iom_get( numror, jpdom_auto, 'tn' , zt_b(:,:,:) ) + CALL iom_get( numror, jpdom_auto, 'sn' , zs_b(:,:,:) ) + + ! compute run length + nstp_iscpl = nitend - nit000 + 1 + rdt_iscpl = nstp_iscpl * rn_Dt + z1_rdtiscpl = 1._wp / rdt_iscpl + + IF (lwp) WRITE(numout,*) ' nb of stp for cons = ', nstp_iscpl + IF (lwp) WRITE(numout,*) ' coupling time step = ', rdt_iscpl + + ! initialisation correction + risfcpl_cons_vol = 0.0 + risfcpl_cons_ssh = 0.0 + risfcpl_cons_tsc = 0.0 + + !============================================================================== + ! 2.0: diagnose the heat, salt and volume input and compute the correction variable + ! for case where we wet a cell or cell still wet (no change in cell status) + !============================================================================== + + DO jk = 1,jpk-1 + DO jj = Njs0,Nje0 + DO ji = Nis0,Nie0 + + ! volume diff + zdvol = e3t(ji,jj,jk,Kmm) * tmask (ji,jj,jk) & + & - ze3t_b(ji,jj,jk ) * ztmask_b(ji,jj,jk) + + ! heat diff + zdtem = ts (ji,jj,jk,jp_tem,Kmm) * e3t(ji,jj,jk,Kmm) * tmask (ji,jj,jk) & + - zt_b(ji,jj,jk) * ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk) + + ! salt diff + zdsal = ts(ji,jj,jk,jp_sal,Kmm) * e3t(ji,jj,jk,Kmm) * tmask (ji,jj,jk) & + - zs_b(ji,jj,jk) * ze3t_b(ji,jj,jk) * ztmask_b(ji,jj,jk) + + ! volume, heat and salt differences in each cell (>0 means correction is an outward flux) + ! in addition to the geometry change unconservation, need to add the divergence correction as it is flux across the boundary + risfcpl_cons_vol(ji,jj,jk) = ( zdvol * e1e2t(ji,jj) + risfcpl_vol(ji,jj,jk) ) * z1_rdtiscpl + risfcpl_cons_tsc(ji,jj,jk,jp_sal) = ( - zdsal * e1e2t(ji,jj) + risfcpl_tsc(ji,jj,jk,jp_sal) ) * z1_rdtiscpl + risfcpl_cons_tsc(ji,jj,jk,jp_tem) = ( - zdtem * e1e2t(ji,jj) + risfcpl_tsc(ji,jj,jk,jp_tem) ) * z1_rdtiscpl + + END DO + END DO + END DO + ! + !============================================================================== + ! 3.0: diagnose the heat, salt and volume input and compute the correction variable + ! for case where we close a cell + !============================================================================== + ! + ! compute the total number of point receiving a correction increment for each processor + ! local + nisfl(:)=0 + DO jk = 1,jpk-1 + DO jj = Njs0,Nje0 + DO ji = Nis0,Nie0 + jip1=MIN(ji+1,jpi) ; jim1=MAX(ji-1,1) ; jjp1=MIN(jj+1,jpj) ; jjm1=MAX(jj-1,1) ; + IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN + nisfl(narea) = nisfl(narea) + MAX(SUM(tmask(jim1:jip1,jjm1:jjp1,jk)),1._wp) + ENDIF + ENDDO + ENDDO + ENDDO + ! + ! global + CALL mpp_sum('isfcpl',nisfl ) + ! + ! allocate list of point receiving correction + ALLOCATE(zisfpts(nisfl(narea))) + ! + zisfpts(:) = isfcons(0,0,0,-HUGE(1.0), -HUGE(1.0), -HUGE(1.0), -HUGE(1.0), -HUGE(1.0), 0) + ! + ! start computing the correction and fill zisfpts + ! local + jisf = 0 + DO jk = 1,jpk-1 + DO jj = Njs0,Nje0 + DO ji = Nis0,Nie0 + IF ( tmask(ji,jj,jk) == 0._wp .AND. ztmask_b(ji,jj,jk) == 1._wp ) THEN + + jip1=MIN(ji+1,jpi) ; jim1=MAX(ji-1,1) ; jjp1=MIN(jj+1,jpj) ; jjm1=MAX(jj-1,1) ; + + zdvol = risfcpl_cons_vol(ji,jj,jk ) + zdsal = risfcpl_cons_tsc(ji,jj,jk,jp_sal) + zdtem = risfcpl_cons_tsc(ji,jj,jk,jp_tem) + + IF ( SUM( tmask(jim1:jip1,jjm1:jjp1,jk) ) > 0._wp ) THEN + ! spread correction amoung neigbourg wet cells (horizontal direction first) + ! as it is a rude correction corner and lateral cell have the same weight + ! + z1_sum = 1._wp / SUM( tmask(jim1:jip1,jjm1:jjp1,jk) ) + ! + ! lateral cells + IF (tmask(jip1,jj ,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jj , jk, zdvol, zdsal, zdtem, z1_sum) + IF (tmask(jim1,jj ,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jj , jk, zdvol, zdsal, zdtem, z1_sum) + IF (tmask(ji ,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, ji , jjp1, jk, zdvol, zdsal, zdtem, z1_sum) + IF (tmask(ji ,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, ji , jjm1, jk, zdvol, zdsal, zdtem, z1_sum) + ! + ! corner cells + IF (tmask(jip1,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jjm1, jk, zdvol, zdsal, zdtem, z1_sum) + IF (tmask(jim1,jjm1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jjm1, jk, zdvol, zdsal, zdtem, z1_sum) + IF (tmask(jim1,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jim1, jjp1, jk, zdvol, zdsal, zdtem, z1_sum) + IF (tmask(jip1,jjp1,jk) == 1) CALL update_isfpts(zisfpts, jisf, jip1, jjp1, jk, zdvol, zdsal, zdtem, z1_sum) + ! + ELSE IF ( tmask(ji,jj,jk+1) == 1._wp ) THEN + ! spread correction amoung neigbourg wet cells (vertical direction) + CALL update_isfpts(zisfpts, jisf, ji , jj , jk+1, zdvol, zdsal, zdtem, 1.0_wp, 0) + ELSE + ! need to find where to put correction in later on + CALL update_isfpts(zisfpts, jisf, ji , jj , jk , zdvol, zdsal, zdtem, 1.0_wp, 1) + END IF + END IF + END DO + END DO + END DO + ! + ! share data among all processes because for some point we need to find the closest wet point (could be on other process) + DO jproc=1,jpnij + ! + ! share total number of isf point treated for proc jproc + IF (jproc==narea) THEN + nisfl_area=nisfl(jproc) + ELSE + nisfl_area=0 + END IF + CALL mpp_max('isfcpl',nisfl_area) + ! + DO jisf = 1,nisfl_area + ! + IF (jproc==narea) THEN + ! indices (conversion to global indices and sharing) + iig = zisfpts(jisf)%ii ; ijg = zisfpts(jisf)%jj ; ik = zisfpts(jisf)%kk + ! + ! data + zdvol = zisfpts(jisf)%dvol ; zdsal = zisfpts(jisf)%dsal ; zdtem = zisfpts(jisf)%dtem + ! + ! location + zlat = zisfpts(jisf)%lat ; zlon = zisfpts(jisf)%lon + ! + ! find flag + ingb = zisfpts(jisf)%ngb + ELSE + iig =0 ; ijg =0 ; ik =0 + zdvol=-HUGE(1.0) ; zdsal=-HUGE(1.0) ; zdtem=-HUGE(1.0) + zlat =-HUGE(1.0) ; zlon =-HUGE(1.0) + ingb = 0 + END IF + ! + ! share data (need synchronisation of data as get_correction call a global com) + CALL mpp_max('isfcpl',iig) ; CALL mpp_max('isfcpl',ijg) ; CALL mpp_max('isfcpl',ik) + CALL mpp_max('isfcpl',zdvol) ; CALL mpp_max('isfcpl',zdsal) ; CALL mpp_max('isfcpl',zdtem) + CALL mpp_max('isfcpl',zlat) ; CALL mpp_max('isfcpl',zlon) + CALL mpp_max('isfcpl',ingb) + ! + ! fill the 3d correction array + CALL get_correction(iig, ijg, ik, zlon, zlat, zdvol, zdsal, zdtem, ingb) + END DO + END DO + ! + !============================================================================== + ! 4.0: finalisation and compute ssh equivalent of the volume correction + !============================================================================== + ! + ! mask + risfcpl_cons_vol(:,:,: ) = risfcpl_cons_vol(:,:,: ) * tmask(:,:,:) + risfcpl_cons_tsc(:,:,:,jp_sal) = risfcpl_cons_tsc(:,:,:,jp_sal) * tmask(:,:,:) + risfcpl_cons_tsc(:,:,:,jp_tem) = risfcpl_cons_tsc(:,:,:,jp_tem) * tmask(:,:,:) + ! + ! add lbclnk + CALL lbc_lnk( 'isfcpl', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1.0_wp, risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1.0_wp, & + & risfcpl_cons_vol(:,:,:) , 'T', 1.0_wp) + ! + ! ssh correction (for dynspg_ts) + DO jk = 1,jpk + risfcpl_cons_ssh(:,:) = risfcpl_cons_ssh(:,:) + risfcpl_cons_vol(:,:,jk) + END DO + risfcpl_cons_ssh(:,:) = risfcpl_cons_ssh(:,:) * r1_e1e2t(:,:) + ! + END SUBROUTINE isfcpl_cons + ! + SUBROUTINE update_isfpts(sisfpts, kpts, ki, kj, kk, pdvol, pdsal, pdtem, pratio, kfind) + !!--------------------------------------------------------------------- + !! *** ROUTINE update_isfpts *** + !! + !! ** Purpose : if a cell become dry, we need to put the corrective increment elsewhere + !! + !! ** Action : update the list of point + !! + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + TYPE(isfcons), DIMENSION(:), INTENT(inout) :: sisfpts + INTEGER, INTENT(inout) :: kpts + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: ki, kj, kk ! target location (kfind=0) + ! ! or source location (kfind=1) + INTEGER, INTENT(in ), OPTIONAL :: kfind ! 0 target cell already found + ! ! 1 target to be determined + REAL(wp), INTENT(in ) :: pdvol, pdsal, pdtem, pratio ! vol/sal/tem increment + ! ! and ratio in case increment span over multiple cells. + !!---------------------------------------------------------------------- + INTEGER :: ifind + !!---------------------------------------------------------------------- + ! + ! increment position + kpts = kpts + 1 + ! + ! define if we need to look for closest valid wet cell (no neighbours or neigbourg on halo) + IF ( PRESENT(kfind) ) THEN + ifind = kfind + ELSE + ifind = ( 1 - tmask_i(ki,kj) ) * tmask(ki,kj,kk) + END IF + ! + ! update isfpts structure + sisfpts(kpts) = isfcons(mig(ki), mjg(kj), kk, pratio * pdvol, pratio * pdsal, pratio * pdtem, glamt(ki,kj), gphit(ki,kj), ifind ) + ! + END SUBROUTINE update_isfpts + ! + SUBROUTINE get_correction( ki, kj, kk, plon, plat, pvolinc, psalinc, pteminc, kfind) + !!--------------------------------------------------------------------- + !! *** ROUTINE get_correction *** + !! + !! ** Action : - Find the closest valid cell if needed (wet and not on the halo) + !! - Scale the correction depending of pratio (case where multiple wet neigbourgs) + !! - Fill the correction array + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: ki, kj, kk, kfind ! target point indices + REAL(wp), INTENT(in) :: plon, plat ! target point lon/lat + REAL(wp), INTENT(in) :: pvolinc, pteminc,psalinc ! correction increment for vol/temp/salt + !!---------------------------------------------------------------------- + INTEGER :: jj, ji, iig, ijg + !!---------------------------------------------------------------------- + ! + ! define global indice of correction location + iig = ki ; ijg = kj + IF ( kfind == 1 ) CALL dom_ngb( plon, plat, iig, ijg,'T', kk) + ! + ! fill the correction array + DO jj = mj0(ijg),mj1(ijg) + DO ji = mi0(iig),mi1(iig) + ! correct the vol_flx and corresponding heat/salt flx in the closest cell + risfcpl_cons_vol(ji,jj,kk) = risfcpl_cons_vol(ji,jj,kk ) + pvolinc + risfcpl_cons_tsc(ji,jj,kk,jp_sal) = risfcpl_cons_tsc(ji,jj,kk,jp_sal) + psalinc + risfcpl_cons_tsc(ji,jj,kk,jp_tem) = risfcpl_cons_tsc(ji,jj,kk,jp_tem) + pteminc + END DO + END DO + + END SUBROUTINE get_correction + +END MODULE isfcpl diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfdiags.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfdiags.F90 new file mode 100644 index 0000000..fee3594 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfdiags.F90 @@ -0,0 +1,116 @@ +MODULE isfdiags + !!====================================================================== + !! *** MODULE isfdiags *** + !! ice shelf diagnostics module : manage the 2d and 3d flux outputs from the ice shelf module + !!====================================================================== + !! History : 3.2 ! 2011-02 (C.Harris ) Original code isf cav + !! X.X ! 2006-02 (C. Wang ) Original code bg03 + !! 3.4 ! 2013-03 (P. Mathiot) Merging + parametrization + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_isf : update sbc under ice shelf + !!---------------------------------------------------------------------- + + USE in_out_manager ! I/O manager + USE dom_oce + USE isf_oce ! ice shelf variable + USE iom ! + + IMPLICIT NONE + + PRIVATE + + PUBLIC isf_diags_flx + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE isf_diags_flx(Kmm, ktop, kbot, phtbl, pfrac, cdisf, pqfwf, pqoce, pqlat, pqhc) + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_diags_flx *** + !! + !! ** Purpose : manage the 2d and 3d flux outputs of the ice shelf module + !! from isf to oce fwf, latent heat, heat content fluxes + !! + !!---------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + !!-------------------------- IN ------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + INTEGER , DIMENSION(jpi,jpj), INTENT(in) :: ktop , kbot ! top and bottom level of the tbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phtbl, pfrac ! thickness of the tbl and fraction of last cell affected by the tbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqfwf, pqoce, pqlat, pqhc ! 2d var to map in 3d + CHARACTER(LEN=3), INTENT(in) :: cdisf ! parametrisation or interactive melt + !!--------------------------------------------------------------------- + CHARACTER(LEN=256) :: cvarqfwf , cvarqoce , cvarqlat , cvarqhc + CHARACTER(LEN=256) :: cvarqfwf3d, cvarqoce3d, cvarqlat3d, cvarqhc3d + !!--------------------------------------------------------------------- + ! + ! output melt + cvarqfwf = 'fwfisf_'//cdisf ; cvarqfwf3d = 'fwfisf3d_'//cdisf + cvarqoce = 'qoceisf_'//cdisf ; cvarqoce3d = 'qoceisf3d_'//cdisf + cvarqlat = 'qlatisf_'//cdisf ; cvarqlat3d = 'qlatisf3d_'//cdisf + cvarqhc = 'qhcisf_'//cdisf ; cvarqhc3d = 'qhcisf3d_'//cdisf + ! + ! output 2d melt rate, latent heat and heat content flux from the injected water + CALL iom_put( TRIM(cvarqfwf), pqfwf(:,:) ) ! mass flux ( > 0 from isf to oce) + CALL iom_put( TRIM(cvarqoce), pqoce(:,:) ) ! oce to ice flux ( > 0 from isf to oce) + CALL iom_put( TRIM(cvarqlat), pqlat(:,:) ) ! latent heat flux ( > 0 from isf to oce) + CALL iom_put( TRIM(cvarqhc) , pqhc (:,:) ) ! heat content flux ( > 0 from isf to oce) + ! + ! output 3d Diagnostics + IF ( iom_use( TRIM(cvarqfwf3d) ) ) CALL isf_diags_2dto3d( Kmm, ktop, kbot, phtbl, pfrac, TRIM(cvarqfwf3d) , pqfwf(:,:)) + IF ( iom_use( TRIM(cvarqoce3d) ) ) CALL isf_diags_2dto3d( Kmm, ktop, kbot, phtbl, pfrac, TRIM(cvarqoce3d) , pqoce(:,:)) + IF ( iom_use( TRIM(cvarqlat3d) ) ) CALL isf_diags_2dto3d( Kmm, ktop, kbot, phtbl, pfrac, TRIM(cvarqlat3d) , pqoce(:,:)) + IF ( iom_use( TRIM(cvarqhc3d) ) ) CALL isf_diags_2dto3d( Kmm, ktop, kbot, phtbl, pfrac, TRIM(cvarqhc3d) , pqhc (:,:)) + ! + END SUBROUTINE isf_diags_flx + + SUBROUTINE isf_diags_2dto3d(Kmm, ktop, kbot, phtbl, pfrac, cdvar, pvar2d) + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_diags_2dto3d *** + !! + !! ** Purpose : compute the 3d flux outputs as they are injected into NEMO + !! (ie uniformaly spread into the top boundary layer or parametrisation layer) + !! + !!---------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + !!-------------------------- IN ------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + INTEGER , DIMENSION(jpi,jpj), INTENT(in) :: ktop , kbot ! top and bottom level of the tbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: phtbl, pfrac ! thickness of the tbl and fraction of last cell affected by the tbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pvar2d ! 2d var to map in 3d + CHARACTER(LEN=*), INTENT(in) :: cdvar + !!--------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! loop indices + INTEGER :: ikt, ikb ! top and bottom level of the tbl + REAL(wp), DIMENSION(jpi,jpj) :: zvar2d ! + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvar3d ! 3d var to output + !!--------------------------------------------------------------------- + ! + ! compute 3d output + zvar2d(:,:) = pvar2d(:,:) / phtbl(:,:) + zvar3d(:,:,:) = 0._wp + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ikt = ktop(ji,jj) + ikb = kbot(ji,jj) + DO jk = ikt, ikb - 1 + zvar3d(ji,jj,jk) = zvar2d(ji,jj) * e3t(ji,jj,jk,Kmm) + END DO + zvar3d(ji,jj,ikb) = zvar2d(ji,jj) * e3t(ji,jj,ikb,Kmm) * pfrac(ji,jj) + END_2D + ! + CALL iom_put( TRIM(cdvar) , zvar3d(:,:,:)) + ! + END SUBROUTINE isf_diags_2dto3d + +END MODULE isfdiags \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfdynatf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfdynatf.F90 new file mode 100644 index 0000000..dbf13ba --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfdynatf.F90 @@ -0,0 +1,91 @@ +MODULE isfdynatf + !!========================================================================= + !! *** MODULE isfnxt *** + !! Ice shelf update: compute the dynatf ice shelf contribution + !!========================================================================= + !! History : OPA ! 2019-09 (P. Mathiot) Original code + !!------------------------------------------------------------------------- + + !!------------------------------------------------------------------------- + !! isfnxt : apply correction needed for the ice shelf to ensure conservation + !!------------------------------------------------------------------------- + + USE isf_oce + + USE phycst , ONLY: r1_rho0 ! physical constant + USE dom_oce ! time and space domain + USE oce, ONLY : ssh ! sea-surface height for qco substitution + + USE in_out_manager + + IMPLICIT NONE + + PRIVATE + + PUBLIC isf_dynatf + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + +CONTAINS + + SUBROUTINE isf_dynatf ( kt, Kmm, pe3t_f, pcoef ) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_dynatf *** + !! + !! ** Purpose : compute the ice shelf volume filter correction for cavity, param, ice sheet coupling case + !! + !!-------------------------- OUT ------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3t_f ! time filtered scale factor to be corrected + ! + REAL(wp) , INTENT(in ) :: pcoef ! rn_atfp * rn_Dt * r1_rho0 + !!-------------------------------------------------------------------- + INTEGER :: jk ! loop index + !!-------------------------------------------------------------------- + ! + ! ice shelf cavity + IF ( ln_isfcav_mlt ) CALL isf_dynatf_mlt(Kmm, pe3t_f, misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, fwfisf_cav, fwfisf_cav_b, pcoef) + ! + ! ice shelf parametrised + IF ( ln_isfpar_mlt ) CALL isf_dynatf_mlt(Kmm, pe3t_f, misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, fwfisf_par, fwfisf_par_b, pcoef) + ! + IF ( ln_isfcpl .AND. ln_rstart .AND. kt == nit000+1 ) THEN + DO jk = 1, jpkm1 + pe3t_f(:,:,jk) = pe3t_f(:,:,jk) - pcoef * risfcpl_vol(:,:,jk) * r1_e1e2t(:,:) + END DO + END IF + ! + END SUBROUTINE isf_dynatf + + SUBROUTINE isf_dynatf_mlt ( Kmm, pe3t_f, ktop, kbot, phtbl, pfrac, pfwf, pfwf_b, pcoef ) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_dynatf_mlt *** + !! + !! ** Purpose : compute the ice shelf volume filter correction for cavity or param + !! + !!-------------------------- IN ------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3t_f ! time-filtered scale factor to be corrected + INTEGER , DIMENSION(jpi,jpj) , INTENT(in ) :: ktop , kbot ! top and bottom level of tbl + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfrac, phtbl ! fraction of bottom cell included in tbl, tbl thickness + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf , pfwf_b ! now/before fwf + REAL(wp), INTENT(in ) :: pcoef ! rn_atfp * rn_Dt * r1_rho0 + !!---------------------------------------------------------------------- + INTEGER :: ji,jj,jk + REAL(wp), DIMENSION(jpi,jpj) :: zfwfinc + !!---------------------------------------------------------------------- + ! + ! compute fwf conservation correction + zfwfinc(:,:) = pcoef * ( pfwf_b(:,:) - pfwf(:,:) ) / ( ht(:,:) + 1._wp - ssmask(:,:) ) * r1_rho0 + ! + ! add the increment + DO jk = 1, jpkm1 + pe3t_f(:,:,jk) = pe3t_f(:,:,jk) + tmask(:,:,jk) * zfwfinc(:,:) & + & * e3t(:,:,jk,Kmm) + END DO + ! + END SUBROUTINE isf_dynatf_mlt + +END MODULE isfdynatf \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfhdiv.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfhdiv.F90 new file mode 100644 index 0000000..9503702 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfhdiv.F90 @@ -0,0 +1,145 @@ +MODULE isfhdiv + !!====================================================================== + !! *** MODULE isfhdiv *** + !! ice shelf horizontal divergence module : update the horizontal divergence + !! with the ice shelf melt and coupling correction + !!====================================================================== + !! History : 4.0 ! 2019-09 (P. Mathiot) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isf_hdiv : update the horizontal divergence with the ice shelf + !! melt and coupling correction + !!---------------------------------------------------------------------- + + USE isf_oce ! ice shelf + + USE dom_oce ! time and space domain + USE phycst , ONLY: r1_rho0 ! physical constant + USE in_out_manager ! + + IMPLICIT NONE + + PRIVATE + + PUBLIC isf_hdiv + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + +CONTAINS + + SUBROUTINE isf_hdiv( kt, Kmm, phdiv ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE isf_hdiv *** + !! + !! ** Purpose : update the horizontal divergence with the ice shelf contribution + !! (parametrisation, explicit, ice sheet coupling conservation + !! increment) + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT( inout ) :: phdiv ! horizontal divergence + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + IF ( ln_isf ) THEN + ! + ! ice shelf cavity contribution + IF ( ln_isfcav_mlt ) CALL isf_hdiv_mlt(misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, fwfisf_cav, fwfisf_cav_b, phdiv) + ! + ! ice shelf parametrisation contribution + IF ( ln_isfpar_mlt ) CALL isf_hdiv_mlt(misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, fwfisf_par, fwfisf_par_b, phdiv) + ! + ! ice sheet coupling contribution + IF ( ln_isfcpl .AND. kt /= 0 ) THEN + ! + ! Dynamical stability at start up after change in under ice shelf cavity geometry is achieve by correcting the divergence. + ! This is achieved by applying a volume flux in order to keep the horizontal divergence after remapping + ! the same as at the end of the latest time step. So correction need to be apply at nit000 (euler time step) and + ! half of it at nit000+1 (leap frog time step). + IF ( kt == nit000 ) CALL isf_hdiv_cpl(Kmm, risfcpl_vol , phdiv) + IF ( kt == nit000+1 ) CALL isf_hdiv_cpl(Kmm, risfcpl_vol*0.5_wp, phdiv) + ! + ! correct divergence every time step to remove any trend due to coupling + ! conservation option + IF ( ln_isfcpl_cons ) CALL isf_hdiv_cpl(Kmm, risfcpl_cons_vol, phdiv) + ! + END IF + ! + END IF + ! + END SUBROUTINE isf_hdiv + + SUBROUTINE isf_hdiv_mlt(ktop, kbot, phtbl, pfrac, pfwf, pfwf_b, phdiv) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE sbc_isf_div *** + !! + !! ** Purpose : update the horizontal divergence with the ice shelf inflow + !! + !! ** Method : pfwf is positive (outflow) and expressed as kg/m2/s + !! increase the divergence + !! + !! ** Action : phdivn increased by the ice shelf outflow + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phdiv + !!---------------------------------------------------------------------- + INTEGER , DIMENSION(jpi,jpj), INTENT(in ) :: ktop , kbot + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pfrac, phtbl + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pfwf , pfwf_b + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikt, ikb + REAL(wp), DIMENSION(A2D(nn_hls)) :: zhdiv + !!---------------------------------------------------------------------- + ! + !== fwf distributed over several levels ==! + ! + ! compute integrated divergence correction + DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls ) + zhdiv(ji,jj) = 0.5_wp * ( pfwf(ji,jj) + pfwf_b(ji,jj) ) * r1_rho0 / phtbl(ji,jj) + END_2D + ! + ! update divergence at each level affected by ice shelf top boundary layer + DO_2D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls ) + ikt = ktop(ji,jj) + ikb = kbot(ji,jj) + ! level fully include in the ice shelf boundary layer + DO jk = ikt, ikb - 1 + phdiv(ji,jj,jk) = phdiv(ji,jj,jk) - zhdiv(ji,jj) + END DO + ! level partially include in ice shelf boundary layer + phdiv(ji,jj,ikb) = phdiv(ji,jj,ikb) - zhdiv(ji,jj) * pfrac(ji,jj) + END_2D + ! + END SUBROUTINE isf_hdiv_mlt + + SUBROUTINE isf_hdiv_cpl(Kmm, pqvol, phdiv) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE isf_hdiv_cpl *** + !! + !! ** Purpose : update the horizontal divergence with the ice shelf + !! coupling conservation increment + !! + !! ** Method : pqvol is positive (outflow) and expressed as m3/s + !! increase the divergence + !! + !! ** Action : phdivn increased by the ice shelf outflow + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: phdiv + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pqvol + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk + !!---------------------------------------------------------------------- + ! + DO_3D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls, 1, jpk ) + phdiv(ji,jj,jk) = phdiv(ji,jj,jk) + pqvol(ji,jj,jk) * r1_e1e2t(ji,jj) & + & / e3t(ji,jj,jk,Kmm) + END_3D + ! + END SUBROUTINE isf_hdiv_cpl + +END MODULE isfhdiv \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfload.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfload.F90 new file mode 100644 index 0000000..6e35f0f --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfload.F90 @@ -0,0 +1,133 @@ +MODULE isfload + !!====================================================================== + !! *** MODULE isfload *** + !! Ice Shelves : compute ice shelf load (needed for the hpg) + !!====================================================================== + !! History : 4.1 ! 2019-09 (P. Mathiot) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isf_load : compute ice shelf load + !!---------------------------------------------------------------------- + + USE isf_oce, ONLY: cn_isfload, rn_isfload_T, rn_isfload_S ! ice shelf variables + + USE dom_oce ! vertical scale factor + USE eosbn2 , ONLY: eos ! eos routine + + USE lib_mpp, ONLY: ctl_stop ! ctl_stop routine + USE in_out_manager ! + + IMPLICIT NONE + + PRIVATE + + PUBLIC isf_load ! called by isfstp.F90 + ! + !! * Substitutions +# include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE isf_load ( Kmm, pisfload ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE isf_load *** + !! + !! ** Purpose : compute the ice shelf load + !! + !!-------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pisfload ! ice shelf load + !!---------------------------------------------------------------------- + ! + ! quality test: ice shelf in a stratify/uniform ocean should not drive any flow. + ! the smaller the residual flow is, the better it is. + ! + ! type of ice shelf cavity + SELECT CASE ( cn_isfload ) + CASE ( 'uniform' ) + CALL isf_load_uniform ( Kmm, pisfload ) + CASE DEFAULT + CALL ctl_stop('STOP','method cn_isfload to compute ice shelf load does not exist (isomip), check your namelist') + END SELECT + ! + END SUBROUTINE isf_load + + + SUBROUTINE isf_load_uniform( Kmm, pload ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE isf_load *** + !! + !! ** Purpose : compute the ice shelf load + !! + !! ** Method : The ice shelf is assumed to be in hydro static equilibrium + !! in water at -1.9 C and 34.4 PSU. Weight of the ice shelf is + !! integrated from top to bottom. + !! + !!-------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pload ! ice shelf load + ! + INTEGER :: ji, jj, jk + INTEGER :: ikt + REAL(wp), DIMENSION(jpi,jpj) :: zrhdtop_isf ! water density displaced by the ice shelf (at the interface) + REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts_top ! water properties displaced by the ice shelf + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zrhd ! water density displaced by the ice shelf + !!---------------------------------------------------------------------- + ! + ! !- assume water displaced by the ice shelf is at T=rn_isfload_T and S=rn_isfload_S (rude) + zts_top(:,:,jp_tem) = rn_isfload_T ; zts_top(:,:,jp_sal) = rn_isfload_S + ! + DO jk = 1, jpk !- compute density of the water displaced by the ice shelf +#if defined key_qco && key_isf + CALL eos( zts_top(:,:,:), gdept_0(:,:,jk), zrhd(:,:,jk) ) +#else + CALL eos( zts_top(:,:,:), CASTSP(gdept(:,:,jk,Kmm)), zrhd(:,:,jk) ) +#endif + END DO + ! + ! !- compute rhd at the ice/oce interface (ice shelf side) + CALL eos( zts_top , risfdep, zrhdtop_isf ) + ! + ! !- Surface value + ice shelf gradient + pload(:,:) = 0._wp ! compute pressure due to ice shelf load + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ikt = mikt(ji,jj) + ! + IF ( ikt > 1 ) THEN + ! ! top layer of the ice shelf +#if defined key_qco && key_isf + pload(ji,jj) = pload(ji,jj) + zrhd(ji,jj,1) * e3w_0(ji,jj,1) + ! + DO jk = 2, ikt-1 ! core layers of the ice shelf + pload(ji,jj) = pload(ji,jj) + (zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) * e3w_0(ji,jj,jk) + END DO + ! ! deepest part of the ice shelf (between deepest T point and ice/ocean interface + pload(ji,jj) = pload(ji,jj) + ( zrhdtop_isf(ji,jj) + zrhd(ji,jj,ikt-1) ) & + & * ( risfdep(ji,jj) - gdept_0(ji,jj,ikt-1) ) +#else + pload(ji,jj) = pload(ji,jj) & + & + zrhd (ji,jj,1) * e3w(ji,jj,1,Kmm) + ! + DO jk = 2, ikt-1 ! core layers of the ice shelf + pload(ji,jj) = pload(ji,jj) + (zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) & + & * e3w(ji,jj,jk,Kmm) + END DO + ! ! deepest part of the ice shelf (between deepest T point and ice/ocean interface + pload(ji,jj) = pload(ji,jj) + ( zrhdtop_isf(ji,jj) + zrhd(ji,jj,ikt-1) ) & + & * ( risfdep(ji,jj) - gdept(ji,jj,ikt-1,Kmm) ) +#endif + ! + END IF + END_2D + ! + END SUBROUTINE isf_load_uniform + + !!====================================================================== +END MODULE isfload \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfpar.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfpar.F90 new file mode 100644 index 0000000..32495a2 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfpar.F90 @@ -0,0 +1,196 @@ +MODULE isfpar + !!====================================================================== + !! *** MODULE isfpar *** + !! ice shelf module : update ocean boundary condition under ice + !! shelf + !!====================================================================== + !! History : 3.2 ! 2011-02 (C.Harris ) Original code isf cav + !! X.X ! 2006-02 (C. Wang ) Original code bg03 + !! 3.4 ! 2013-03 (P. Mathiot) Merging + parametrization + !! 4.1 ! 2019-09 (P. Mathiot) Restructuration + !! 4.2 ! 2021-05 (C. Ethe ) Test and fix oasis case + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isfpar : compute ice shelf melt using a prametrisation of ice shelf cavities + !!---------------------------------------------------------------------- + USE isf_oce ! ice shelf + ! + USE isfrst , ONLY: isfrst_write, isfrst_read ! ice shelf restart read/write subroutine + USE isftbl , ONLY: isf_tbl_ktop, isf_tbl_lvl ! ice shelf top boundary layer properties subroutine + USE isfparmlt, ONLY: isfpar_mlt ! ice shelf melt formulation subroutine + USE isfdiags , ONLY: isf_diags_flx ! ice shelf diags subroutine + USE isfutils , ONLY: debug, read_2dcstdta ! ice shelf debug subroutine + ! + USE dom_oce , ONLY: bathy ! ocean space and time domain + USE par_oce , ONLY: jpi,jpj ! ocean space and time domain + USE phycst , ONLY: r1_rho0_rcp ! physical constants + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE fldread ! read input field at current time step + + IMPLICIT NONE + PRIVATE + + PUBLIC isf_par, isf_par_init + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE isf_par( kt, Kmm, ptsc, pqfwf ) + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_par *** + !! + !! ** Purpose : compute the heat and fresh water due to ice shelf melting/freezing using a parametrisation + !! + !! ** Comment : in isf_par and all its call tree, + !! 'tbl' means parametrisation layer (ie how the far field temperature/salinity is computed) + !! instead of in a proper top boundary layer as at the ice shelf ocean interface + !! as the action to compute the properties of the tbl or the parametrisation layer are the same, + !! (ie average T/S over a specific depth (can be across multiple levels)) + !! the name tbl was kept. + !! + !! ** Convention : all fluxes are from isf to oce + !! + !!--------------------------------------------------------------------- + !!-------------------------- OUT -------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: pqfwf + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(inout) :: ptsc + !!-------------------------- IN -------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!--------------------------------------------------------------------- + INTEGER :: ji, jj + REAL(wp), DIMENSION(jpi,jpj) :: zqoce, zqhc, zqlat, zqh + !!--------------------------------------------------------------------- + ! + ! compute heat content, latent heat and melt fluxes (2d) + CALL isfpar_mlt( kt, Kmm, zqhc, zqoce, pqfwf ) + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! compute heat and water flux (from isf to oce) + pqfwf(ji,jj) = pqfwf(ji,jj) * mskisf_par(ji,jj) + zqoce(ji,jj) = zqoce(ji,jj) * mskisf_par(ji,jj) + zqhc (ji,jj) = zqhc(ji,jj) * mskisf_par(ji,jj) + ! + ! compute latent heat flux (from isf to oce) + zqlat(ji,jj) = - pqfwf(ji,jj) * rLfusisf ! 2d latent heat flux (W/m2) + ! + ! total heat flux (from isf to oce) + zqh(ji,jj) = ( zqhc (ji,jj) + zqoce(ji,jj) ) + ! + ! set temperature content + ptsc(ji,jj,jp_tem) = zqh(ji,jj) * r1_rho0_rcp + END_2D + ! + ! output fluxes + CALL isf_diags_flx( Kmm, misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, 'par', pqfwf, zqoce, zqlat, zqhc) + ! + ! write restart variables (qoceisf, qhcisf, fwfisf for now and before) + IF (lrst_oce) CALL isfrst_write(kt, 'par', ptsc, pqfwf) + ! + IF ( ln_isfdebug ) THEN + IF(lwp) WRITE(numout,*) + CALL debug('isf_par: ptsc T',ptsc(:,:,1)) + CALL debug('isf_par: ptsc S',ptsc(:,:,2)) + CALL debug('isf_par: pqfwf fwf',pqfwf(:,:)) + IF(lwp) WRITE(numout,*) + END IF + ! + END SUBROUTINE isf_par + + SUBROUTINE isf_par_init + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_par_init *** + !! + !! ** Purpose : initialisation of the variable needed for the parametrisation of ice shelf melt + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr + REAL(wp), DIMENSION(jpi,jpj) :: ztblmax, ztblmin + !!---------------------------------------------------------------------- + ! + ! allocation + CALL isf_alloc_par() + ! + ! initialisation + misfkt_par(:,:) = 1 ; misfkb_par(:,:) = 1 + rhisf_tbl_par(:,:) = 1e-20 ; rfrac_tbl_par(:,:) = 0.0_wp + ! + ! define isf tbl tickness, top and bottom indice + CALL read_2dcstdta(TRIM(sn_isfpar_zmax%clname), TRIM(sn_isfpar_zmax%clvar), ztblmax) + CALL read_2dcstdta(TRIM(sn_isfpar_zmin%clname), TRIM(sn_isfpar_zmin%clvar), ztblmin) + ! + ! mask ice shelf parametrisation location + ztblmax(:,:) = ztblmax(:,:) * ssmask(:,:) + ztblmin(:,:) = ztblmin(:,:) * ssmask(:,:) + ! + ! if param used under an ice shelf overwrite ztblmin by the ice shelf draft + WHERE ( risfdep > 0._wp .AND. ztblmin > 0._wp ) + ztblmin(:,:) = risfdep(:,:) + END WHERE + ! + ! ensure ztblmax <= bathy + WHERE ( ztblmax(:,:) > bathy(:,:) ) + ztblmax(:,:) = bathy(:,:) + END WHERE + ! + ! compute ktop and update ztblmin to gdepw_0(misfkt_par) + CALL isf_tbl_ktop(ztblmin, misfkt_par) ! out: misfkt_par + ! ! inout: ztblmin + ! + ! initial tbl thickness + rhisf0_tbl_par(:,:) = ztblmax(:,:) - ztblmin(:,:) + ! + ! define iceshelf parametrisation mask + mskisf_par = 0 + WHERE ( rhisf0_tbl_par(:,:) > 0._wp ) + mskisf_par(:,:) = 1._wp + END WHERE + ! + ! read par variable from restart + IF ( ln_rstart ) CALL isfrst_read('par', risf_par_tsc, fwfisf_par, risf_par_tsc_b, fwfisf_par_b) + ! + SELECT CASE ( TRIM(cn_isfpar_mlt) ) + ! + CASE ( 'spe' ) + ! + ALLOCATE( sf_isfpar_fwf(1), STAT=ierr ) + ALLOCATE( sf_isfpar_fwf(1)%fnow(jpi,jpj,1), sf_isfpar_fwf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_isfpar_fwf, (/ sn_isfpar_fwf /), cn_isfdir, 'isf_par_init', 'read fresh water flux isf data', 'namisf' ) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> ice melt read from forcing field (cn_isfmlt_par = spe)' + ! + CASE ( 'bg03' ) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> bg03 parametrisation (cn_isfmlt_par = bg03)' + ! + ! read effective length + CALL read_2dcstdta(TRIM(sn_isfpar_Leff%clname), TRIM(sn_isfpar_Leff%clvar), risfLeff) + risfLeff = risfLeff*1000.0_wp !: convertion in m + ! + CASE ( 'oasis' ) + ! + ALLOCATE( sf_isfpar_fwf(1), STAT=ierr ) + ALLOCATE( sf_isfpar_fwf(1)%fnow(jpi,jpj,1), sf_isfpar_fwf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_isfpar_fwf, (/ sn_isfpar_fwf /), cn_isfdir, 'isf_par_init', 'read fresh water flux isf data', 'namisf' ) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> isf melt provided by OASIS (cn_isfmlt_par = oasis)' + ! + CASE DEFAULT + CALL ctl_stop( 'sbc_isf_init: wrong value of nn_isf' ) + END SELECT + ! + END SUBROUTINE isf_par_init + +END MODULE isfpar \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfparmlt.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfparmlt.F90 new file mode 100644 index 0000000..0e921f0 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfparmlt.F90 @@ -0,0 +1,237 @@ +MODULE isfparmlt + !!====================================================================== + !! *** MODULE isfparmlt *** + !! Ice shelf parametrisation module : update surface ocean boundary condition under ice + !! shelf using an ice shelf melt parametrisation + !!====================================================================== + !! History : 4.0 ! original code + !!---------------------------------------------------------------------- + + USE isf_oce ! ice shelf + USE isftbl , ONLY: isf_tbl ! ice shelf depth average + USE isfutils,ONLY: debug ! debug subroutine + + USE dom_oce ! ocean space and time domain + USE oce , ONLY: ts ! ocean dynamics and tracers + USE phycst , ONLY: rcp, rho0 ! physical constants + USE eosbn2 , ONLY: eos_fzp ! equation of state + + USE in_out_manager ! I/O manager + USE iom , ONLY: iom_put ! I/O library + USE fldread , ONLY: fld_read, FLD, FLD_N ! + USE lib_fortran, ONLY: glob_sum ! + USE lib_mpp , ONLY: ctl_stop ! + + IMPLICIT NONE + + PRIVATE + + PUBLIC isfpar_mlt + + + !! * Substitutions +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +! ------------------------------------------------------------------------------------------------------- +! -------------------------------- PUBLIC SUBROUTINE ---------------------------------------------------- +! ------------------------------------------------------------------------------------------------------- + + SUBROUTINE isfpar_mlt( kt, Kmm, pqhc, pqoce, pqfwf ) + !!--------------------------------------------------------------------- + !! *** ROUTINE isfpar_mlt *** + !! + !! ** Purpose : Compute Salt and Heat fluxes related to ice_shelf + !! melting and freezing + !! + !! ** Method : 2 parameterizations are available according + !! 1 : Specified melt flux + !! 2 : Beckmann & Goose parameterization + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pqfwf, pqoce, pqhc ! fresh water, ice-ocean heat and heat content fluxes + !!-------------------------- IN ------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!--------------------------------------------------------------------- + ! + ! Choose among the available ice shelf parametrisation + SELECT CASE ( cn_isfpar_mlt ) + CASE ( 'spe' ) ! specified runoff in depth (Mathiot et al., 2017 in preparation) + CALL isfpar_mlt_spe(kt, Kmm, pqhc, pqoce, pqfwf) + CASE ( 'bg03' ) ! Beckmann and Goosse parametrisation + CALL isfpar_mlt_bg03(kt, Kmm, pqhc, pqoce, pqfwf) + CASE ( 'oasis' ) + CALL isfpar_mlt_oasis( kt, Kmm, pqhc, pqoce, pqfwf) + CASE DEFAULT + CALL ctl_stop('STOP', 'unknown isf melt formulation : cn_isfpar (should not see this)') + END SELECT + ! + IF (ln_isfdebug) THEN + IF(lwp) WRITE(numout,*) '' + CALL debug( 'isfpar_mlt qhc :', pqhc (:,:) ) + CALL debug( 'isfpar_mlt qoce :', pqoce(:,:) ) + CALL debug( 'isfpar_mlt qfwf :', pqfwf(:,:) ) + IF(lwp) WRITE(numout,*) '' + END IF + ! + END SUBROUTINE isfpar_mlt + +! ------------------------------------------------------------------------------------------------------- +! -------------------------------- PRIVATE SUBROUTINE --------------------------------------------------- +! ------------------------------------------------------------------------------------------------------- + + SUBROUTINE isfpar_mlt_spe(kt, Kmm, pqhc, pqoce, pqfwf) + !!--------------------------------------------------------------------- + !! *** ROUTINE isfpar_mlt_spe *** + !! + !! ** Purpose : prescribed ice shelf melting in case ice shelf cavities are closed. + !! data read into a forcing files. + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pqhc, pqfwf, pqoce ! fresh water and ice-ocean heat fluxes + !!-------------------------- IN ------------------------------------- + INTEGER, INTENT(in) :: kt + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!-------------------------------------------------------------------- + INTEGER :: jk + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz + !!-------------------------------------------------------------------- + ! + ! 0. ------------Read specified fwf from isf to oce + CALL fld_read ( kt, 1, sf_isfpar_fwf ) + ! + ! compute ptfrz + ! 1. ------------Mean freezing point + DO jk = 1,jpk + CALL eos_fzp(CASTSP(ts(:,:,jk,jp_sal,Kmm)), ztfrz3d(:,:,jk), gdept(:,:,jk,Kmm)) + END DO + CALL isf_tbl(Kmm, CASTDP(ztfrz3d), ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) + ! + pqfwf(:,:) = sf_isfpar_fwf(1)%fnow(:,:,1) ! fresh water flux from the isf (fwfisf <0 mean melting) ( > 0 from isf to oce) + pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean/ice shelf flux assume to be equal to latent heat flux ( > 0 from isf to oce) + pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce) + ! + CALL iom_put('isftfrz_par', ztfrz(:,:) * mskisf_par(:,:) ) + ! + END SUBROUTINE isfpar_mlt_spe + + SUBROUTINE isfpar_mlt_bg03(kt, Kmm, pqhc, pqoce, pqfwf) + !!--------------------------------------------------------------------- + !! *** ROUTINE isfpar_mlt_bg03 *** + !! + !! ** Purpose : compute an estimate of ice shelf melting and + !! latent, ocean-ice and heat content heat fluxes + !! in case cavities are closed based on the far fields T and S properties. + !! + !! ** Method : The ice shelf melt is computed as proportional to the differences between the + !! mean temperature and mean freezing point in front of the ice shelf averaged + !! over the ice shelf min ice shelf draft and max ice shelf draft and the freezing point + !! + !! ** Reference : Beckmann and Goosse (2003), "A parameterization of ice shelf-ocean + !! interaction for climate models", Ocean Modelling 5(2003) 157-170. + !!---------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pqhc, pqfwf, pqoce ! fresh water and ice-ocean heat fluxes + !!-------------------------- IN ------------------------------------- + INTEGER, INTENT(in) :: kt + INTEGER, INTENT(in) :: Kmm ! ocean time level index + !!-------------------------------------------------------------------- + INTEGER :: jk + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d ! freezing point + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point + REAL(wp), DIMENSION(jpi,jpj) :: ztavg ! temperature avg + !!---------------------------------------------------------------------- + ! + ! 0. ------------Mean freezing point + DO jk = 1,jpk + CALL eos_fzp(CASTSP(ts(:,:,jk,jp_sal,Kmm)), ztfrz3d(:,:,jk), gdept(:,:,jk,Kmm)) + END DO + CALL isf_tbl(Kmm, CASTDP(ztfrz3d), ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) + ! + ! 1. ------------Mean temperature + CALL isf_tbl(Kmm, ts(:,:,:,jp_tem,Kmm), ztavg, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) + ! + ! 2. ------------Net heat flux and fresh water flux due to the ice shelf + pqfwf(:,:) = rho0 * rcp * rn_isfpar_bg03_gt0 * risfLeff(:,:) * e1t(:,:) * (ztavg(:,:) - ztfrz(:,:) ) * r1_e1e2t(:,:) / rLfusisf ! ( > 0 from isf to oce) + pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean/ice shelf flux assume to be equal to latent heat flux ( > 0 from isf to oce) + pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce) + ! + ! 3. ------------BG03 output + ! output ttbl + CALL iom_put('ttbl_par', ztavg(:,:) * mskisf_par(:,:) ) + ! + ! output thermal driving + CALL iom_put('isfthermald_par',( ztavg(:,:) - ztfrz(:,:) ) * mskisf_par(:,:)) + ! + ! output freezing point used to define the thermal driving and heat content fluxes + CALL iom_put('isftfrz_par', ztfrz(:,:) * mskisf_par(:,:) ) + ! + END SUBROUTINE isfpar_mlt_bg03 + + SUBROUTINE isfpar_mlt_oasis(kt, Kmm, pqhc , pqoce, pqfwf ) + !!---------------------------------------------------------------------- + !! *** ROUTINE isfpar_mlt_oasis *** + !! + !! ** Purpose : scale the fwf read from input file by the total amount received by the sbccpl interface + !! + !! ** Purpose : - read ice shelf melt from forcing file and scale it by the input file total amount => pattern + !! - compute total amount of fwf given by sbccpl (fwfisf_oasis) + !! - scale fwf and compute heat fluxes + !! + !!--------------------------------------------------------------------- + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pqhc, pqoce, pqfwf ! heat content, latent heat and fwf fluxes + !!-------------------------- IN ------------------------------------- + INTEGER , INTENT(in ) :: kt ! current time step + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + !!-------------------------------------------------------------------- + INTEGER :: jk ! loop index + REAL(wp) :: zfwf_fld, zfwf_oasis ! total fwf in the forcing fields (pattern) and from the cpl interface (amount) + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! tbl freezing temperature + REAL(wp), DIMENSION(jpi,jpj) :: zfwf ! 2d fwf map after scaling + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztfrz3d + !!-------------------------------------------------------------------- + ! + ! 0. ------------Read specified runoff + CALL fld_read ( kt, 1, sf_isfpar_fwf ) + ! + ! 1. ------------Mean freezing point (needed for heat content flux) + DO jk = 1,jpk + CALL eos_fzp(CASTSP(ts(:,:,jk,jp_sal,Kmm)), ztfrz3d(:,:,jk), gdept(:,:,jk,Kmm)) + END DO + CALL isf_tbl(Kmm, CASTDP(ztfrz3d), ztfrz, 'T', misfkt_par, rhisf_tbl_par, misfkb_par, rfrac_tbl_par ) + ! + ! 2. ------------Scale isf melt pattern with total amount from oasis + ! ice shelf 2d map of fwf from isf to oce + zfwf(:,:) = sf_isfpar_fwf(1)%fnow(:,:,1) + ! + ! compute glob sum from input file + ! (PM) should we consider delay sum as in fwb ? (it will offset by 1 time step if I understood well) + zfwf_fld = glob_sum('isfcav_mlt', e1e2t(:,:) * zfwf(:,:)) + ! + ! compute glob sum from atm->oce ice shelf fwf + ! (PM) should we consider delay sum as in fwb ? + zfwf_oasis = glob_sum('isfcav_mlt', e1e2t(:,:) * fwfisf_oasis(:,:)) + ! + ! scale fwf + zfwf(:,:) = zfwf(:,:) * zfwf_oasis / zfwf_fld + ! + ! 3. -----------Define fwf and qoce + ! ocean heat flux is assume to be equal to the latent heat + pqfwf(:,:) = zfwf(:,:) ! fwf ( > 0 from isf to oce) + pqoce(:,:) = - pqfwf(:,:) * rLfusisf ! ocean heat flux ( > 0 from isf to oce) (assumed to be the latent heat flux) + pqhc (:,:) = pqfwf(:,:) * ztfrz(:,:) * rcp ! heat content flux ( > 0 from isf to oce) + ! + CALL iom_put('isftfrz_par', ztfrz ) + ! + END SUBROUTINE isfpar_mlt_oasis + +END MODULE isfparmlt \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfrst.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfrst.F90 new file mode 100644 index 0000000..d90b3e0 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfrst.F90 @@ -0,0 +1,99 @@ +MODULE isfrst + !!====================================================================== + !! *** MODULE isfrst *** + !! iceshelf restart module :read/write iceshelf variables from/in restart + !!====================================================================== + !! History : 4.1 ! 2019-07 (P. Mathiot) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isfrst : read/write iceshelf variables in/from restart + !!---------------------------------------------------------------------- + ! + USE par_oce, ONLY: jpi,jpj,jpk,jpts ! time and space domain + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + ! + IMPLICIT NONE + + PRIVATE + + PUBLIC isfrst_read, isfrst_write ! iceshelf restart read and write + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcisf.F90 10536 2019-01-16 19:21:09Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE isfrst_read( cdisf, ptsc, pfwf, ptsc_b, pfwf_b ) + !!--------------------------------------------------------------------- + !! + !! isfrst_read : read iceshelf variables from restart + !! + !!-------------------------- OUT -------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pfwf_b + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT( out) :: ptsc_b + !!-------------------------- IN -------------------------------------- + CHARACTER(LEN=3) , INTENT(in ) :: cdisf + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc + !!---------------------------------------------------------------------- + CHARACTER(LEN=256) :: cfwf_b, chc_b, csc_b + !!---------------------------------------------------------------------- + ! + ! define variable name + cfwf_b = 'fwfisf_'//TRIM(cdisf)//'_b' + chc_b = 'isf_hc_'//TRIM(cdisf)//'_b' + csc_b = 'isf_sc_'//TRIM(cdisf)//'_b' + ! + ! read restart + IF( .NOT.l_1st_euler ) THEN + IF(lwp) WRITE(numout,*) ' nit000-1 isf tracer content forcing fields read in the restart file' + CALL iom_get( numror, jpdom_auto, cfwf_b, pfwf_b(:,:) ) ! before ice shelf melt + CALL iom_get( numror, jpdom_auto, chc_b , ptsc_b (:,:,jp_tem) ) ! before ice shelf heat flux + CALL iom_get( numror, jpdom_auto, csc_b , ptsc_b (:,:,jp_sal) ) ! before ice shelf heat flux + ELSE + pfwf_b(:,:) = pfwf(:,:) + ptsc_b(:,:,:) = ptsc(:,:,:) + ENDIF + ! + END SUBROUTINE isfrst_read + + + SUBROUTINE isfrst_write( kt, cdisf, ptsc, pfwf ) + !!--------------------------------------------------------------------- + !! + !! isfrst_write : write iceshelf variables in restart + !! + !!-------------------------- IN -------------------------------------- + INTEGER , INTENT(in ) :: kt + CHARACTER(LEN=3) , INTENT(in ) :: cdisf + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pfwf + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc + !!--------------------------------------------------------------------- + CHARACTER(LEN=256) :: cfwf_b, chc_b, csc_b + !!--------------------------------------------------------------------- + ! + ! ocean output print + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'isf : isf fwf and heat fluxes written in ocean restart file ', & + & 'at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~' + ! + ! define variable name + cfwf_b = 'fwfisf_'//TRIM(cdisf)//'_b' + chc_b = 'isf_hc_'//TRIM(cdisf)//'_b' + csc_b = 'isf_sc_'//TRIM(cdisf)//'_b' + ! + ! write restart variable + CALL iom_rstput( kt, nitrst, numrow, cfwf_b, pfwf(:,:) ) + CALL iom_rstput( kt, nitrst, numrow, chc_b , ptsc(:,:,jp_tem) ) + CALL iom_rstput( kt, nitrst, numrow, csc_b , ptsc(:,:,jp_sal) ) + ! + END SUBROUTINE isfrst_write + + !!====================================================================== +END MODULE isfrst \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfstp.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfstp.F90 new file mode 100644 index 0000000..956a587 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfstp.F90 @@ -0,0 +1,315 @@ +MODULE isfstp + !!====================================================================== + !! *** MODULE isfstp *** + !! Ice Shelves : compute iceshelf load, melt and heat flux + !!====================================================================== + !! History : 3.2 ! 2011-02 (C.Harris ) Original code isf cav + !! X.X ! 2006-02 (C. Wang ) Original code bg03 + !! 3.4 ! 2013-03 (P. Mathiot) Merging + parametrization + !! 4.1 ! 2019-09 (P. Mathiot) Split param/explicit ice shelf and re-organisation + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isfstp : compute iceshelf melt and heat flux + !!---------------------------------------------------------------------- + USE isf_oce ! isf variables + USE isfload, ONLY: isf_load ! ice shelf load + USE isftbl , ONLY: isf_tbl_lvl ! ice shelf boundary layer + USE isfpar , ONLY: isf_par, isf_par_init ! ice shelf parametrisation + USE isfcav , ONLY: isf_cav, isf_cav_init ! ice shelf cavity + USE isfcpl , ONLY: isfcpl_rst_write, isfcpl_init ! isf variables + + USE dom_oce ! ocean space and time domain + USE oce , ONLY: ssh ! sea surface height + USE domvvl, ONLY: ln_vvl_zstar ! zstar logical + USE zdfdrg, ONLY: r_Cdmin_top, r_ke0_top ! vertical physics: top/bottom drag coef. + ! + USE lib_mpp, ONLY: ctl_stop, ctl_nam + USE fldread, ONLY: FLD, FLD_N + USE in_out_manager ! I/O manager + USE timing + + IMPLICIT NONE + PRIVATE + + PUBLIC isf_stp, isf_init, isf_nam ! routine called in sbcmod and divhor + + !! * Substitutions +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: isfstp.F90 15529 2021-11-23 15:00:19Z techene $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE isf_stp( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_stp *** + !! + !! ** Purpose : compute total heat flux and total fwf due to ice shelf melt + !! + !! ** Method : For each case (parametrisation or explicity cavity) : + !! - define the before fields + !! - compute top boundary layer properties + !! (in case of parametrisation, this is the + !! depth range model array used to compute mean far fields properties) + !! - compute fluxes + !! - write restart variables + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + INTEGER :: jk ! loop index +#if defined key_qco + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t ! 3D workspace +#endif + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('isf') + ! + !======================================================================= + ! 1.: compute melt and associated heat fluxes in the ice shelf cavities + !======================================================================= + ! + IF ( ln_isfcav_mlt ) THEN + ! + ! 1.1: before time step + IF ( kt /= nit000 ) THEN + risf_cav_tsc_b (:,:,:) = risf_cav_tsc (:,:,:) + fwfisf_cav_b(:,:) = fwfisf_cav(:,:) + END IF + ! + ! 1.2: compute misfkb, rhisf_tbl, rfrac (deepest level, thickness, fraction of deepest cell affected by tbl) + rhisf_tbl_cav(:,:) = rn_htbl * mskisf_cav(:,:) +#if defined key_qco + DO jk = 1, jpk + ze3t(:,:,jk) = e3t(:,:,jk,Kmm) + END DO + CALL isf_tbl_lvl( CASTSP(ht(:,:)), ze3t , misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav ) +#else + CALL isf_tbl_lvl( ht(:,:), e3t(:,:,:,Kmm), misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav ) +#endif + ! + ! 1.3: compute ice shelf melt + CALL isf_cav( kt, Kmm, risf_cav_tsc, fwfisf_cav ) + ! + END IF + ! + !================================================================================= + ! 2.: compute melt and associated heat fluxes for not resolved ice shelf cavities + !================================================================================= + ! + IF ( ln_isfpar_mlt ) THEN + ! + ! 2.1: before time step + IF ( kt /= nit000 ) THEN + risf_par_tsc_b(:,:,:) = risf_par_tsc(:,:,:) + fwfisf_par_b (:,:) = fwfisf_par (:,:) + END IF + ! + ! 2.2: compute misfkb, rhisf_tbl, rfrac (deepest level, thickness, fraction of deepest cell affected by tbl) + ! by simplicity, we assume the top level where param applied do not change with time (done in init part) + rhisf_tbl_par(:,:) = rhisf0_tbl_par(:,:) +#if defined key_qco + DO jk = 1, jpk + ze3t(:,:,jk) = e3t(:,:,jk,Kmm) + END DO + CALL isf_tbl_lvl( CASTSP(ht(:,:)), ze3t , misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par ) +#else + CALL isf_tbl_lvl( ht(:,:), e3t(:,:,:,Kmm), misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par ) +#endif + ! + ! 2.3: compute ice shelf melt + CALL isf_par( kt, Kmm, risf_par_tsc, fwfisf_par ) + ! + END IF + ! + !================================================================================== + ! 3.: output specific restart variable in case of coupling with an ice sheet model + !================================================================================== + ! + IF ( ln_isfcpl .AND. lrst_oce ) CALL isfcpl_rst_write(kt, Kmm) + ! + IF( ln_timing ) CALL timing_stop('isf') + ! + END SUBROUTINE isf_stp + + + SUBROUTINE isf_init( Kbb, Kmm, Kaa ) + !!--------------------------------------------------------------------- + !! *** ROUTINE isfstp_init *** + !! + !! ** Purpose : Initialisation of the ice shelf public variables + !! + !! ** Method : Read the namisf namelist, check option compatibility and set derived parameters + !! + !! ** Action : - read namisf parameters + !! - allocate memory + !! - output print + !! - ckeck option compatibility + !! - call cav/param/isfcpl init routine + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices + !!---------------------------------------------------------------------- + ! + ! constrain: l_isfoasis need to be known + ! + CALL isf_nam() ! Read namelist + ! + CALL isf_alloc() ! Allocate public array + ! + CALL isf_ctl() ! check option compatibility + ! + IF( ln_isfcav ) CALL isf_load( Kmm, risfload ) ! compute ice shelf load + ! + ! terminate routine now if no ice shelf melt formulation specify + IF( ln_isf ) THEN + ! + IF( ln_isfcav_mlt ) CALL isf_cav_init() ! initialisation melt in the cavity + ! + IF( ln_isfpar_mlt ) CALL isf_par_init() ! initialisation parametrised melt + ! + IF( ln_isfcpl ) CALL isfcpl_init( Kbb, Kmm, Kaa ) ! initialisation ice sheet coupling + ! + END IF + + END SUBROUTINE isf_init + + + SUBROUTINE isf_ctl() + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_ctl *** + !! + !! ** Purpose : output print and option compatibility check + !! + !!---------------------------------------------------------------------- + IF (lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'isf_init : ice shelf initialisation' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namisf :' + ! + WRITE(numout,*) ' ice shelf cavity (open or parametrised) ln_isf = ', ln_isf + WRITE(numout,*) + ! + IF ( ln_isf ) THEN +#if key_qco +# if ! defined key_isf + CALL ctl_stop( 'STOP', 'isf_ctl: ice shelf requires both ln_isf=T AND key_isf activated' ) +# endif +#endif + WRITE(numout,*) ' Add debug print in isf module ln_isfdebug = ', ln_isfdebug + WRITE(numout,*) + WRITE(numout,*) ' melt inside the cavity ln_isfcav_mlt = ', ln_isfcav_mlt + IF ( ln_isfcav_mlt) THEN + WRITE(numout,*) ' melt formulation cn_isfcav_mlt= ', TRIM(cn_isfcav_mlt) + WRITE(numout,*) ' thickness of the top boundary layer rn_htbl = ', rn_htbl + WRITE(numout,*) ' gamma formulation cn_gammablk = ', TRIM(cn_gammablk) + IF ( TRIM(cn_gammablk) .NE. 'spe' ) THEN + WRITE(numout,*) ' gammat coefficient rn_gammat0 = ', rn_gammat0 + WRITE(numout,*) ' gammas coefficient rn_gammas0 = ', rn_gammas0 + WRITE(numout,*) ' top background ke used (from namdrg_top) rn_ke0 = ', r_ke0_top + WRITE(numout,*) ' top drag coef. used (from namdrg_top) rn_Cd0 = ', r_Cdmin_top + END IF + END IF + WRITE(numout,*) '' + ! + WRITE(numout,*) ' ice shelf melt parametrisation ln_isfpar_mlt = ', ln_isfpar_mlt + IF ( ln_isfpar_mlt ) THEN + WRITE(numout,*) ' isf parametrisation formulation cn_isfpar_mlt = ', TRIM(cn_isfpar_mlt) + END IF + WRITE(numout,*) '' + ! + WRITE(numout,*) ' Coupling to an ice sheet model ln_isfcpl = ', ln_isfcpl + IF ( ln_isfcpl ) THEN + WRITE(numout,*) ' conservation activated ln_isfcpl_cons = ', ln_isfcpl_cons + WRITE(numout,*) ' number of call of the extrapolation loop = ', nn_drown + ENDIF + WRITE(numout,*) '' + ! + ELSE + ! + IF ( ln_isfcav ) THEN + WRITE(numout,*) '' + WRITE(numout,*) ' W A R N I N G: ice shelf cavities are open BUT no melt will be computed or read from file !' + WRITE(numout,*) '' + END IF + ! + END IF + + IF (ln_isfcav) THEN + WRITE(numout,*) ' Ice shelf load method cn_isfload = ', TRIM(cn_isfload) + WRITE(numout,*) ' Temperature used to compute the ice shelf load = ', rn_isfload_T + WRITE(numout,*) ' Salinity used to compute the ice shelf load = ', rn_isfload_S + END IF + WRITE(numout,*) '' + FLUSH(numout) + + END IF + ! + + !--------------------------------------------------------------------------------------------------------------------- + ! sanity check ! issue ln_isfcav not yet known as well as l_isfoasis => move this call in isf_stp ? + ! melt in the cavity without cavity + IF ( ln_isfcav_mlt .AND. (.NOT. ln_isfcav) ) & + & CALL ctl_stop('ice shelf melt in the cavity activated (ln_isfcav_mlt) but no cavity detected in domcfg (ln_isfcav), STOP' ) + ! + ! ice sheet coupling without cavity + IF ( ln_isfcpl .AND. (.NOT. ln_isfcav) ) & + & CALL ctl_stop('coupling with an ice sheet model detected (ln_isfcpl) but no cavity detected in domcfg (ln_isfcav), STOP' ) + ! + IF ( ln_isfcpl .AND. ln_isfcpl_cons .AND. ln_linssh ) & + & CALL ctl_stop( 'The coupling between NEMO and an ice sheet model with the conservation option does not work with the linssh option' ) + ! + IF ( l_isfoasis .AND. .NOT. ln_isf ) CALL ctl_stop( ' OASIS send ice shelf fluxes to NEMO but NEMO does not have the isf module activated' ) + ! + IF ( l_isfoasis .AND. ln_isf ) THEN + ! + ! NEMO coupled to ATMO model with isf cavity need oasis method for melt computation + IF ( ln_isfcav_mlt .AND. TRIM(cn_isfcav_mlt) /= 'oasis' ) CALL ctl_stop( 'cn_isfcav_mlt = oasis is the only option availble if fwf send by oasis' ) + IF ( ln_isfpar_mlt .AND. TRIM(cn_isfpar_mlt) /= 'oasis' ) CALL ctl_stop( 'cn_isfpar_mlt = oasis is the only option availble if fwf send by oasis' ) + ! + ! oasis melt computation with cavity open and cavity parametrised (not coded) + IF ( ln_isfcav_mlt .AND. ln_isfpar_mlt ) THEN + IF ( TRIM(cn_isfpar_mlt) == 'oasis' .AND. TRIM(cn_isfcav_mlt) == 'oasis' ) CALL ctl_stop( 'cn_isfpar_mlt = oasis and cn_isfcav_mlt = oasis not coded' ) + END IF + ! + ! compatibility ice shelf and vvl + IF( .NOT. ln_vvl_zstar .AND. ln_isf ) CALL ctl_stop( 'Only vvl_zstar has been tested with ice shelf cavity' ) + ! + END IF + END SUBROUTINE isf_ctl + + + SUBROUTINE isf_nam + !!--------------------------------------------------------------------- + !! *** ROUTINE isf_nam *** + !! + !! ** Purpose : Read ice shelf namelist cfg and ref + !! + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + !!---------------------------------------------------------------------- + NAMELIST/namisf/ ln_isf , & + & cn_gammablk , rn_gammat0 , rn_gammas0 , rn_htbl, sn_isfcav_fwf, & + & ln_isfcav_mlt , cn_isfcav_mlt , sn_isfcav_fwf , & + & ln_isfpar_mlt , cn_isfpar_mlt , sn_isfpar_fwf , & + & sn_isfpar_zmin, sn_isfpar_zmax, sn_isfpar_Leff, & + & ln_isfcpl , nn_drown , ln_isfcpl_cons, ln_isfdebug, & + & cn_isfload , rn_isfload_T , rn_isfload_S , cn_isfdir , & + & rn_isfpar_bg03_gt0 + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namisf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namisf in reference namelist' ) + ! + READ ( numnam_cfg, namisf, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namisf in configuration namelist' ) + IF(lwm) WRITE ( numond, namisf ) + + END SUBROUTINE isf_nam + !! + !!====================================================================== +END MODULE isfstp \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isftbl.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isftbl.F90 new file mode 100644 index 0000000..394c57b --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isftbl.F90 @@ -0,0 +1,275 @@ +MODULE isftbl + !!====================================================================== + !! *** MODULE isftbl *** + !! isftbl module : compute properties of top boundary layer + !!====================================================================== + !! History : 4.1 ! 2019-09 (P. Mathiot) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isftbl : routine to compute : + !! - geometry of the ice shelf tbl (isf_tbl_lvl, isftbl_ktop, isftbl_kbot) + !! (top and bottom level, thickness and fraction of deepest level affected) + !! - tbl averaged properties (isf_tbl, isf_tbl_avg) + !!---------------------------------------------------------------------- + + USE isf_oce ! ice shelf variables + + USE dom_oce ! vertical scale factor and depth + + IMPLICIT NONE + + PRIVATE + + PUBLIC isf_tbl, isf_tbl_avg, isf_tbl_lvl, isf_tbl_ktop, isf_tbl_kbot + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + +CONTAINS + + SUBROUTINE isf_tbl( Kmm, pvarin, pvarout, cd_ptin, ktop, phtbl, kbot, pfrac ) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE isf_tbl *** + !! + !! ** Purpose : compute mean T/S/U/V in the boundary layer at T- point + !! + !! ** Method : Average properties over a specific thickness + !! + !! ** Reference : inspired from : Losch, Modeling ice shelf cavities in a z coordinate ocean general circulation model + !! https://doi.org/10.1029/2007JC004368 , 2008 + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pvarout ! 2d average of pvarin + !!-------------------------- IN ------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + CHARACTER(len=1) , INTENT(in ) :: cd_ptin ! point of variable in/out + REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pvarin ! 3d variable to average over the tbl + INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop ! top level + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl ! tbl thickness + !!-------------------------- IN OPTIONAL ----------------------------- + INTEGER, DIMENSION(jpi,jpj), OPTIONAL, INTENT(in ) :: kbot ! bottom level + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in ) :: pfrac ! fraction of bottom cell affected by tbl + !!-------------------------------------------------------------------- + INTEGER :: ji, jj ! loop index + INTEGER , DIMENSION(jpi,jpj) :: ikbot ! bottom level of the tbl + REAL(wp), DIMENSION(jpi,jpj) :: zvarout ! 2d average of pvarin + REAL(wp), DIMENSION(jpi,jpj) :: zhtbl ! thickness of the tbl + REAL(wp), DIMENSION(jpi,jpj) :: zfrac ! thickness of the tbl + INTEGER :: jk ! loop index + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t,ze3u,ze3v ! e3 + !!-------------------------------------------------------------------- + ! + SELECT CASE ( cd_ptin ) + CASE ( 'U' ) + ! + ! copy phtbl (phtbl is INTENT in as we don't want to change it) + zhtbl = phtbl + ! + DO jk = 1, jpk + ze3u(:,:,jk) = e3u(:,:,jk,Kmm) + END DO + ! compute tbl lvl and thickness + CALL isf_tbl_lvl( hu(:,:,Kmm), ze3u, ktop, ikbot, zhtbl, zfrac ) + ! + ! compute tbl property at U point + CALL isf_tbl_avg( miku, ikbot, zhtbl, zfrac, ze3u, pvarin, zvarout ) + ! + ! compute tbl property at T point + pvarout(1,:) = 0._wp + DO_2D( nn_hls-1, nn_hls, nn_hls, nn_hls ) + pvarout(ji,jj) = 0.5_wp * (zvarout(ji,jj) + zvarout(ji-1,jj)) + END_2D + ! lbclnk not needed as a final communication is done after the computation of fwf + ! + CASE ( 'V' ) + ! + ! copy phtbl (phtbl is INTENT in as we don't want to change it) + zhtbl = phtbl + ! + DO jk = 1, jpk + ze3v(:,:,jk) = e3v(:,:,jk,Kmm) + END DO + ! compute tbl lvl and thickness + CALL isf_tbl_lvl( hv(:,:,Kmm), ze3v, ktop, ikbot, zhtbl, zfrac ) + ! + ! compute tbl property at V point + CALL isf_tbl_avg( mikv, ikbot, zhtbl, zfrac, ze3v, pvarin, zvarout ) + ! + ! pvarout is an averaging of wet point + pvarout(:,1) = 0._wp + DO_2D( nn_hls, nn_hls, nn_hls-1, nn_hls ) + pvarout(ji,jj) = 0.5_wp * (zvarout(ji,jj) + zvarout(ji,jj-1)) + END_2D + ! lbclnk not needed as a final communication is done after the computation of fwf + ! + CASE ( 'T' ) + ! + ! compute tbl property at T point + DO jk = 1, jpk + ze3t(:,:,jk) = e3t(:,:,jk,Kmm) + END DO + CALL isf_tbl_avg( ktop, kbot, phtbl, pfrac, ze3t, pvarin, pvarout ) + ! + END SELECT + ! + END SUBROUTINE isf_tbl + + SUBROUTINE isf_tbl_avg( ktop, kbot, phtbl, pfrac, pe3, pvarin, pvarout ) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_tbl_avg *** + !! + !! ** Purpose : compute mean property in the boundary layer + !! + !! ** Method : Depth average is made between the top level ktop and the bottom level kbot + !! over a thickness phtbl. The bottom level is partially counted (pfrac). + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pvarout ! tbl property averaged over phtbl between level ktop and kbot + !!-------------------------- IN ------------------------------------- + INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop, kbot ! top and bottom level of the top boundary layer + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl, pfrac ! fraction of bottom level to be affected by the tbl + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pvarin ! tbl property to average between ktop, kbot over phtbl + !!-------------------------------------------------------------------- + INTEGER :: ji,jj,jk ! loop indices + INTEGER :: ikt, ikb ! top and bottom levels + !!-------------------------------------------------------------------- + ! + ! compute tbl top.bottom level and thickness + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + ! tbl top/bottom indices initialisation + ikt = ktop(ji,jj) ; ikb = kbot(ji,jj) + ! + ! level fully include in the ice shelf boundary layer + pvarout(ji,jj) = SUM( pvarin(ji,jj,ikt:ikb-1) * pe3(ji,jj,ikt:ikb-1) ) / phtbl(ji,jj) + ! + ! level partially include in ice shelf boundary layer + pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,ikb) * pe3(ji,jj,ikb) / phtbl(ji,jj) * pfrac(ji,jj) + ! + END_2D + + END SUBROUTINE isf_tbl_avg + + SUBROUTINE isf_tbl_lvl( phw, pe3, ktop, kbot, phtbl, pfrac ) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_tbl_lvl *** + !! + !! ** Purpose : - compute bottom level off the top boundary layer + !! - thickness of the top boundary layer + !! - fraction of the bottom level affected by the tbl + !! + !!-------------------------- OUT -------------------------------------- + INTEGER, DIMENSION(jpi,jpj) , INTENT( out) :: kbot ! bottom level of the top boundary layer + REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pfrac ! fraction of bottom level in the tbl + !!-------------------------- IN -------------------------------------- + INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop ! top level of the top boundary layer + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phw ! water column thickness + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor + !!-------------------------- INOUT ------------------------------------ + REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: phtbl ! top boundary layer thickness + !!--------------------------------------------------------------------- + INTEGER :: ji,jj,jk + INTEGER :: ikt, ikb + !!--------------------------------------------------------------------- + ! + ! get htbl + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + ! tbl top/bottom indices initialisation + ikt = ktop(ji,jj) + ! + ! limit the tbl to water thickness. + phtbl(ji,jj) = MIN( phtbl(ji,jj), phw(ji,jj) ) + ! + ! thickness of boundary layer must be at least the top level thickness + phtbl(ji,jj) = MAX( phtbl(ji,jj), pe3(ji,jj,ikt) ) + ! + END_2D + ! + ! get ktbl + CALL isf_tbl_kbot(ktop, phtbl, pe3, kbot) + ! + ! get pfrac + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + ! tbl top/bottom indices initialisation + ikt = ktop(ji,jj) ; ikb = kbot(ji,jj) + ! + ! proportion of the bottom cell included in ice shelf boundary layer + pfrac(ji,jj) = ( phtbl(ji,jj) - SUM( pe3(ji,jj,ikt:ikb-1) ) ) / pe3(ji,jj,ikb) + ! + END_2D + ! + END SUBROUTINE isf_tbl_lvl + ! + SUBROUTINE isf_tbl_kbot(ktop, phtbl, pe3, kbot) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_tbl_bot *** + !! + !! ** Purpose : compute bottom level of the isf top boundary layer + !! + !!-------------------------- OUT ------------------------------------- + INTEGER, DIMENSION(jpi,jpj) , INTENT( out) :: kbot ! bottom level of the top boundary layer + !!-------------------------- IN ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl ! top boundary layer thickness + INTEGER, DIMENSION(jpi,jpj) , INTENT(in ) :: ktop ! top level of the top boundary layer + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3 ! vertical scale factor + !!-------------------------------------------------------------------- + INTEGER :: ji, jj + INTEGER :: ikt, ikb + !!-------------------------------------------------------------------- + ! + ! phtbl need to be bounded by water column thickness before + ! test: if htbl = water column thickness, should return mbathy + ! test: if htbl = 0 should return ktop (phtbl cap to pe3t(ji,jj,1)) + ! + ! get ktbl + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + ! determine the deepest level influenced by the boundary layer + ikt = ktop(ji,jj) + ikb = ikt + DO WHILE ( SUM(pe3(ji,jj,ikt:ikb-1)) < phtbl(ji,jj ) ) ; ikb = ikb + 1 ; END DO + kbot(ji,jj) = ikb - 1 + ! + END_2D + ! + END SUBROUTINE isf_tbl_kbot + ! + SUBROUTINE isf_tbl_ktop(pdep, ktop) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_tbl_top *** + !! + !! ** Purpose : compute top level of the isf top boundary layer in case of an ice shelf parametrisation + !! + !!-------------------------- OUT ------------------------------------- + INTEGER, DIMENSION(jpi,jpj), INTENT( out) :: ktop ! top level affected by the ice shelf parametrisation + !!-------------------------- IN ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pdep ! top depth of the parametrisation influence + !!-------------------------------------------------------------------- + INTEGER :: ji,jj + INTEGER :: ikt + !!-------------------------------------------------------------------- + ! + ! if we need to recompute the top level at every time stepcompute top level (z*, z~) + ! in case of weak ht variation we can assume the top level of htbl to be constant + ! => only done using gdepw_0 + ! be sure pdep is already correctly bounded + ! test: this routine run on isfdraft should return mikt + ! test: this routine run with pdep = 0 should return 1 + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! comput ktop + ikt = 2 + DO WHILE ( gdepw_0(ji,jj,ikt) <= pdep(ji,jj ) ) ; ikt = ikt + 1 ; END DO + ktop(ji,jj) = ikt - 1 + ! + ! update pdep + pdep(ji,jj) = gdepw_0(ji,jj,ktop(ji,jj)) + END_2D + ! + END SUBROUTINE isf_tbl_ktop + +END MODULE isftbl \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfutils.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfutils.F90 new file mode 100644 index 0000000..5d2dfcc --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ISF/isfutils.F90 @@ -0,0 +1,163 @@ +MODULE isfutils + !!====================================================================== + !! *** MODULE isfutils *** + !! istutils module : miscelenious useful routines + !!====================================================================== + !! History : 4.1 ! 2019-09 (P. Mathiot) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! isfutils : - read_2dcstdta to read a constant input file with iom_get + !! - debug to print array sum, min, max in ocean.output + !!---------------------------------------------------------------------- + USE par_kind + USE iom , ONLY: iom_open, iom_get, iom_close, jpdom_global ! read input file + USE lib_fortran , ONLY: glob_sum, glob_min, glob_max ! compute global value + USE par_oce , ONLY: jpi,jpj,jpk, jpnij, Nis0, Nie0, Njs0, Nje0 ! domain size + USE dom_oce , ONLY: narea ! local domain + USE in_out_manager, ONLY: lwp, numout ! miscelenious + USE lib_mpp + + IMPLICIT NONE + + PRIVATE + + INTERFACE debug + MODULE PROCEDURE debug2d, debug3d + END INTERFACE debug + + PUBLIC read_2dcstdta, debug + +# include "single_precision_substitute.h90" +CONTAINS + + SUBROUTINE read_2dcstdta(cdfile, cdvar, pvar) + !!-------------------------------------------------------------------- + !! *** ROUTINE read_2dcstdta *** + !! + !! ** Purpose : read input file + !! + !!-------------------------- OUT ------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pvar ! output variable + !!-------------------------- IN ------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdfile ! input file name + CHARACTER(len=*) , INTENT(in ) :: cdvar ! variable name + !!-------------------------------------------------------------------- + INTEGER :: inum + !!-------------------------------------------------------------------- + + CALL iom_open( TRIM(cdfile), inum ) + CALL iom_get( inum, jpdom_global, TRIM(cdvar), pvar) + CALL iom_close(inum) + + END SUBROUTINE read_2dcstdta + + SUBROUTINE debug2d(cdtxt,pvar) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_debug2d *** + !! + !! ** Purpose : add debug print for 2d variables + !! + !!-------------------------- IN ------------------------------------- + CHARACTER(LEN=*) , INTENT(in ) :: cdtxt + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pvar + !!-------------------------------------------------------------------- + REAL(wp) :: zmin, zmax, zsum + INTEGER(i8) :: imodd, ip + INTEGER :: imods + INTEGER :: isums, idums + INTEGER :: ji,jj,jk + INTEGER, DIMENSION(jpnij) :: itmps + !!-------------------------------------------------------------------- + ! + ! global min/max/sum to check data range and NaN + zsum =glob_sum( 'debug', CASTDP(pvar(:,:)) ) + zmin = glob_min( 'debug',REAL(pvar(:,:),dp) ) + zmax = glob_max( 'debug', REAL(pvar(:,:),dp) ) + ! + ! basic check sum to check reproducibility + ! TRANSFER function find out the integer corresponding to pvar(i,j) bit pattern + ! MOD allow us to keep only the latest digits during the sum + ! imod is not choosen to be very large as at the end there is a classic mpp_sum + imodd=65521 ! highest prime number < 2**16 with i8 type + imods=65521 ! highest prime number < 2**16 with default integer for mpp_sum subroutine + isums=0 ; itmps(:)=0 ; + ! + ! local MOD sum + DO jj=Njs0,Nje0 + DO ji=Nis0,Nie0 + idums = ABS(MOD(TRANSFER(pvar(ji,jj), ip),imodd)) + itmps(narea) = MOD(itmps(narea) + idums, imods) + END DO + END DO + ! + ! global MOD sum + CALL mpp_max('debug',itmps(:)) + DO jk = 1,jpnij + isums = MOD(isums + itmps(jk),imods) + END DO + ! + ! print out + IF (lwp) THEN + WRITE(numout,*) TRIM(cdtxt),' (min, max, sum, tag) : ',zmin, zmax, zsum, isums + CALL FLUSH(numout) + END IF + ! + END SUBROUTINE debug2d + + SUBROUTINE debug3d(cdtxt,pvar) + !!-------------------------------------------------------------------- + !! *** ROUTINE isf_debug3d *** + !! + !! ** Purpose : add debug print for 3d variables + !! + !!-------------------------- IN ------------------------------------- + CHARACTER(LEN=*) , INTENT(in ) :: cdtxt + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pvar + !!-------------------------------------------------------------------- + REAL(wp) :: zmin, zmax, zsum + INTEGER(i8) :: imodd, ip + INTEGER :: imods + INTEGER :: isums, idums + INTEGER :: ji,jj,jk + INTEGER, DIMENSION(jpnij) :: itmps + !!-------------------------------------------------------------------- + ! + ! global min/max/sum to check data range and NaN + zsum = glob_sum( 'debug', pvar(:,:,:) ) + zmin = glob_min( 'debug', pvar(:,:,:) ) + zmax = glob_max( 'debug', pvar(:,:,:) ) + ! + ! basic check sum to check reproducibility + ! TRANSFER function find out the integer corresponding to pvar(i,j) bit pattern + ! MOD allow us to keep only the latest digits during the sum + ! imod is not choosen to be very large as at the end there is a classic mpp_sum + imodd=65521 ! highest prime number < 2**16 with i8 type + imods=65521 ! highest prime number < 2**16 with default integer for mpp_sum subroutine + itmps=0; isums=0 + ! + ! local MOD sum + DO jk=1,jpk + DO jj=Njs0,Nje0 + DO ji=Nis0,Nie0 + idums = ABS(MOD(TRANSFER(pvar(ji,jj,jk), ip),imodd)) + itmps(narea) = MOD(itmps(narea) + idums, imods) + END DO + END DO + END DO + ! + ! global MOD sum + CALL mpp_max('debug',itmps) + DO jk = 1,jpnij + isums = MOD(isums+itmps(jk),imods) + END DO + ! + ! print out + IF (lwp) THEN + WRITE(numout,*) TRIM(cdtxt),' (min, max, sum, tag) : ',zmin, zmax, zsum, isums + CALL FLUSH(numout) + END IF + ! + END SUBROUTINE debug3d + +END MODULE isfutils diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/halo_mng.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/halo_mng.F90 new file mode 100644 index 0000000..f03b666 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/halo_mng.F90 @@ -0,0 +1,194 @@ +MODULE halo_mng + !!====================================================================== + !! *** MODULE halo_mng *** + !! Ocean numerics: massively parallel processing library + !!===================================================================== + !! History : OPA ! 1994 (M. Guyon, J. Escobar, M. Imbard) + !Original code + !! 4.0 ! 2019 (CMCC - ASC) initial version of halo management module + !in_out_manager + !!---------------------------------------------------------------------- + + USE dom_oce ! ocean space and time domain + USE lbclnk ! ocean lateral boundary condition (or mpp link) + + IMPLICIT NONE + PRIVATE + + INTERFACE halo_mng_resize + MODULE PROCEDURE halo_mng_resize_2D, halo_mng_resize_3D, halo_mng_resize_4D, halo_mng_resize_5D + END INTERFACE + + PUBLIC halo_mng_resize + PUBLIC halo_mng_init + PUBLIC halo_mng_set + + INTEGER :: jpi_1, jpj_1 + INTEGER :: jpimax_1, jpjmax_1 + INTEGER :: Nis0_1, Njs0_1 + INTEGER :: Nie0_1, Nje0_1 +CONTAINS + + SUBROUTINE halo_mng_init( ) + + jpi_1 = jpi + jpj_1 = jpj + + Nis0_1 = Nis0 + Njs0_1 = Njs0 + + Nie0_1 = Nie0 + Nje0_1 = Nje0 + + jpimax_1 = jpimax + jpjmax_1 = jpjmax + + END SUBROUTINE halo_mng_init + + SUBROUTINE halo_mng_set( khls ) + + INTEGER, INTENT(in ) :: khls + + nn_hls = khls + + jpi = jpi_1 + 2*khls -2 + jpj = jpj_1 + 2*khls -2 + + jpi = jpi_1 + 2*khls -2 + jpj = jpj_1 + 2*khls -2 + + jpimax = jpimax_1 + 2*khls -2 + jpjmax = jpjmax_1 + 2*khls -2 + + Nis0 = Nis0_1 + khls - 1 + Njs0 = Njs0_1 + khls - 1 + + Nie0 = Nie0_1 + khls - 1 + Nje0 = Nje0_1 + khls - 1 + + END SUBROUTINE halo_mng_set + + SUBROUTINE halo_mng_resize_2D(pta, cdna, psgn, fillval) + + REAL(wp), POINTER, DIMENSION(:,:) :: pta + CHARACTER(len=1), INTENT(in) :: cdna + REAL(wp), INTENT(in) :: psgn + REAL(wp), OPTIONAL, INTENT(in ) :: fillval + REAL(wp), POINTER, DIMENSION(:,:) :: zpta + INTEGER :: offset + INTEGER :: pta_size_i, pta_size_j + + pta_size_i = SIZE(pta,1) + pta_size_j = SIZE(pta,2) + + ! check if the current size of pta is equal to the current expected dimension + IF (pta_size_i .ne. jpi) THEN + ALLOCATE (zpta(jpi, jpj)) + offset = abs((jpi - pta_size_i) / 2) + + IF (pta_size_i .lt. jpi) THEN + zpta (offset+1 : offset+pta_size_i, offset+1 : offset+pta_size_j) = pta + ELSE + zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj) + END IF + CALL lbc_lnk( 'halo_mng_resize_2D', zpta, cdna, psgn, pfillval=fillval) + DEALLOCATE(pta) + pta => zpta + END IF + + END SUBROUTINE halo_mng_resize_2D + + SUBROUTINE halo_mng_resize_3D(pta, cdna, psgn, fillval) + + REAL(wp), POINTER, DIMENSION(:,:,:) :: pta + CHARACTER(len=1), INTENT(in) :: cdna + REAL(wp), INTENT(in) :: psgn + REAL(wp), OPTIONAL, INTENT(in ) :: fillval + REAL(wp), POINTER, DIMENSION(:,:,:) :: zpta + INTEGER :: offset + INTEGER :: pta_size_i, pta_size_j + + pta_size_i = SIZE(pta,1) + pta_size_j = SIZE(pta,2) + + ! check if the current size of pta is equal to the current expected dimension + IF (pta_size_i .ne. jpi) THEN + ALLOCATE (zpta(jpi, jpj, jpk)) + offset = abs((jpi - pta_size_i) / 2) + + IF (pta_size_i .lt. jpi) THEN + zpta (offset+1 : offset+pta_size_i, offset+1 : offset+pta_size_j, :) = pta + ELSE + zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj, :) + END IF + CALL lbc_lnk( 'halo_mng_resize_3D', zpta, cdna, psgn, pfillval=fillval) + DEALLOCATE(pta) + pta => zpta + END IF + + END SUBROUTINE halo_mng_resize_3D + + SUBROUTINE halo_mng_resize_4D(pta, cdna, psgn, fillval, fjpt) + + REAL(wp), POINTER, DIMENSION(:,:,:,:) :: pta + CHARACTER(len=1), INTENT(in) :: cdna + REAL(wp), INTENT(in) :: psgn + REAL(wp), OPTIONAL, INTENT(in) :: fillval + INTEGER , INTENT(in) :: fjpt + REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zpta + INTEGER :: offset + INTEGER :: pta_size_i, pta_size_j + + pta_size_i = SIZE(pta,1) + pta_size_j = SIZE(pta,2) + + ! check if the current size of pta is equal to the current expected dimension + IF (pta_size_i .ne. jpi) THEN + ALLOCATE (zpta(jpi, jpj, jpk, jpt)) + offset = abs((jpi - pta_size_i) / 2) + + IF (pta_size_i .lt. jpi) THEN + zpta (offset+1 : offset+pta_size_i, offset+1 : offset+pta_size_j, :, :) = pta + ELSE + zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj, :, :) + END IF + CALL lbc_lnk( 'halo_mng_resize_4D', zpta(:,:,:,fjpt), cdna, psgn, pfillval=fillval) + DEALLOCATE(pta) + pta => zpta + END IF + + END SUBROUTINE halo_mng_resize_4D + + SUBROUTINE halo_mng_resize_5D(pta, cdna, psgn, fillval, kjpt, fjpt) + + REAL(wp), POINTER, DIMENSION(:,:,:,:,:) :: pta + CHARACTER(len=1), INTENT(in) :: cdna + REAL(wp), INTENT(in) :: psgn + REAL(wp), OPTIONAL, INTENT(in) :: fillval + INTEGER , OPTIONAL, INTENT(in) :: kjpt ! number of tracers + INTEGER , INTENT(in) :: fjpt + REAL(wp), POINTER, DIMENSION(:,:,:,:,:) :: zpta + INTEGER :: offset + INTEGER :: pta_size_i, pta_size_j + + pta_size_i = SIZE(pta,1) + pta_size_j = SIZE(pta,2) + + ! check if the current size of pta is equal to the current expected dimension + IF (pta_size_i .ne. jpi) THEN + ALLOCATE (zpta(jpi, jpj, jpk, kjpt, jpt)) + offset = abs((jpi - pta_size_i) / 2) + + IF (pta_size_i .lt. jpi) THEN + zpta (offset+1 : offset+pta_size_i, offset+1 : offset+pta_size_j, :, :, :) = pta + ELSE + zpta = pta(offset+1 : offset+jpi, offset+1 : offset+jpj, :, :, :) + END IF + CALL lbc_lnk( 'halo_mng_resize_5D', zpta(:,:,:,:,fjpt), cdna, psgn, pfillval=fillval) + DEALLOCATE(pta) + pta => zpta + END IF + + END SUBROUTINE halo_mng_resize_5D + +END MODULE \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_lnk_call_generic.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_lnk_call_generic.h90 new file mode 100644 index 0000000..1a7b148 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_lnk_call_generic.h90 @@ -0,0 +1,129 @@ +#if defined DIM_2d +# define XD 2d +# define DIMS :,: +# define ISZ3 1 +# define ISZ4 1 +#endif +#if defined DIM_3d +# define XD 3d +# define DIMS :,:,: +# define ISZ3 SIZE(ptab, dim=3) +# define ISZ4 1 +#endif +#if defined DIM_4d +# define XD 4d +# define DIMS :,:,:,: +# define ISZ3 SIZE(ptab, dim=3) +# define ISZ4 SIZE(ptab, dim=4) +#endif + + SUBROUTINE lbc_lnk_call_/**/XD/**/_/**/PRECISION( & + & cdname & + & , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4 & + & , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8 & + & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & + & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & + & , pt17, cdna17, psgn17, pt18, cdna18, psgn18, pt19, cdna19, psgn19, pt20, cdna20, psgn20 & + & , pt21, cdna21, psgn21, pt22, cdna22, psgn22, pt23, cdna23, psgn23, pt24, cdna24, psgn24 & + & , pt25, cdna25, psgn25, pt26, cdna26, psgn26, pt27, cdna27, psgn27, pt28, cdna28, psgn28 & + & , pt29, cdna29, psgn29, pt30, cdna30, psgn30 & + & , kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + !!--------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + REAL(PRECISION), DIMENSION(DIMS) , TARGET, CONTIGUOUS, INTENT(inout) :: pt1 ! arrays on which the lbc is applied + REAL(PRECISION), DIMENSION(DIMS), OPTIONAL, TARGET, CONTIGUOUS, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , & + & pt9 , pt10, pt11, pt12, pt13, pt14, pt15, & + & pt16, pt17, pt18, pt19, pt20, pt21, pt22, & + & pt23, pt24, pt25, pt26, pt27, pt28, pt29, & + & pt30 + CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points + CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , & + & cdna9 , cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, & + & cdna16, cdna17, cdna18, cdna19, cdna20, cdna21, cdna22, & + & cdna23, cdna24, cdna25, cdna26, cdna27, cdna28, cdna29, & + & cdna30 + REAL(PRECISION) , INTENT(in ) :: psgn1 ! sign used across the north fold + REAL(PRECISION) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , & + & psgn9 , psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, & + & psgn16, psgn17, psgn18, psgn19, psgn20, psgn21, psgn22, & + & psgn23, psgn24, psgn25, psgn26, psgn27, psgn28, psgn29, & + & psgn30 + INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(PRECISION) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL , INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out + LOGICAL , OPTIONAL , INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + !! + INTEGER :: kfld ! number of elements that will be attributed + TYPE(PTR_4d_/**/PRECISION), DIMENSION(30) :: ptab_ptr ! pointer array + CHARACTER(len=1) , DIMENSION(30) :: cdna_ptr ! nature of ptab_ptr grid-points + REAL(PRECISION) , DIMENSION(30) :: psgn_ptr ! sign used across the north fold boundary + !!--------------------------------------------------------------------- + ! + kfld = 0 ! initial array of pointer size + ! + ! ! Load the first array + CALL load_ptr_/**/XD/**/_/**/PRECISION( pt1, cdna1, psgn1, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + ! ! Look if more arrays are added + IF( PRESENT(psgn2 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn3 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn4 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn5 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn6 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn7 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn8 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn9 ) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn10) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn11) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn12) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn13) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn14) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn15) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn16) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn17) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt17, cdna17, psgn17, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn18) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt18, cdna18, psgn18, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn19) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt19, cdna19, psgn19, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn20) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt20, cdna20, psgn20, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn21) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt21, cdna21, psgn21, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn22) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt22, cdna22, psgn22, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn23) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt23, cdna23, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn24) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt24, cdna24, psgn24, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn25) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt25, cdna25, psgn25, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn26) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt26, cdna26, psgn26, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn27) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt27, cdna27, psgn27, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn28) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt28, cdna28, psgn28, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn29) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt29, cdna29, psgn29, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn30) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt30, cdna30, psgn30, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + IF( nn_comm == 1 ) THEN + CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ELSE + CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + ENDIF + ! + END SUBROUTINE lbc_lnk_call_/**/XD/**/_/**/PRECISION + + + SUBROUTINE load_ptr_/**/XD/**/_/**/PRECISION( ptab, cdna, psgn, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + !!--------------------------------------------------------------------- + REAL(PRECISION), DIMENSION(DIMS), TARGET, INTENT(inout), CONTIGUOUS :: ptab ! arrays on which the lbc is applied + CHARACTER(len=1) , INTENT(in ) :: cdna ! nature of pt2d array grid-points + REAL(PRECISION) , INTENT(in ) :: psgn ! sign used across the north fold boundary + TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers + CHARACTER(len=1), DIMENSION(:), INTENT(inout) :: cdna_ptr ! nature of pt2d_array array grid-points + REAL(PRECISION) , DIMENSION(:), INTENT(inout) :: psgn_ptr ! sign used across the north fold boundary + INTEGER , INTENT(inout) :: kfld ! number of elements that has been attributed + !!--------------------------------------------------------------------- + ! + kfld = kfld + 1 + ptab_ptr(kfld)%pt4d(1:SIZE(ptab, dim=1),1:SIZE(ptab, dim=2),1:ISZ3,1:ISZ4) => ptab + cdna_ptr(kfld) = cdna + psgn_ptr(kfld) = psgn + ! + END SUBROUTINE load_ptr_/**/XD/**/_/**/PRECISION + +#undef XD +#undef DIMS +#undef ISZ3 +#undef ISZ4 \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_lnk_neicoll_generic.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_lnk_neicoll_generic.h90 new file mode 100644 index 0000000..dec9b38 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_lnk_neicoll_generic.h90 @@ -0,0 +1,271 @@ +SUBROUTINE lbc_lnk_neicoll_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc + LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + ! + INTEGER :: ji, jj, jk , jl, jf, jn ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ip0i, ip1i, im0i, im1i + INTEGER :: ip0j, ip1j, im0j, im1j + INTEGER :: ishti, ishtj, ishti2, ishtj2 + INTEGER :: iszS, iszR + INTEGER :: ierr + INTEGER :: ihls, idx + INTEGER :: impi_nc + INTEGER :: ifill_nfd + INTEGER, DIMENSION(4) :: iwewe, issnn + INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi + INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj + INTEGER, DIMENSION(8) :: ifill, iszall + INTEGER, DIMENSION(8) :: jnf + INTEGER, DIMENSION(:), ALLOCATABLE :: iScnt, iRcnt ! number of elements to be sent/received + INTEGER, DIMENSION(:), ALLOCATABLE :: iSdpl, iRdpl ! displacement in halos arrays + LOGICAL, DIMENSION(8) :: llsend, llrecv + REAL(PRECISION) :: zland + LOGICAL :: ll4only ! default: 8 neighbourgs + !!---------------------------------------------------------------------- + ! + ! ----------------------------------------- ! + ! 1. local variables initialization ! + ! ----------------------------------------- ! + ! + ipi = SIZE(ptab(1)%pt4d,1) + ipj = SIZE(ptab(1)%pt4d,2) + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) + ! + ! take care of optional parameters + ! + ihls = nn_hls ! default definition + IF( PRESENT( khls ) ) ihls = khls + IF( ihls > n_hlsmax ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( ipi /= Ni_0+2*ihls ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0 + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( ipj /= Nj_0+2*ihls ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0 + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + ! + ll4only = .FALSE. ! default definition + IF( PRESENT(ld4only) ) ll4only = ld4only + ! + impi_nc = mpi_nc_com8(ihls) ! default + IF( ll4only ) impi_nc = mpi_nc_com4(ihls) + ! + zland = 0._wp ! land filling value: zero by default + IF( PRESENT( pfillval ) ) zland = pfillval ! set land value + ! + ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not. + IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs + CALL ctl_stop( 'STOP', 'mpp_nc_generic+lsend and lrecv not yet implemented') + ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' + CALL ctl_stop( 'STOP', ctmp1 ) + ELSE ! default neighbours + llsend(:) = mpiSnei(ihls,:) >= 0 + IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners + llrecv(:) = mpiRnei(ihls,:) >= 0 + IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners + ENDIF + ! + ! define ifill: which method should be used to fill each parts (sides+corners) of the halos + ! default definition + DO jn = 1, 8 + IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication + ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity + ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined + ELSE ; ifill(jn) = jpfillcst ! constant value (zland) + ENDIF + END DO + ! take care of "indirect self-periodicity" for the corners + DO jn = 5, 8 + IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpwe)) ifill(jn) = jpfillnothing ! no bi-perio but ew-perio: do corners later + IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpso)) ifill(jn) = jpfillnothing ! no bi-perio but ns-perio: do corners later + END DO + ! north fold treatment + IF( l_IdoNFold ) THEN + ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false. + ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo + ENDIF + + ! We first define the localization and size of the parts of the array that will be sent (s), received (r) + ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions. + ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array + ! + ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls + ! ! ________________________ + ip0i = 0 ! im0j = inner |__|________________|__| + ip1i = ihls ! im1j = inner - halo | |__|__________|__| | + im1i = ipi-2*ihls ! | | | | | | + im0i = ipi - ihls ! | | | | | | + ip0j = 0 ! | | | | | | + ip1j = ihls ! | |__|__________|__| | + im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__| + im0j = ipj - ihls ! ip0j = 0 |__|________________|__| + ! ! ip0i ip1i im1i im0i + ! + iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /) + ! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea + isizei(1:4) = (/ ihls, ihls, Ni_0, Ni_0 /) ; isizei(5:8) = ihls ! i- count + isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8) = ihls ! j- count + ishtSi(1:4) = (/ ip1i, im1i, ip1i, ip1i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data + ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data + ishtRi(1:4) = (/ ip0i, im0i, ip1i, ip1i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location + ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location + ishtPi(1:4) = (/ im1i, ip1i, ip1i, ip1i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity + ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity + ! + ! -------------------------------- ! + ! 2. Prepare MPI exchanges ! + ! -------------------------------- ! + ! + ! Allocate local temporary arrays to be sent/received. + iszS = COUNT( llsend ) + iszR = COUNT( llrecv ) + ALLOCATE( iScnt(iszS), iRcnt(iszR), iSdpl(iszS), iRdpl(iszR) ) ! ok if iszS = 0 or iszR = 0 + iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf + iScnt(:) = PACK( iszall, mask = llsend ) ! ok if mask = .false. + iRcnt(:) = PACK( iszall, mask = llrecv ) + IF( iszS > 0 ) iSdpl(1) = 0 + DO jn = 2,iszS + iSdpl(jn) = iSdpl(jn-1) + iScnt(jn-1) ! with _alltoallv: in units of sendtype + END DO + IF( iszR > 0 ) iRdpl(1) = 0 + DO jn = 2,iszR + iRdpl(jn) = iRdpl(jn-1) + iRcnt(jn-1) ! with _alltoallv: in units of sendtype + END DO + + ! Allocate buffer arrays to be sent/received if needed + iszS = SUM(iszall, mask = llsend) ! send buffer size + IF( ALLOCATED(BUFFSND) ) THEN + IF( SIZE(BUFFSND) < iszS ) DEALLOCATE(BUFFSND) ! send buffer is too small + ENDIF + IF( .NOT. ALLOCATED(BUFFSND) ) ALLOCATE( BUFFSND(iszS) ) + iszR = SUM(iszall, mask = llrecv) ! recv buffer size + IF( ALLOCATED(BUFFRCV) ) THEN + IF( SIZE(BUFFRCV) < iszR ) DEALLOCATE(BUFFRCV) ! recv buffer is too small + ENDIF + IF( .NOT. ALLOCATED(BUFFRCV) ) ALLOCATE( BUFFRCV(iszR) ) + + ! fill sending buffer with ptab(jf)%pt4d + idx = 1 + DO jn = 1, 8 + IF( llsend(jn) ) THEN + ishti = ishtSi(jn) + ishtj = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + BUFFSND(idx) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) + idx = idx + 1 + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + END DO + ! + ! ------------------------------------------------ ! + ! 3. Do all MPI exchanges in 1 unique call ! + ! ------------------------------------------------ ! + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + CALL mpi_neighbor_alltoallv (BUFFSND, iScnt, iSdpl, MPI_TYPE, BUFFRCV, iRcnt, iRdpl, MPI_TYPE, impi_nc, ierr) + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ------------------------- ! + ! 4. Fill all halos ! + ! ------------------------- ! + ! + idx = 1 + ! MPI3 bug fix when domain decomposition has 2 columns/rows + IF (jpni .eq. 2) THEN + IF (jpnj .eq. 2) THEN + jnf(1:8) = (/ 2, 1, 4, 3, 8, 7, 6, 5 /) + ELSE + jnf(1:8) = (/ 2, 1, 3, 4, 6, 5, 8, 7 /) + ENDIF + ELSE + IF (jpnj .eq. 2) THEN + jnf(1:8) = (/ 1, 2, 4, 3, 7, 8, 5, 6 /) + ELSE + jnf(1:8) = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) + ENDIF + ENDIF + + DO jn = 1, 8 + ishti = ishtRi(jnf(jn)) + ishtj = ishtRj(jnf(jn)) + SELECT CASE ( ifill(jnf(jn)) ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! fill with data received by MPI + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idx) + idx = idx + 1 + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use periodicity + ishti2 = ishtPi(jnf(jn)) + ishtj2 = ishtPj(jnf(jn)) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + ishti2 = ishtSi(jnf(jn)) + ishtj2 = ishtSj(jnf(jn)) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland + END DO ; END DO ; END DO ; END DO ; END DO + END SELECT + END DO + + DEALLOCATE( iScnt, iRcnt, iSdpl, iRdpl ) + IF( iszS > jpi*jpj ) DEALLOCATE(BUFFSND) ! blocking Send -> can directly deallocate + IF( iszR > jpi*jpj ) DEALLOCATE(BUFFRCV) ! blocking Recv -> can directly deallocate + + ! potential "indirect self-periodicity" for the corners + DO jn = 5, 8 + IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpwe) ) THEN ! no bi-perio but ew-perio: corners indirect definition + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + ishti2 = ishtPi(jn) ! use i- shift periodicity + ishtj2 = ishtRj(jn) ! use j- shift recv location: use ew-perio -> ok as filling of the south and north halos now done + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpso) ) THEN ! no bi-perio but ns-perio: corners indirect definition + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + ishti2 = ishtRi(jn) ! use i- shift recv location: use ns-perio -> ok as filling of the west and east halos now done + ishtj2 = ishtPj(jn) ! use j- shift periodicity + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + END DO + ! + ! ------------------------------- ! + ! 5. north fold treatment ! + ! ------------------------------- ! + ! + IF( l_IdoNFold ) THEN + IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold + ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold + ENDIF + ENDIF + ! + END SUBROUTINE lbc_lnk_neicoll_/**/PRECISION \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_lnk_pt2pt_generic.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_lnk_pt2pt_generic.h90 new file mode 100644 index 0000000..360a1b9 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_lnk_pt2pt_generic.h90 @@ -0,0 +1,301 @@ +#if ! defined BLOCK_ISEND && ! defined BLOCK_FILL + SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) + REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls + LOGICAL, DIMENSION(8),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc + LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) + ! + INTEGER :: ji, jj, jk, jl, jf, jn ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ip0i, ip1i, im0i, im1i + INTEGER :: ip0j, ip1j, im0j, im1j + INTEGER :: ishti, ishtj, ishti2, ishtj2 + INTEGER :: ifill_nfd, icomm, ierr + INTEGER :: ihls, idxs, idxr, iszS, iszR + INTEGER, DIMENSION(4) :: iwewe, issnn + INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi + INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj + INTEGER, DIMENSION(8) :: ifill, iszall, ishtS, ishtR + INTEGER, DIMENSION(8) :: ireq ! mpi_request id + INTEGER, DIMENSION(8) :: iStag, iRtag ! Send and Recv mpi_tag id + REAL(PRECISION) :: zland + LOGICAL, DIMENSION(8) :: llsend, llrecv + LOGICAL :: ll4only ! default: 8 neighbourgs + !!---------------------------------------------------------------------- + ! + ! ----------------------------------------- ! + ! 1. local variables initialization ! + ! ----------------------------------------- ! + ! + ipi = SIZE(ptab(1)%pt4d,1) + ipj = SIZE(ptab(1)%pt4d,2) + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) + ! + idxs = 1 ! initalize index for send buffer + idxr = 1 ! initalize index for recv buffer + icomm = mpi_comm_oce ! shorter name + ! + ! take care of optional parameters + ! + ihls = nn_hls ! default definition + IF( PRESENT( khls ) ) ihls = khls + IF( ihls > n_hlsmax ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( ipi /= Ni_0+2*ihls ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0 + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( ipj /= Nj_0+2*ihls ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0 + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + ! + ll4only = .FALSE. ! default definition + IF( PRESENT(ld4only) ) ll4only = ld4only + ! + zland = 0._wp ! land filling value: zero by default + IF( PRESENT( pfillval ) ) zland = pfillval ! set land value + ! + ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not. + IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs + llsend(:) = lsend(:) ; llrecv(:) = lrecv(:) + ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN + WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' + CALL ctl_stop( 'STOP', ctmp1 ) + ELSE ! default neighbours + llsend(:) = mpiSnei(ihls,:) >= 0 + IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners + llrecv(:) = mpiRnei(ihls,:) >= 0 + IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners + ENDIF + ! + ! define ifill: which method should be used to fill each parts (sides+corners) of the halos + ! default definition + DO jn = 1, 4 + IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication + ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity + ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined + ELSE ; ifill(jn) = jpfillcst ! constant value (zland) + ENDIF + END DO + DO jn = 5, 8 + IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication + ELSE ; ifill(jn) = jpfillnothing! do nothing + ENDIF + END DO + ! + ! north fold treatment + IF( l_IdoNFold ) THEN + ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false. + ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo + ENDIF + + ! We first define the localization and size of the parts of the array that will be sent (s), received (r) + ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions. + ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array + ! + ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls + ! ! ________________________ + ip0i = 0 ! im0j = inner |__|__|__________|__|__| + ip1i = ihls ! im1j = inner - halo |__|__|__________|__|__| + im1i = ipi-2*ihls ! | | | | | | + im0i = ipi - ihls ! | | | | | | + ip0j = 0 ! | | | | | | + ip1j = ihls ! |__|__|__________|__|__| + im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__| + im0j = ipj - ihls ! ip0j = 0 |__|__|__________|__|__| + ! ! ip0i ip1i im1i im0i + ! + iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /) + !cd sides: west east south north ; corners: so-we, so-ea, no-we, no-ea + isizei(1:4) = (/ ihls, ihls, ipi, ipi /) ; isizei(5:8) = ihls ! i- count + isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8) = ihls ! j- count + ishtSi(1:4) = (/ ip1i, im1i, ip0i, ip0i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data + ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data + ishtRi(1:4) = (/ ip0i, im0i, ip0i, ip0i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location + ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location + ishtPi(1:4) = (/ im1i, ip1i, ip0i, ip0i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity + ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity + ! + ! -------------------------------- ! + ! 2. Prepare MPI exchanges ! + ! -------------------------------- ! + ! + iStag = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) ! any value but each one must be different + ! define iRtag with the corresponding iStag, e.g. data received at west where sent at east. + iRtag(jpwe) = iStag(jpea) ; iRtag(jpea) = iStag(jpwe) ; iRtag(jpso) = iStag(jpno) ; iRtag(jpno) = iStag(jpso) + iRtag(jpsw) = iStag(jpne) ; iRtag(jpse) = iStag(jpnw) ; iRtag(jpnw) = iStag(jpse) ; iRtag(jpne) = iStag(jpsw) + ! + iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf + ishtS(1) = 0 + DO jn = 2, 8 + ishtS(jn) = ishtS(jn-1) + iszall(jn-1) * COUNT( (/llsend(jn-1)/) ) + END DO + ishtR(1) = 0 + DO jn = 2, 8 + ishtR(jn) = ishtR(jn-1) + iszall(jn-1) * COUNT( (/llrecv(jn-1)/) ) + END DO + + ! Allocate buffer arrays to be sent/received if needed + iszS = SUM(iszall, mask = llsend) ! send buffer size + IF( ALLOCATED(BUFFSND) ) THEN + CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! wait for Isend from the PREVIOUS call + IF( SIZE(BUFFSND) < iszS ) DEALLOCATE(BUFFSND) ! send buffer is too small + ENDIF + IF( .NOT. ALLOCATED(BUFFSND) ) ALLOCATE( BUFFSND(iszS) ) + iszR = SUM(iszall, mask = llrecv) ! recv buffer size + IF( ALLOCATED(BUFFRCV) ) THEN + IF( SIZE(BUFFRCV) < iszR ) DEALLOCATE(BUFFRCV) ! recv buffer is too small + ENDIF + IF( .NOT. ALLOCATED(BUFFRCV) ) ALLOCATE( BUFFRCV(iszR) ) + ! + ! default definition when no communication is done. understood by mpi_waitall + nreq_p2p(:) = MPI_REQUEST_NULL ! WARNING: Must be done after the call to mpi_waitall just above + ! + ! ----------------------------------------------- ! + ! 3. Do east and west MPI_Isend if needed ! + ! ----------------------------------------------- ! + ! + DO jn = 1, 2 +#define BLOCK_ISEND +# include "lbc_lnk_pt2pt_generic.h90" +#undef BLOCK_ISEND + END DO + ! + ! ----------------------------------- ! + ! 4. Fill east and west halos ! + ! ----------------------------------- ! + ! + DO jn = 1, 2 +#define BLOCK_FILL +# include "lbc_lnk_pt2pt_generic.h90" +#undef BLOCK_FILL + END DO + ! + ! ------------------------------------------------- ! + ! 5. Do north and south MPI_Isend if needed ! + ! ------------------------------------------------- ! + ! + DO jn = 3, 4 +#define BLOCK_ISEND +# include "lbc_lnk_pt2pt_generic.h90" +#undef BLOCK_ISEND + END DO + ! + ! ------------------------------- ! + ! 6. north fold treatment ! + ! ------------------------------- ! + ! + ! Must be done after receiving data from East/West neighbourgs (as it is coded in mpp_nfd, to be changed one day...) + ! Do it after MPI_iSend to south/north neighbourgs so they won't wait (too much) to receive their data + ! Do if before MPI_Recv from south/north neighbourgs so we have more time to receive data + ! + IF( l_IdoNFold ) THEN + IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold + ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold + ENDIF + ENDIF + ! + ! ------------------------------------- ! + ! 7. Fill south and north halos ! + ! ------------------------------------- ! + ! + DO jn = 3, 4 +#define BLOCK_FILL +# include "lbc_lnk_pt2pt_generic.h90" +#undef BLOCK_FILL + END DO + ! + ! ----------------------------------------------- ! + ! 8. Specific problem in corner treatment ! + ! ( very rate case... ) ! + ! ----------------------------------------------- ! + ! + DO jn = 5, 8 +#define BLOCK_ISEND +# include "lbc_lnk_pt2pt_generic.h90" +#undef BLOCK_ISEND + END DO + DO jn = 5, 8 +#define BLOCK_FILL +# include "lbc_lnk_pt2pt_generic.h90" +#undef BLOCK_FILL + END DO + ! + ! -------------------------------------------- ! + ! 9. deallocate local temporary arrays ! + ! if they areg larger than jpi*jpj ! <- arbitrary max size... + ! -------------------------------------------- ! + ! + IF( iszR > jpi*jpj ) DEALLOCATE(BUFFRCV) ! blocking receive -> can directly deallocate + IF( iszS > jpi*jpj ) THEN + CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! must wait before deallocate send buffer + DEALLOCATE(BUFFSND) + ENDIF + ! + END SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION +#endif + +#if defined BLOCK_ISEND + IF( llsend(jn) ) THEN + ishti = ishtSi(jn) + ishtj = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + BUFFSND(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) + idxs = idxs + 1 + END DO ; END DO ; END DO ; END DO ; END DO +#if ! defined key_mpi_off + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! non-blocking send of the west/east side using local buffer + CALL MPI_ISEND( BUFFSND(ishtS(jn)+1), iszall(jn), MPI_TYPE, mpiSnei(ihls,jn), iStag(jn), icomm, nreq_p2p(jn), ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE.) +#endif + ENDIF +#endif + +#if defined BLOCK_FILL + ishti = ishtRi(jn) + ishtj = ishtRj(jn) + SELECT CASE ( ifill(jn) ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! fill with data received by MPI +#if ! defined key_mpi_off + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! ! blocking receive of the west/east halo in local temporary arrays + CALL MPI_RECV( BUFFRCV(ishtR(jn)+1), iszall(jn), MPI_TYPE, mpiRnei(ihls,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE.) +#endif + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idxr) + idxr = idxr + 1 + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use periodicity + ishti2 = ishtPi(jn) + ishtj2 = ishtPj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + ishti2 = ishtSi(jn) + ishtj2 = ishtSj(jn) + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) + ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland + END DO ; END DO ; END DO ; END DO ; END DO + END SELECT +#endif \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_nfd_ext_generic.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_nfd_ext_generic.h90 new file mode 100644 index 0000000..3b2f314 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_nfd_ext_generic.h90 @@ -0,0 +1,118 @@ +SUBROUTINE lbc_nfd_ext_/**/PRECISION( ptab, cd_nat, psgn, kextj ) + !!---------------------------------------------------------------------- + REAL(PRECISION), DIMENSION(:,1-kextj:),INTENT(inout) :: ptab + CHARACTER(len=1), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(PRECISION), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER, INTENT(in ) :: kextj ! extra halo width at north fold + ! + INTEGER :: ji, jj, jh ! dummy loop indices + INTEGER :: ipj + INTEGER :: ijt, iju, ipjm1 + !!---------------------------------------------------------------------- + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; ipj = jpj ! 1 proc only along the i-direction + CASE DEFAULT ; ipj = 4 ! several proc along the i-direction + END SELECT + ! + ipjm1 = ipj-1 + ! + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + ! + SELECT CASE ( cd_nat ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jh = 0, kextj + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) + END DO + ptab(1,ipj+jh) = psgn * ptab(3,ipj-2-jh) + END DO + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+2 + ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) + END DO + CASE ( 'U' ) ! U-point + DO jh = 0, kextj + DO ji = 2, jpiglo-1 + iju = jpiglo-ji+1 + ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-2-jh) + END DO + ptab( 1 ,ipj+jh) = psgn * ptab( 2 ,ipj-2-jh) + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-2-jh) + END DO + DO ji = jpiglo/2, jpiglo-1 + iju = jpiglo-ji+1 + ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) + END DO + CASE ( 'V' ) ! V-point + DO jh = 0, kextj + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + ptab(ji,ipj-1+jh) = psgn * ptab(ijt,ipj-2-jh) + ptab(ji,ipj+jh ) = psgn * ptab(ijt,ipj-3-jh) + END DO + ptab(1,ipj+jh) = psgn * ptab(3,ipj-3-jh) + END DO + CASE ( 'F' ) ! F-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji+1 + ptab(ji,ipj-1+jh) = psgn * ptab(iju,ipj-2-jh) + ptab(ji,ipj+jh ) = psgn * ptab(iju,ipj-3-jh) + END DO + END DO + DO jh = 0, kextj + ptab( 1 ,ipj+jh) = psgn * ptab( 2 ,ipj-3-jh) + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-3-jh) + END DO + END SELECT + ! + ENDIF ! c_NFtype == 'T' + ! + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + ! + SELECT CASE ( cd_nat ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jh = 0, kextj + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-1-jh) + END DO + END DO + CASE ( 'U' ) ! U-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-1-jh) + END DO + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-1-jh) + END DO + CASE ( 'V' ) ! V-point + DO jh = 0, kextj + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) + END DO + END DO + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+1 + ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) + END DO + CASE ( 'F' ) ! F-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + ptab(ji,ipj+jh ) = psgn * ptab(iju,ipj-2-jh) + END DO + ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-2-jh) + END DO + DO ji = jpiglo/2+1, jpiglo-1 + iju = jpiglo-ji + ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) + END DO + END SELECT + ! + ENDIF ! c_NFtype == 'F' + ! + END SUBROUTINE lbc_nfd_ext_/**/PRECISION \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_nfd_generic.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_nfd_generic.h90 new file mode 100644 index 0000000..77cbe5b --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbc_nfd_generic.h90 @@ -0,0 +1,389 @@ +SUBROUTINE lbc_nfd_/**/PRECISION( ptab, cd_nat, psgn, khls, kfld ) + TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + ! + INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ii1, ii2, ij1, ij2 + !!---------------------------------------------------------------------- + ! + ipi = SIZE(ptab(1)%pt4d,1) + ipj = SIZE(ptab(1)%pt4d,2) + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( ipi /= Ni0glo+2*khls ) THEN + WRITE(ctmp1,*) 'lbc_nfd input array does not match khls', ipi, khls, Ni0glo + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + ! + DO jf = 1, ipf ! Loop on the number of arrays to be treated + ! + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + ! + SELECT CASE ( cd_nat(jf) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls+1 + ii1 = khls + ji + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + 1 + ii1 = ipi - khls + ji + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls-1 ! last khls-1 points + ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi + ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2-1 ! points from ipi/2+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji + 1 ! ends at: ipi/2 + (ipi/2 - khls - 1) + 1 = ipi - khls + ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls - 1) + 1 = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-khls + ii1 = ji ! ends at: khls + ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls-1 points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + CASE ( 'U' ) ! U-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls + ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-khls + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls-1 points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + CASE ( 'V' ) ! V-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls+1 lines (from ipj to ipj-khls) : full + DO jj = 1, khls+1 + ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls + ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls+1 + ii1 = khls + ji + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + 1 + ii1 = ipi - khls + ji + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls-1 ! last khls-1 points + ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi + ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + CASE ( 'F' ) ! F-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls+1 lines (from ipj to ipj-khls) : full + DO jj = 1, khls+1 + ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls + ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + END SELECT ! cd_nat(jf) + ! + ENDIF ! c_NFtype == 'T' + ! + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + ! + SELECT CASE ( cd_nat(jf) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! first: line number ipj-khls : 3 points + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, 1 ! points from ipi/2+1 + ii1 = ipi/2 + ji + ii2 = ipi/2 - ji + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... + END DO + DO ji = 1, 1 ! points ipi - khls + ii1 = ipi - khls + ji - 1 + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... + END DO + DO ji = 1, 1 ! point khls: redo it just in case (if e-w periodocity already done) + ! ! as we just changed point ipi - khls + ii1 = khls + ji - 1 + ii2 = khls + ji + ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign... + END DO + END DO + ! + ! Second: last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls + ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + CASE ( 'U' ) ! U-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls + ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls + ! + DO ji = 1, khls-1 ! first khls-1 points + ii1 = ji ! ends at: khls-1 + ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls + ii1 = khls + ji - 1 + ii2 = ipi - ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1 + ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + ii1 = ipi - khls + ji - 1 + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + END DO; END DO + CASE ( 'V' ) ! V-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls ! first khls points + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls + ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-khls + ii1 = ji ! ends at: khls + ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + CASE ( 'F' ) ! F-point + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! last khls lines (from ipj to ipj-khls+1) : full + DO jj = 1, khls + ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1 + ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 + ! + DO ji = 1, khls-1 ! first khls-1 points + ii1 = ji ! ends at: khls-1 + ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point khls + ii1 = khls + ji - 1 + ii2 = ipi - ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls) + ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1 + ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, 1 ! point ipi - khls + ii1 = ipi - khls + ji - 1 + ii2 = ii1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls ! last khls points + ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi + ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + ! + ! line number ipj-khls : right half + DO jj = 1, 1 + ij1 = ipj - khls + ij2 = ij1 ! same line + ! + DO ji = 1, Ni0glo/2-1 ! points from ipi/2+1 to ipi - khls-1 (note: Ni0glo = ipi - 2*khls) + ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls + ii2 = ipi/2 - ji ! ends at: ipi/2 - (ipi/2 - khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = 1, khls-1 ! first khls-1 points: redo them just in case (if e-w periodocity already done) + ! ! as we just changed points ipi-2khls+1 to ipi-nn_hl-1 + ii1 = ji ! ends at: khls + ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1 + ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + ! ! last khls points: have been / will done by e-w periodicity + END DO + ! + END DO; END DO + END SELECT ! cd_nat(jf) + ! + ENDIF ! c_NFtype == 'F' + ! + END DO ! ipf + ! + END SUBROUTINE lbc_nfd_/**/PRECISION \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbclnk.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbclnk.F90 new file mode 100644 index 0000000..7deb123 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbclnk.F90 @@ -0,0 +1,205 @@ +MODULE lbclnk + !!====================================================================== + !! *** MODULE lbclnk *** + !! NEMO : lateral boundary conditions + !!===================================================================== + !! History : OPA ! 1997-06 (G. Madec) Original code + !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module + !! 3.2 ! 2009-03 (R. Benshila) External north fold treatment + !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk + !! 3.4 ! 2012-12 (R. Bourdalle-Badie, G. Reffray) add a C1D case + !! 3.6 ! 2015-06 (O. Tintó and M. Castrillo) add lbc_lnk_multi + !! 4.0 ! 2017-03 (G. Madec) automatique allocation of array size (use with any 3rd dim size) + !! - ! 2017-04 (G. Madec) remove duplicated routines (lbc_lnk_2d_9, lbc_lnk_2d_multiple, lbc_lnk_3d_gather) + !! - ! 2017-05 (G. Madec) create generic.h90 files to generate all lbc and north fold routines + !!---------------------------------------------------------------------- + !! define the generic interfaces of lib_mpp routines + !!---------------------------------------------------------------------- + !! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp + !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE lib_mpp ! distributed memory computing library + USE lbcnfd ! north fold + USE in_out_manager ! I/O manager +#if ! defined key_mpi_off + USE MPI +#endif + + IMPLICIT NONE + PRIVATE + + INTERFACE lbc_lnk + MODULE PROCEDURE lbc_lnk_call_2d_sp, lbc_lnk_call_3d_sp, lbc_lnk_call_4d_sp + MODULE PROCEDURE lbc_lnk_call_2d_dp, lbc_lnk_call_3d_dp, lbc_lnk_call_4d_dp + END INTERFACE + + INTERFACE lbc_lnk_pt2pt + MODULE PROCEDURE lbc_lnk_pt2pt_sp, lbc_lnk_pt2pt_dp + END INTERFACE + + INTERFACE lbc_lnk_neicoll + MODULE PROCEDURE lbc_lnk_neicoll_sp ,lbc_lnk_neicoll_dp + END INTERFACE + ! + INTERFACE lbc_lnk_icb + MODULE PROCEDURE mpp_lnk_2d_icb_dp, mpp_lnk_2d_icb_sp + END INTERFACE + + PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions + PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions + + REAL(dp), DIMENSION(:), ALLOCATABLE :: buffsnd_dp, buffrcv_dp ! MPI send/recv buffers + REAL(sp), DIMENSION(:), ALLOCATABLE :: buffsnd_sp, buffrcv_sp ! + INTEGER, DIMENSION(8) :: nreq_p2p ! request id for MPI_Isend in point-2-point communication + + !! * Substitutions + !!# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: lbclnk.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + !!---------------------------------------------------------------------- + !! *** lbc_lnk_call_[234]d_[sd]p *** + !! + !! * Dummy Argument : + !! in ==> cdname ! name of the calling subroutine (for monitoring) + !! ptab ! array to be loaded (2D, 3D or 4D) + !! cd_nat ! nature of pt2d array grid-points + !! psgn ! sign used across the north fold boundary + !! inout <=> ptab_ptr ! array of 2D, 3D or 4D pointers + !! cdna_ptr ! nature of ptab array grid-points + !! psgn_ptr ! sign used across the north fold boundary + !! kfld ! number of elements that has been attributed + !!---------------------------------------------------------------------- + ! + !!---------------------------------------------------------------------- + !! + !! *** lbc_lnk_call_[234]d_[sd]p *** + !! *** load_ptr_[234]d_[sd]p *** + !! + !!---------------------------------------------------------------------- + !! + !! ---- SINGLE PRECISION VERSIONS + !! +#define PRECISION sp +# define DIM_2d +# include "lbc_lnk_call_generic.h90" +# undef DIM_2d +# define DIM_3d +# include "lbc_lnk_call_generic.h90" +# undef DIM_3d +# define DIM_4d +# include "lbc_lnk_call_generic.h90" +# undef DIM_4d +#undef PRECISION + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +#define PRECISION dp +# define DIM_2d +# include "lbc_lnk_call_generic.h90" +# undef DIM_2d +# define DIM_3d +# include "lbc_lnk_call_generic.h90" +# undef DIM_3d +# define DIM_4d +# include "lbc_lnk_call_generic.h90" +# undef DIM_4d +#undef PRECISION + ! + !!---------------------------------------------------------------------- + !! *** lbc_lnk_pt2pt_[sd]p *** + !! *** lbc_lnk_neicoll_[sd]p *** + !! + !! * Argument : dummy argument use in lbc_lnk_... routines + !! cdname : name of the calling subroutine (for monitoring) + !! ptab : pointer of arrays on which the boundary condition is applied + !! cd_nat : nature of array grid-points + !! psgn : sign used across the north fold boundary + !! kfld : number of pt3d arrays + !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) + !! pfillval : optional, background value (used with jpfillcopy) + !!---------------------------------------------------------------------- + !! + !! ---- SINGLE PRECISION VERSIONS + !! +#define PRECISION sp +# define MPI_TYPE MPI_REAL +# define BUFFSND buffsnd_sp +# define BUFFRCV buffrcv_sp +# include "lbc_lnk_pt2pt_generic.h90" +# include "lbc_lnk_neicoll_generic.h90" +# undef MPI_TYPE +# undef BUFFSND +# undef BUFFRCV +#undef PRECISION + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +#define PRECISION dp +# define MPI_TYPE MPI_DOUBLE_PRECISION +# define BUFFSND buffsnd_dp +# define BUFFRCV buffrcv_dp +# include "lbc_lnk_pt2pt_generic.h90" +# include "lbc_lnk_neicoll_generic.h90" +# undef MPI_TYPE +# undef BUFFSND +# undef BUFFRCV +#undef PRECISION + + !!====================================================================== + !!--------------------------------------------------------------------- + !! *** routine mpp_lbc_north_icb *** + !! + !! ** Purpose : Ensure proper north fold horizontal bondary condition + !! in mpp configuration in case of jpn1 > 1 and for 2d + !! array with outer extra halo + !! + !! ** Method : North fold condition and mpp with more than one proc + !! in i-direction require a specific treatment. We gather + !! the 4+kextj northern lines of the global domain on 1 + !! processor and apply lbc north-fold on this sub array. + !! Then we scatter the north fold array back to the processors. + !! This routine accounts for an extra halo with icebergs + !! and assumes ghost rows and columns have been suppressed. + !! + !!---------------------------------------------------------------------- +# define SINGLE_PRECISION +# define ROUTINE_LNK mpp_lbc_north_icb_sp +# include "mpp_lbc_north_icb_generic.h90" +# undef ROUTINE_LNK +# undef SINGLE_PRECISION +# define ROUTINE_LNK mpp_lbc_north_icb_dp +# include "mpp_lbc_north_icb_generic.h90" +# undef ROUTINE_LNK + + + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_2d_icb *** + !! + !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs) + !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) + !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! jpi : first dimension of the local subdomain + !! jpj : second dimension of the local subdomain + !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) + !!---------------------------------------------------------------------- + +# define SINGLE_PRECISION +# define ROUTINE_LNK mpp_lnk_2d_icb_sp +# include "mpp_lnk_icb_generic.h90" +# undef ROUTINE_LNK +# undef SINGLE_PRECISION +# define ROUTINE_LNK mpp_lnk_2d_icb_dp +# include "mpp_lnk_icb_generic.h90" +# undef ROUTINE_LNK + +END MODULE lbclnk \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbcnfd.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbcnfd.F90 new file mode 100644 index 0000000..f91f19c --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lbcnfd.F90 @@ -0,0 +1,107 @@ +MODULE lbcnfd + !!====================================================================== + !! *** MODULE lbcnfd *** + !! Ocean : north fold boundary conditions + !!====================================================================== + !! History : 3.2 ! 2009-03 (R. Benshila) Original code + !! 3.5 ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization + !! 4.0 ! 2017-04 (G. Madec) automatique allocation of array argument (use any 3rd dimension) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! lbc_nfd : generic interface for lbc_nfd_sp and lbc_nfd_dp routines that is doing the north fold in a non-mpi case + !! mpp_nfd : generic interface for mpp_nfd_sp and mpp_nfd_dp routines that will use lbc_nfd directly or indirectly + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library +#if ! defined key_mpi_off + USE MPI +#endif + + IMPLICIT NONE + PRIVATE + + INTERFACE lbc_nfd ! called by mpp_nfd, lbc_lnk_pt2pt or lbc_lnk_neicoll + MODULE PROCEDURE lbc_nfd_sp, lbc_nfd_ext_sp + MODULE PROCEDURE lbc_nfd_dp, lbc_nfd_ext_dp + END INTERFACE + + INTERFACE mpp_nfd ! called by lbc_lnk_pt2pt or lbc_lnk_neicoll + MODULE PROCEDURE mpp_nfd_sp, mpp_nfd_dp + END INTERFACE + + PUBLIC mpp_nfd ! mpi north fold conditions + PUBLIC lbc_nfd ! north fold conditions + + INTEGER, PUBLIC :: nfd_nbnei + INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (: ) :: nfd_rknei + INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:) :: nfd_rksnd + INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:) :: nfd_jisnd + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: lbcnfd.F90 15267 2021-09-17 09:04:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + !!---------------------------------------------------------------------- + !! *** routine lbc_nfd_[sd]p *** + !! *** routine lbc_nfd_ext_[sd]p *** + !!---------------------------------------------------------------------- + !! + !! ** Purpose : lateral boundary condition + !! North fold treatment without processor exchanges. + !! + !! ** Method : + !! + !! ** Action : ptab with updated values along the north fold + !!---------------------------------------------------------------------- + ! + ! !== SINGLE PRECISION VERSIONS + ! +#define PRECISION sp +# include "lbc_nfd_generic.h90" +# include "lbc_nfd_ext_generic.h90" +#undef PRECISION + ! + ! !== DOUBLE PRECISION VERSIONS + ! +#define PRECISION dp +# include "lbc_nfd_generic.h90" +# include "lbc_nfd_ext_generic.h90" +#undef PRECISION + + !!====================================================================== + ! + !!---------------------------------------------------------------------- + !! *** routine mpp_nfd_[sd]p *** + !! + !! * Argument : dummy argument use in mpp_nfd_... routines + !! ptab : pointer of arrays on which the boundary condition is applied + !! cd_nat : nature of array grid-points + !! psgn : sign used across the north fold boundary + !! kfld : optional, number of pt3d arrays + !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) + !! pfillval : optional, background value (used with jpfillcopy) + !!---------------------------------------------------------------------- + !! + !! ---- SINGLE PRECISION VERSIONS + !! +#define PRECISION sp +# define MPI_TYPE MPI_REAL +# include "mpp_nfd_generic.h90" +# undef MPI_TYPE +#undef PRECISION + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +#define PRECISION dp +# define MPI_TYPE MPI_DOUBLE_PRECISION +# include "mpp_nfd_generic.h90" +# undef MPI_TYPE +#undef PRECISION + + !!====================================================================== +END MODULE lbcnfd \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lib_mpp.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lib_mpp.F90 new file mode 100644 index 0000000..4bf56f6 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/lib_mpp.F90 @@ -0,0 +1,1744 @@ +MODULE lib_mpp + !!====================================================================== + !! *** MODULE lib_mpp *** + !! Ocean numerics: massively parallel processing library + !!===================================================================== + !! History : OPA ! 1994 (M. Guyon, J. Escobar, M. Imbard) Original code + !! 7.0 ! 1997 (A.M. Treguier) SHMEM additions + !! 8.0 ! 1998 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI + !! ! 1998 (J.M. Molines) Open boundary conditions + !! NEMO 1.0 ! 2003 (J.M. Molines, G. Madec) F90, free form + !! ! 2003 (J.M. Molines) add mpp_ini_north(_3d,_2d) + !! - ! 2004 (R. Bourdalle Badie) isend option in mpi + !! ! 2004 (J.M. Molines) minloc, maxloc + !! - ! 2005 (G. Madec, S. Masson) npolj=5,6 F-point & ice cases + !! - ! 2005 (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort + !! - ! 2005 (R. Benshila, G. Madec) add extra halo case + !! - ! 2008 (R. Benshila) add mpp_ini_ice + !! 3.2 ! 2009 (R. Benshila) SHMEM suppression, north fold in lbc_nfd + !! 3.2 ! 2009 (O. Marti) add mpp_ini_znl + !! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager + !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm. + !! 3.5 ! 2013 (C. Ethe, G. Madec) message passing arrays as local variables + !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations + !! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max + !! 4.0 ! 2017 (G. Madec) automatique allocation of array argument (use any 3rd dimension) + !! - ! 2017 (G. Madec) create generic.h90 files to generate all lbc and north fold routines + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! ctl_stop : update momentum and tracer Kz from a tke scheme + !! ctl_warn : initialization, namelist read, and parameters control + !! ctl_opn : Open file and check if required file is available. + !! ctl_nam : Prints informations when an error occurs while reading a namelist + !! load_nml : Read, condense and buffer namelist file into character array for use as an internal file + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! mpp_start : get local communicator its size and rank + !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) + !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) + !! mpprecv : + !! mppsend : + !! mppscatter : + !! mppgather : + !! mpp_min : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real + !! mpp_max : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real + !! mpp_sum : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real + !! mpp_minloc : + !! mpp_maxloc : + !! mppsync : + !! mppstop : + !! mpp_ini_northgather : initialisation of north fold with gathering of the communications + !! mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs + !! mpp_bcast_nml : broadcast/receive namelist character buffer from reading process to all others + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager +#if ! defined key_mpi_off + USE MPI +#endif + + IMPLICIT NONE + PRIVATE + ! + PUBLIC ctl_stop, ctl_warn, ctl_opn, ctl_nam, load_nml + PUBLIC mpp_start, mppstop, mppsync, mpp_comm_free + PUBLIC mpp_ini_northgather + PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc + PUBLIC mpp_delay_max, mpp_delay_sum, mpp_delay_rcv + PUBLIC mppscatter, mppgather + PUBLIC mpp_ini_znl + PUBLIC mpp_ini_nc + PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines + PUBLIC mppsend_sp, mpprecv_sp ! needed by TAM and ICB routines + PUBLIC mppsend_dp, mpprecv_dp ! needed by TAM and ICB routines + PUBLIC mpp_report + PUBLIC mpp_bcast_nml + PUBLIC tic_tac +#if defined key_mpi_off + PUBLIC MPI_wait + PUBLIC MPI_waitall + PUBLIC MPI_Wtime +#endif + + !! * Interfaces + !! define generic interface for these routine as they are called sometimes + !! with scalar arguments instead of array arguments, which causes problems + !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ + INTERFACE mpp_min + MODULE PROCEDURE mppmin_a_int, mppmin_int + MODULE PROCEDURE mppmin_a_real_sp, mppmin_real_sp + MODULE PROCEDURE mppmin_a_real_dp, mppmin_real_dp + END INTERFACE + INTERFACE mpp_max + MODULE PROCEDURE mppmax_a_int, mppmax_int + MODULE PROCEDURE mppmax_a_real_sp, mppmax_real_sp + MODULE PROCEDURE mppmax_a_real_dp, mppmax_real_dp + END INTERFACE + INTERFACE mpp_sum + MODULE PROCEDURE mppsum_a_int, mppsum_int + MODULE PROCEDURE mppsum_realdd, mppsum_a_realdd + MODULE PROCEDURE mppsum_a_real_sp, mppsum_real_sp + MODULE PROCEDURE mppsum_a_real_dp, mppsum_real_dp + END INTERFACE + INTERFACE mpp_minloc + MODULE PROCEDURE mpp_minloc2d_sp ,mpp_minloc3d_sp + MODULE PROCEDURE mpp_minloc2d_dp ,mpp_minloc3d_dp + END INTERFACE + INTERFACE mpp_maxloc + MODULE PROCEDURE mpp_maxloc2d_sp ,mpp_maxloc3d_sp + MODULE PROCEDURE mpp_maxloc2d_dp ,mpp_maxloc3d_dp + END INTERFACE + + TYPE, PUBLIC :: PTR_4D_sp !: array of 4D pointers (used in lbclnk and lbcnfd) + REAL(sp), DIMENSION (:,:,:,:), POINTER :: pt4d + END TYPE PTR_4D_sp + + TYPE, PUBLIC :: PTR_4D_dp !: array of 4D pointers (used in lbclnk and lbcnfd) + REAL(dp), DIMENSION (:,:,:,:), POINTER :: pt4d + END TYPE PTR_4D_dp + + !! ========================= !! + !! MPI variable definition !! + !! ========================= !! +#if ! defined key_mpi_off + LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag +#else + INTEGER, PUBLIC, PARAMETER :: MPI_STATUS_SIZE = 1 + INTEGER, PUBLIC, PARAMETER :: MPI_REAL = 4 + INTEGER, PUBLIC, PARAMETER :: MPI_DOUBLE_PRECISION = 8 + INTEGER, PUBLIC, PARAMETER :: MPI_REQUEST_NULL = 1 + LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag + INTEGER, PUBLIC, DIMENSION(MPI_STATUS_SIZE) :: MPI_STATUS_IGNORE = 1 ! out from mpi_wait + INTEGER, PUBLIC, DIMENSION(MPI_STATUS_SIZE) :: MPI_STATUSES_IGNORE = 1 ! out from mpi_waitall +#endif + + INTEGER, PUBLIC :: mppsize ! number of process + INTEGER, PUBLIC :: mpprank ! process number [ 0 - size-1 ] +!$AGRIF_DO_NOT_TREAT + INTEGER, PUBLIC :: mpi_comm_oce ! opa local communicator +!$AGRIF_END_DO_NOT_TREAT + + INTEGER :: MPI_SUMDD + + ! Neighbourgs informations + INTEGER, PARAMETER, PUBLIC :: n_hlsmax = 3 + INTEGER, DIMENSION( 8), PUBLIC :: mpinei !: 8-neighbourg MPI indexes (starting at 0, -1 if no neighbourg) + INTEGER, DIMENSION(n_hlsmax,8), PUBLIC :: mpiSnei !: 8-neighbourg Send MPI indexes (starting at 0, -1 if no neighbourg) + INTEGER, DIMENSION(n_hlsmax,8), PUBLIC :: mpiRnei !: 8-neighbourg Recv MPI indexes (starting at 0, -1 if no neighbourg) + INTEGER, PARAMETER, PUBLIC :: jpwe = 1 !: WEst + INTEGER, PARAMETER, PUBLIC :: jpea = 2 !: EAst + INTEGER, PARAMETER, PUBLIC :: jpso = 3 !: SOuth + INTEGER, PARAMETER, PUBLIC :: jpno = 4 !: NOrth + INTEGER, PARAMETER, PUBLIC :: jpsw = 5 !: South-West + INTEGER, PARAMETER, PUBLIC :: jpse = 6 !: South-East + INTEGER, PARAMETER, PUBLIC :: jpnw = 7 !: North-West + INTEGER, PARAMETER, PUBLIC :: jpne = 8 !: North-East + + LOGICAL, DIMENSION(8), PUBLIC :: l_SelfPerio ! should we explicitely take care of I/J periodicity + LOGICAL, PUBLIC :: l_IdoNFold + + ! variables used for zonal integration + INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average + LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row + INTEGER :: ngrp_znl !: group ID for the znl processors + INTEGER :: ndim_rank_znl !: number of processors on the same zonal average + INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain + + ! variables used for MPI3 neighbourhood collectives + INTEGER, DIMENSION(n_hlsmax), PUBLIC :: mpi_nc_com4 ! MPI3 neighbourhood collectives communicator + INTEGER, DIMENSION(n_hlsmax), PUBLIC :: mpi_nc_com8 ! MPI3 neighbourhood collectives communicator (with diagionals) + + ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) + INTEGER, PUBLIC :: ngrp_world !: group ID for the world processors + INTEGER, PUBLIC :: ngrp_opa !: group ID for the opa processors + INTEGER, PUBLIC :: ngrp_north !: group ID for the northern processors (to be fold) + INTEGER, PUBLIC :: ncomm_north !: communicator made by the processors belonging to ngrp_north + INTEGER, PUBLIC :: ndim_rank_north !: number of 'sea' processor in the northern line (can be /= jpni !) + INTEGER, PUBLIC :: njmppmax !: value of njmpp for the processors of the northern line + INTEGER, PUBLIC :: north_root !: number (in the comm_opa) of proc 0 in the northern comm + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north + + ! Communications summary report + CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_lbc !: names of lbc_lnk calling routines + CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_glb !: names of global comm calling routines + CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_dlg !: names of delayed global comm calling routines + INTEGER, PUBLIC :: ncom_stp = 0 !: copy of time step # istp + INTEGER, PUBLIC :: ncom_fsbc = 1 !: copy of sbc time step # nn_fsbc + INTEGER, PUBLIC :: ncom_freq !: frequency of comm diagnostic + INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE :: ncomm_sequence !: size of communicated arrays (halos) + INTEGER, PARAMETER, PUBLIC :: ncom_rec_max = 5000 !: max number of communication record + INTEGER, PUBLIC :: n_sequence_lbc = 0 !: # of communicated arraysvia lbc + INTEGER, PUBLIC :: n_sequence_glb = 0 !: # of global communications + INTEGER, PUBLIC :: n_sequence_dlg = 0 !: # of delayed global communications + INTEGER, PUBLIC :: numcom = -1 !: logical unit for communicaton report + LOGICAL, PUBLIC :: l_full_nf_update = .TRUE. !: logical for a full (2lines) update of bc at North fold report + INTEGER, PARAMETER, PUBLIC :: nbdelay = 2 !: number of delayed operations + !: name (used as id) of allreduce-delayed operations + ! Warning: we must use the same character length in an array constructor (at least for gcc compiler) + CHARACTER(len=32), DIMENSION(nbdelay), PUBLIC :: c_delaylist = (/ 'cflice', 'fwb ' /) + !: component name where the allreduce-delayed operation is performed + CHARACTER(len=3), DIMENSION(nbdelay), PUBLIC :: c_delaycpnt = (/ 'ICE' , 'OCE' /) + TYPE, PUBLIC :: DELAYARR + REAL( wp), POINTER, DIMENSION(:) :: z1d => NULL() + COMPLEX(dp), POINTER, DIMENSION(:) :: y1d => NULL() + END TYPE DELAYARR + TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE :: todelay !: must have SAVE for default initialization of DELAYARR + INTEGER, DIMENSION(nbdelay), PUBLIC :: ndelayid = -1 !: mpi request id of the delayed operations + + ! timing summary report + REAL(dp), DIMENSION(2), PUBLIC :: waiting_time = 0._dp + REAL(dp) , PUBLIC :: compute_time = 0._dp, elapsed_time = 0._dp + + REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend + + LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms + INTEGER, PUBLIC :: nn_comm !: namelist control of comms + + INTEGER, PUBLIC, PARAMETER :: jpfillnothing = 1 + INTEGER, PUBLIC, PARAMETER :: jpfillcst = 2 + INTEGER, PUBLIC, PARAMETER :: jpfillcopy = 3 + INTEGER, PUBLIC, PARAMETER :: jpfillperio = 4 + INTEGER, PUBLIC, PARAMETER :: jpfillmpi = 5 + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: lib_mpp.F90 15267 2021-09-17 09:04:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE mpp_start( localComm ) + !!---------------------------------------------------------------------- + !! *** routine mpp_start *** + !! + !! ** Purpose : get mpi_comm_oce, mpprank and mppsize + !!---------------------------------------------------------------------- + INTEGER , OPTIONAL , INTENT(in ) :: localComm ! + ! + INTEGER :: ierr + LOGICAL :: llmpi_init + !!---------------------------------------------------------------------- +#if ! defined key_mpi_off + ! + CALL mpi_initialized ( llmpi_init, ierr ) + IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' ) + + IF( .NOT. llmpi_init ) THEN + IF( PRESENT(localComm) ) THEN + WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator ' + WRITE(ctmp2,*) ' without calling MPI_Init before ! ' + CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) + ENDIF + CALL mpi_init( ierr ) + IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' ) + ENDIF + + IF( PRESENT(localComm) ) THEN + IF( Agrif_Root() ) THEN + mpi_comm_oce = localComm + ENDIF + ELSE + CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr) + IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' ) + ENDIF + +# if defined key_agrif + IF( Agrif_Root() ) THEN + CALL Agrif_MPI_Init(mpi_comm_oce) + ELSE + CALL Agrif_MPI_set_grid_comm(mpi_comm_oce) + ENDIF +# endif + + CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) + CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr ) + ! + CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) + ! +#else + IF( PRESENT( localComm ) ) mpi_comm_oce = localComm + mppsize = 1 + mpprank = 0 +#endif + END SUBROUTINE mpp_start + + + SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) + !!---------------------------------------------------------------------- + !! *** routine mppsend *** + !! + !! ** Purpose : Send messag passing array + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! size of the array pmess + INTEGER , INTENT(in ) :: kdest ! receive process number + INTEGER , INTENT(in ) :: ktyp ! tag of the message + INTEGER , INTENT(inout) :: md_req ! argument for isend + !! + INTEGER :: iflag + INTEGER :: mpi_working_type + !!---------------------------------------------------------------------- + ! +#if ! defined key_mpi_off + IF (wp == dp) THEN + mpi_working_type = mpi_double_precision + ELSE + mpi_working_type = mpi_real + END IF + CALL mpi_isend( pmess, kbytes, mpi_working_type, kdest , ktyp, mpi_comm_oce, md_req, iflag ) +#endif + ! + END SUBROUTINE mppsend + + + SUBROUTINE mppsend_dp( ktyp, pmess, kbytes, kdest, md_req ) + !!---------------------------------------------------------------------- + !! *** routine mppsend *** + !! + !! ** Purpose : Send messag passing array + !! + !!---------------------------------------------------------------------- + REAL(dp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! size of the array pmess + INTEGER , INTENT(in ) :: kdest ! receive process number + INTEGER , INTENT(in ) :: ktyp ! tag of the message + INTEGER , INTENT(inout) :: md_req ! argument for isend + !! + INTEGER :: iflag + !!---------------------------------------------------------------------- + ! +#if ! defined key_mpi_off + CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) +#endif + ! + END SUBROUTINE mppsend_dp + + + SUBROUTINE mppsend_sp( ktyp, pmess, kbytes, kdest, md_req ) + !!---------------------------------------------------------------------- + !! *** routine mppsend *** + !! + !! ** Purpose : Send messag passing array + !! + !!---------------------------------------------------------------------- + REAL(sp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! size of the array pmess + INTEGER , INTENT(in ) :: kdest ! receive process number + INTEGER , INTENT(in ) :: ktyp ! tag of the message + INTEGER , INTENT(inout) :: md_req ! argument for isend + !! + INTEGER :: iflag + !!---------------------------------------------------------------------- + ! +#if ! defined key_mpi_off + CALL mpi_isend( pmess, kbytes, mpi_real, kdest , ktyp, mpi_comm_oce, md_req, iflag ) +#endif + ! + END SUBROUTINE mppsend_sp + + + SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource ) + !!---------------------------------------------------------------------- + !! *** routine mpprecv *** + !! + !! ** Purpose : Receive messag passing array + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess + INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message + INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number + !! + INTEGER :: istatus(mpi_status_size) + INTEGER :: iflag + INTEGER :: use_source + INTEGER :: mpi_working_type + !!---------------------------------------------------------------------- + ! +#if ! defined key_mpi_off + ! If a specific process number has been passed to the receive call, + ! use that one. Default is to use mpi_any_source + use_source = mpi_any_source + IF( PRESENT(ksource) ) use_source = ksource + ! + IF (wp == dp) THEN + mpi_working_type = mpi_double_precision + ELSE + mpi_working_type = mpi_real + END IF + CALL mpi_recv( pmess, kbytes, mpi_working_type, use_source, ktyp, mpi_comm_oce, istatus, iflag ) +#endif + ! + END SUBROUTINE mpprecv + + SUBROUTINE mpprecv_dp( ktyp, pmess, kbytes, ksource ) + !!---------------------------------------------------------------------- + !! *** routine mpprecv *** + !! + !! ** Purpose : Receive messag passing array + !! + !!---------------------------------------------------------------------- + REAL(dp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess + INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message + INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number + !! + INTEGER :: istatus(mpi_status_size) + INTEGER :: iflag + INTEGER :: use_source + !!---------------------------------------------------------------------- + ! +#if ! defined key_mpi_off + ! If a specific process number has been passed to the receive call, + ! use that one. Default is to use mpi_any_source + use_source = mpi_any_source + IF( PRESENT(ksource) ) use_source = ksource + ! + CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) +#endif + ! + END SUBROUTINE mpprecv_dp + + + SUBROUTINE mpprecv_sp( ktyp, pmess, kbytes, ksource ) + !!---------------------------------------------------------------------- + !! *** routine mpprecv *** + !! + !! ** Purpose : Receive messag passing array + !! + !!---------------------------------------------------------------------- + REAL(sp), INTENT(inout) :: pmess(*) ! array of real + INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess + INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message + INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number + !! + INTEGER :: istatus(mpi_status_size) + INTEGER :: iflag + INTEGER :: use_source + !!---------------------------------------------------------------------- + ! +#if ! defined key_mpi_off + ! If a specific process number has been passed to the receive call, + ! use that one. Default is to use mpi_any_source + use_source = mpi_any_source + IF( PRESENT(ksource) ) use_source = ksource + ! + CALL mpi_recv( pmess, kbytes, mpi_real, use_source, ktyp, mpi_comm_oce, istatus, iflag ) +#endif + ! + END SUBROUTINE mpprecv_sp + + + SUBROUTINE mppgather( ptab, kp, pio ) + !!---------------------------------------------------------------------- + !! *** routine mppgather *** + !! + !! ** Purpose : Transfert between a local subdomain array and a work + !! array which is distributed following the vertical level. + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: ptab ! subdomain input array + INTEGER , INTENT(in ) :: kp ! record length + REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array + !! + INTEGER :: itaille, ierror ! temporary integer + !!--------------------------------------------------------------------- + ! + itaille = jpi * jpj +#if ! defined key_mpi_off + CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , & + & mpi_double_precision, kp , mpi_comm_oce, ierror ) +#else + pio(:,:,1) = ptab(:,:) +#endif + ! + END SUBROUTINE mppgather + + + SUBROUTINE mppscatter( pio, kp, ptab ) + !!---------------------------------------------------------------------- + !! *** routine mppscatter *** + !! + !! ** Purpose : Transfert between awork array which is distributed + !! following the vertical level and the local subdomain array. + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array + INTEGER :: kp ! Tag (not used with MPI + REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input + !! + INTEGER :: itaille, ierror ! temporary integer + !!--------------------------------------------------------------------- + ! + itaille = jpi * jpj + ! +#if ! defined key_mpi_off + CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & + & mpi_double_precision, kp , mpi_comm_oce, ierror ) +#else + ptab(:,:) = pio(:,:,1) +#endif + ! + END SUBROUTINE mppscatter + + + SUBROUTINE mpp_delay_sum( cdname, cdelay, y_in, pout, ldlast, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mpp_delay_sum *** + !! + !! ** Purpose : performed delayed mpp_sum, the result is received on next call + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation + COMPLEX(dp), INTENT(in ), DIMENSION(:) :: y_in + REAL(wp), INTENT( out), DIMENSION(:) :: pout + LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine + INTEGER, INTENT(in ), OPTIONAL :: kcom + !! + INTEGER :: ji, isz + INTEGER :: idvar + INTEGER :: ierr, ilocalcomm + COMPLEX(dp), ALLOCATABLE, DIMENSION(:) :: ytmp + !!---------------------------------------------------------------------- +#if ! defined key_mpi_off + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + + isz = SIZE(y_in) + + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_dlg = .TRUE. ) + + idvar = -1 + DO ji = 1, nbdelay + IF( TRIM(cdelay) == TRIM(c_delaylist(ji)) ) idvar = ji + END DO + IF ( idvar == -1 ) CALL ctl_stop( 'STOP',' mpp_delay_sum : please add a new delayed exchange for '//TRIM(cdname) ) + + IF ( ndelayid(idvar) == 0 ) THEN ! first call with restart: %z1d defined in iom_delay_rst + ! -------------------------- + IF ( SIZE(todelay(idvar)%z1d) /= isz ) THEN ! Check dimension coherence + IF(lwp) WRITE(numout,*) ' WARNING: the nb of delayed variables in restart file is not the model one' + DEALLOCATE(todelay(idvar)%z1d) + ndelayid(idvar) = -1 ! do as if we had no restart + ELSE + ALLOCATE(todelay(idvar)%y1d(isz)) + todelay(idvar)%y1d(:) = CMPLX(todelay(idvar)%z1d(:), 0., wp) ! create %y1d, complex variable needed by mpi_sumdd + ndelayid(idvar) = MPI_REQUEST_NULL ! initialised request to a valid value + END IF + ENDIF + + IF( ndelayid(idvar) == -1 ) THEN ! first call without restart: define %y1d and %z1d from y_in with blocking allreduce + ! -------------------------- + ALLOCATE(todelay(idvar)%z1d(isz), todelay(idvar)%y1d(isz)) ! allocate also %z1d as used for the restart + CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) ! get %y1d + ndelayid(idvar) = MPI_REQUEST_NULL + ENDIF + + CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received + + ! send back pout from todelay(idvar)%z1d defined at previous call + pout(:) = todelay(idvar)%z1d(:) + + ! send y_in into todelay(idvar)%y1d with a non-blocking communication +# if defined key_mpi2 + IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) + ndelayid(idvar) = MPI_REQUEST_NULL + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) +# else + CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) +# endif +#else + pout(:) = REAL(y_in(:), wp) +#endif + + END SUBROUTINE mpp_delay_sum + + + SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom ) + !!---------------------------------------------------------------------- + !! *** routine mpp_delay_max *** + !! + !! ** Purpose : performed delayed mpp_max, the result is received on next call + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation + REAL(wp), INTENT(in ), DIMENSION(:) :: p_in ! + REAL(wp), INTENT( out), DIMENSION(:) :: pout ! + LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine + INTEGER, INTENT(in ), OPTIONAL :: kcom + !! + INTEGER :: ji, isz + INTEGER :: idvar + INTEGER :: ierr, ilocalcomm + INTEGER :: MPI_TYPE + !!---------------------------------------------------------------------- + +#if ! defined key_mpi_off + if( wp == dp ) then + MPI_TYPE = MPI_DOUBLE_PRECISION + else if ( wp == sp ) then + MPI_TYPE = MPI_REAL + else + CALL ctl_stop( "Error defining type, wp is neither dp nor sp" ) + + end if + + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + + isz = SIZE(p_in) + + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_dlg = .TRUE. ) + + idvar = -1 + DO ji = 1, nbdelay + IF( TRIM(cdelay) == TRIM(c_delaylist(ji)) ) idvar = ji + END DO + IF ( idvar == -1 ) CALL ctl_stop( 'STOP',' mpp_delay_max : please add a new delayed exchange for '//TRIM(cdname) ) + + IF ( ndelayid(idvar) == 0 ) THEN ! first call with restart: %z1d defined in iom_delay_rst + ! -------------------------- + IF ( SIZE(todelay(idvar)%z1d) /= isz ) THEN ! Check dimension coherence + IF(lwp) WRITE(numout,*) ' WARNING: the nb of delayed variables in restart file is not the model one' + DEALLOCATE(todelay(idvar)%z1d) + ndelayid(idvar) = -1 ! do as if we had no restart + ELSE + ndelayid(idvar) = MPI_REQUEST_NULL + END IF + ENDIF + + IF( ndelayid(idvar) == -1 ) THEN ! first call without restart: define %z1d from p_in with a blocking allreduce + ! -------------------------- + ALLOCATE(todelay(idvar)%z1d(isz)) + CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr ) ! get %z1d + ndelayid(idvar) = MPI_REQUEST_NULL + ENDIF + + CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received + + ! send back pout from todelay(idvar)%z1d defined at previous call + pout(:) = todelay(idvar)%z1d(:) + + ! send p_in into todelay(idvar)%z1d with a non-blocking communication + ! (PM) Should we get rid of MPI2 option ? MPI3 was release in 2013. Who is still using MPI2 ? +# if defined key_mpi2 + IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) +# else + CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) +# endif +#else + pout(:) = p_in(:) +#endif + + END SUBROUTINE mpp_delay_max + + + SUBROUTINE mpp_delay_rcv( kid ) + !!---------------------------------------------------------------------- + !! *** routine mpp_delay_rcv *** + !! + !! ** Purpose : force barrier for delayed mpp (needed for restart) + !! + !!---------------------------------------------------------------------- + INTEGER,INTENT(in ) :: kid + INTEGER :: ierr + !!---------------------------------------------------------------------- +#if ! defined key_mpi_off + IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) + ! test on ndelayid(kid) useless as mpi_wait return immediatly if the request handle is MPI_REQUEST_NULL + CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! after this ndelayid(kid) = MPI_REQUEST_NULL + IF( ln_timing ) CALL tic_tac( .FALSE., ld_global = .TRUE.) + IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp) ! define %z1d from %y1d +#endif + END SUBROUTINE mpp_delay_rcv + + SUBROUTINE mpp_bcast_nml( cdnambuff , kleng ) + CHARACTER(LEN=:) , ALLOCATABLE, INTENT(INOUT) :: cdnambuff + INTEGER , INTENT(INOUT) :: kleng + !!---------------------------------------------------------------------- + !! *** routine mpp_bcast_nml *** + !! + !! ** Purpose : broadcast namelist character buffer + !! + !!---------------------------------------------------------------------- + !! + INTEGER :: iflag + !!---------------------------------------------------------------------- + ! +#if ! defined key_mpi_off + call MPI_BCAST(kleng, 1, MPI_INT, 0, mpi_comm_oce, iflag) + call MPI_BARRIER(mpi_comm_oce, iflag) +!$AGRIF_DO_NOT_TREAT + IF ( .NOT. ALLOCATED(cdnambuff) ) ALLOCATE( CHARACTER(LEN=kleng) :: cdnambuff ) +!$AGRIF_END_DO_NOT_TREAT + call MPI_BCAST(cdnambuff, kleng, MPI_CHARACTER, 0, mpi_comm_oce, iflag) + call MPI_BARRIER(mpi_comm_oce, iflag) +#endif + ! + END SUBROUTINE mpp_bcast_nml + + + !!---------------------------------------------------------------------- + !! *** mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *** + !! + !!---------------------------------------------------------------------- + !! +# define OPERATION_MAX +# define INTEGER_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppmax_int +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppmax_a_int +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef INTEGER_TYPE +! + !! + !! ---- SINGLE PRECISION VERSIONS + !! +# define SINGLE_PRECISION +# define REAL_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppmax_real_sp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppmax_a_real_sp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef SINGLE_PRECISION + !! + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +! +# define DIM_0d +# define ROUTINE_ALLREDUCE mppmax_real_dp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppmax_a_real_dp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef REAL_TYPE +# undef OPERATION_MAX + !!---------------------------------------------------------------------- + !! *** mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *** + !! + !!---------------------------------------------------------------------- + !! +# define OPERATION_MIN +# define INTEGER_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppmin_int +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppmin_a_int +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef INTEGER_TYPE +! + !! + !! ---- SINGLE PRECISION VERSIONS + !! +# define SINGLE_PRECISION +# define REAL_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppmin_real_sp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppmin_a_real_sp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef SINGLE_PRECISION + !! + !! ---- DOUBLE PRECISION VERSIONS + !! + +# define DIM_0d +# define ROUTINE_ALLREDUCE mppmin_real_dp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppmin_a_real_dp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef REAL_TYPE +# undef OPERATION_MIN + + !!---------------------------------------------------------------------- + !! *** mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *** + !! + !! Global sum of 1D array or a variable (integer, real or complex) + !!---------------------------------------------------------------------- + !! +# define OPERATION_SUM +# define INTEGER_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppsum_int +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppsum_a_int +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef INTEGER_TYPE + + !! + !! ---- SINGLE PRECISION VERSIONS + !! +# define OPERATION_SUM +# define SINGLE_PRECISION +# define REAL_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppsum_real_sp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppsum_a_real_sp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef REAL_TYPE +# undef OPERATION_SUM + +# undef SINGLE_PRECISION + + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +# define OPERATION_SUM +# define REAL_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppsum_real_dp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppsum_a_real_dp +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef REAL_TYPE +# undef OPERATION_SUM + +# define OPERATION_SUM_DD +# define COMPLEX_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppsum_realdd +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppsum_a_realdd +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef COMPLEX_TYPE +# undef OPERATION_SUM_DD + + !!---------------------------------------------------------------------- + !! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d + !! + !!---------------------------------------------------------------------- + !! + !! + !! ---- SINGLE PRECISION VERSIONS + !! +# define SINGLE_PRECISION +# define OPERATION_MINLOC +# define DIM_2d +# define ROUTINE_LOC mpp_minloc2d_sp +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_2d +# define DIM_3d +# define ROUTINE_LOC mpp_minloc3d_sp +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_3d +# undef OPERATION_MINLOC + +# define OPERATION_MAXLOC +# define DIM_2d +# define ROUTINE_LOC mpp_maxloc2d_sp +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_2d +# define DIM_3d +# define ROUTINE_LOC mpp_maxloc3d_sp +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_3d +# undef OPERATION_MAXLOC +# undef SINGLE_PRECISION + !! + !! ---- DOUBLE PRECISION VERSIONS + !! +# define OPERATION_MINLOC +# define DIM_2d +# define ROUTINE_LOC mpp_minloc2d_dp +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_2d +# define DIM_3d +# define ROUTINE_LOC mpp_minloc3d_dp +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_3d +# undef OPERATION_MINLOC + +# define OPERATION_MAXLOC +# define DIM_2d +# define ROUTINE_LOC mpp_maxloc2d_dp +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_2d +# define DIM_3d +# define ROUTINE_LOC mpp_maxloc3d_dp +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_3d +# undef OPERATION_MAXLOC + + + SUBROUTINE mppsync() + !!---------------------------------------------------------------------- + !! *** routine mppsync *** + !! + !! ** Purpose : Massively parallel processors, synchroneous + !! + !!----------------------------------------------------------------------- + INTEGER :: ierror + !!----------------------------------------------------------------------- + ! +#if ! defined key_mpi_off + CALL mpi_barrier( mpi_comm_oce, ierror ) +#endif + ! + END SUBROUTINE mppsync + + + SUBROUTINE mppstop( ld_abort ) + !!---------------------------------------------------------------------- + !! *** routine mppstop *** + !! + !! ** purpose : Stop massively parallel processors method + !! + !!---------------------------------------------------------------------- + LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number + LOGICAL :: ll_abort + INTEGER :: info, ierr + !!---------------------------------------------------------------------- + ll_abort = .FALSE. + IF( PRESENT(ld_abort) ) ll_abort = ld_abort + ! +#if ! defined key_mpi_off + IF(ll_abort) THEN + CALL mpi_abort( MPI_COMM_WORLD, 123, info ) + ELSE + CALL mppsync + CALL mpi_finalize( info ) + ENDIF +#endif + IF( ll_abort ) STOP 123 + ! + END SUBROUTINE mppstop + + + SUBROUTINE mpp_comm_free( kcom ) + !!---------------------------------------------------------------------- + INTEGER, INTENT(inout) :: kcom + !! + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! +#if ! defined key_mpi_off + CALL MPI_COMM_FREE(kcom, ierr) +#endif + ! + END SUBROUTINE mpp_comm_free + + + SUBROUTINE mpp_ini_znl( kumout ) + !!---------------------------------------------------------------------- + !! *** routine mpp_ini_znl *** + !! + !! ** Purpose : Initialize special communicator for computing zonal sum + !! + !! ** Method : - Look for processors in the same row + !! - Put their number in nrank_znl + !! - Create group for the znl processors + !! - Create a communicator for znl processors + !! - Determine if processor should write znl files + !! + !! ** output + !! ndim_rank_znl = number of processors on the same row + !! ngrp_znl = group ID for the znl processors + !! ncomm_znl = communicator for the ice procs. + !! n_znl_root = number (in the world) of proc 0 in the ice comm. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kumout ! ocean.output logical units + ! + INTEGER :: jproc ! dummy loop integer + INTEGER :: ierr, ii ! local integer + INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork + !!---------------------------------------------------------------------- +#if ! defined key_mpi_off + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_world : ', ngrp_world + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - mpi_comm_world : ', mpi_comm_world + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - mpi_comm_oce : ', mpi_comm_oce + ! + ALLOCATE( kwork(jpnij), STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij') + + IF( jpnj == 1 ) THEN + ngrp_znl = ngrp_world + ncomm_znl = mpi_comm_oce + ELSE + ! + CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_oce, ierr ) + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - kwork pour njmpp : ', kwork + !-$$ CALL flush(numout) + ! + ! Count number of processors on the same row + ndim_rank_znl = 0 + DO jproc=1,jpnij + IF ( kwork(jproc) == njmpp ) THEN + ndim_rank_znl = ndim_rank_znl + 1 + ENDIF + END DO + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ndim_rank_znl : ', ndim_rank_znl + !-$$ CALL flush(numout) + ! Allocate the right size to nrank_znl + IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl) + ALLOCATE(nrank_znl(ndim_rank_znl)) + ii = 0 + nrank_znl (:) = 0 + DO jproc=1,jpnij + IF ( kwork(jproc) == njmpp) THEN + ii = ii + 1 + nrank_znl(ii) = jproc -1 + ENDIF + END DO + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - nrank_znl : ', nrank_znl + !-$$ CALL flush(numout) + + ! Create the opa group + CALL MPI_COMM_GROUP(mpi_comm_oce,ngrp_opa,ierr) + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_opa : ', ngrp_opa + !-$$ CALL flush(numout) + + ! Create the znl group from the opa group + CALL MPI_GROUP_INCL ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr ) + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_znl ', ngrp_znl + !-$$ CALL flush(numout) + + ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row + CALL MPI_COMM_CREATE ( mpi_comm_oce, ngrp_znl, ncomm_znl, ierr ) + !-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ncomm_znl ', ncomm_znl + !-$$ CALL flush(numout) + ! + END IF + + ! Determines if processor if the first (starting from i=1) on the row + IF ( jpni == 1 ) THEN + l_znl_root = .TRUE. + ELSE + l_znl_root = .FALSE. + kwork (1) = nimpp + CALL mpp_min ( 'lib_mpp', kwork(1), kcom = ncomm_znl) + IF ( nimpp == kwork(1)) l_znl_root = .TRUE. + END IF + + DEALLOCATE(kwork) +#endif + + END SUBROUTINE mpp_ini_znl + + + SUBROUTINE mpp_ini_nc( khls ) + !!---------------------------------------------------------------------- + !! *** routine mpp_ini_nc *** + !! + !! ** Purpose : Initialize special communicators for MPI3 neighbourhood + !! collectives + !! + !! ** Method : - Create graph communicators starting from the processes + !! distribution along i and j directions + ! + !! ** output + !! mpi_nc_com4 = MPI3 neighbourhood collectives communicator + !! mpi_nc_com8 = MPI3 neighbourhood collectives communicator (with diagonals) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: khls ! halo size, default = nn_hls + ! + INTEGER, DIMENSION(:), ALLOCATABLE :: iSnei4, iRnei4, iSnei8, iRnei8 + INTEGER :: iScnt4, iRcnt4, iScnt8, iRcnt8 + INTEGER :: ierr + LOGICAL, PARAMETER :: ireord = .FALSE. + !!---------------------------------------------------------------------- +#if ! defined key_mpi_off && ! defined key_mpi2 + + iScnt4 = COUNT( mpiSnei(khls,1:4) >= 0 ) + iRcnt4 = COUNT( mpiRnei(khls,1:4) >= 0 ) + iScnt8 = COUNT( mpiSnei(khls,1:8) >= 0 ) + iRcnt8 = COUNT( mpiRnei(khls,1:8) >= 0 ) + + ALLOCATE( iSnei4(iScnt4), iRnei4(iRcnt4), iSnei8(iScnt8), iRnei8(iRcnt8) ) ! ok if icnt4 or icnt8 = 0 + + iSnei4 = PACK( mpiSnei(khls,1:4), mask = mpiSnei(khls,1:4) >= 0 ) + iRnei4 = PACK( mpiRnei(khls,1:4), mask = mpiRnei(khls,1:4) >= 0 ) + iSnei8 = PACK( mpiSnei(khls,1:8), mask = mpiSnei(khls,1:8) >= 0 ) + iRnei8 = PACK( mpiRnei(khls,1:8), mask = mpiRnei(khls,1:8) >= 0 ) + + CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt4, iSnei4, MPI_UNWEIGHTED, iRcnt4, iRnei4, MPI_UNWEIGHTED, & + & MPI_INFO_NULL, ireord, mpi_nc_com4(khls), ierr ) + CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt8, iSnei8, MPI_UNWEIGHTED, iRcnt8, iRnei8, MPI_UNWEIGHTED, & + & MPI_INFO_NULL, ireord, mpi_nc_com8(khls), ierr) + + DEALLOCATE( iSnei4, iRnei4, iSnei8, iRnei8 ) +#endif + END SUBROUTINE mpp_ini_nc + + + SUBROUTINE mpp_ini_northgather + !!---------------------------------------------------------------------- + !! *** routine mpp_ini_northgather *** + !! + !! ** Purpose : Initialize special communicator for north folding + !! condition together with global variables needed in the mpp folding + !! + !! ** Method : - Look for northern processors + !! - Put their number in nrank_north + !! - Create groups for the world processors and the north processors + !! - Create a communicator for northern processors + !! + !! ** output + !! ndim_rank_north = number of processors in the northern line + !! nrank_north (ndim_rank_north) = number of the northern procs. + !! ngrp_world = group ID for the world processors + !! ngrp_north = group ID for the northern processors + !! ncomm_north = communicator for the northern procs. + !! north_root = number (in the world) of proc 0 in the northern comm. + !! + !!---------------------------------------------------------------------- + INTEGER :: ierr + INTEGER :: jjproc + INTEGER :: ii, ji + !!---------------------------------------------------------------------- + ! +#if ! defined key_mpi_off + ! + ! Look for how many procs on the northern boundary + ndim_rank_north = 0 + DO jjproc = 1, jpni + IF( nfproc(jjproc) /= -1 ) ndim_rank_north = ndim_rank_north + 1 + END DO + ! + ! Allocate the right size to nrank_north + IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north) + ALLOCATE( nrank_north(ndim_rank_north) ) + + ! Fill the nrank_north array with proc. number of northern procs. + ! Note : the rank start at 0 in MPI + ii = 0 + DO ji = 1, jpni + IF ( nfproc(ji) /= -1 ) THEN + ii=ii+1 + nrank_north(ii)=nfproc(ji) + END IF + END DO + ! + ! create the world group + CALL MPI_COMM_GROUP( mpi_comm_oce, ngrp_world, ierr ) + ! + ! Create the North group from the world group + CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr ) + ! + ! Create the North communicator , ie the pool of procs in the north group + CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr ) + ! +#endif + END SUBROUTINE mpp_ini_northgather + + + SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype ) + !!--------------------------------------------------------------------- + !! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD + !! + !! Modification of original codes written by David H. Bailey + !! This subroutine computes yddb(i) = ydda(i)+yddb(i) + !!--------------------------------------------------------------------- + INTEGER , INTENT(in) :: ilen, itype + COMPLEX(dp), DIMENSION(ilen), INTENT(in) :: ydda + COMPLEX(dp), DIMENSION(ilen), INTENT(inout) :: yddb + ! + REAL(dp) :: zerr, zt1, zt2 ! local work variables + INTEGER :: ji, ztmp ! local scalar + !!--------------------------------------------------------------------- + ! + ztmp = itype ! avoid compilation warning + ! + DO ji=1,ilen + ! Compute ydda + yddb using Knuth's trick. + zt1 = real(ydda(ji)) + real(yddb(ji)) + zerr = zt1 - real(ydda(ji)) + zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) & + + aimag(ydda(ji)) + aimag(yddb(ji)) + + ! The result is zt1 + zt2, after normalization. + yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),dp ) + END DO + ! + END SUBROUTINE DDPDD_MPI + + + SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg ) + !!---------------------------------------------------------------------- + !! *** routine mpp_report *** + !! + !! ** Purpose : report use of mpp routines per time-setp + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + INTEGER , OPTIONAL, INTENT(in ) :: kpk, kpl, kpf + LOGICAL , OPTIONAL, INTENT(in ) :: ld_lbc, ld_glb, ld_dlg + !! + CHARACTER(len=128) :: ccountname ! name of a subroutine to count communications + LOGICAL :: ll_lbc, ll_glb, ll_dlg + INTEGER :: ji, jj, jk, jh, jf, jcount ! dummy loop indices + !!---------------------------------------------------------------------- +#if ! defined key_mpi_off + ! + ll_lbc = .FALSE. + IF( PRESENT(ld_lbc) ) ll_lbc = ld_lbc + ll_glb = .FALSE. + IF( PRESENT(ld_glb) ) ll_glb = ld_glb + ll_dlg = .FALSE. + IF( PRESENT(ld_dlg) ) ll_dlg = ld_dlg + ! + ! find the smallest common frequency: default = frequency product, if multiple, choose the larger of the 2 frequency + ncom_freq = ncom_fsbc + ! + IF ( ncom_stp == nit000+ncom_freq ) THEN ! avoid to count extra communications in potential initializations at nit000 + IF( ll_lbc ) THEN + IF( .NOT. ALLOCATED(ncomm_sequence) ) ALLOCATE( ncomm_sequence(ncom_rec_max,2) ) + IF( .NOT. ALLOCATED( crname_lbc) ) ALLOCATE( crname_lbc(ncom_rec_max ) ) + n_sequence_lbc = n_sequence_lbc + 1 + IF( n_sequence_lbc > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock + crname_lbc(n_sequence_lbc) = cdname ! keep the name of the calling routine + ncomm_sequence(n_sequence_lbc,1) = kpk*kpl ! size of 3rd and 4th dimensions + ncomm_sequence(n_sequence_lbc,2) = kpf ! number of arrays to be treated (multi) + ENDIF + IF( ll_glb ) THEN + IF( .NOT. ALLOCATED(crname_glb) ) ALLOCATE( crname_glb(ncom_rec_max) ) + n_sequence_glb = n_sequence_glb + 1 + IF( n_sequence_glb > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock + crname_glb(n_sequence_glb) = cdname ! keep the name of the calling routine + ENDIF + IF( ll_dlg ) THEN + IF( .NOT. ALLOCATED(crname_dlg) ) ALLOCATE( crname_dlg(ncom_rec_max) ) + n_sequence_dlg = n_sequence_dlg + 1 + IF( n_sequence_dlg > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock + crname_dlg(n_sequence_dlg) = cdname ! keep the name of the calling routine + ENDIF + ELSE IF ( ncom_stp == nit000+2*ncom_freq ) THEN + CALL ctl_opn( numcom, 'communication_report.txt', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) + WRITE(numcom,*) ' ' + WRITE(numcom,*) ' ------------------------------------------------------------' + WRITE(numcom,*) ' Communication pattern report (second oce+sbc+top time step):' + WRITE(numcom,*) ' ------------------------------------------------------------' + WRITE(numcom,*) ' ' + WRITE(numcom,'(A,I4)') ' Exchanged halos : ', n_sequence_lbc + jj = 0; jk = 0; jf = 0; jh = 0 + DO ji = 1, n_sequence_lbc + IF ( ncomm_sequence(ji,1) .GT. 1 ) jk = jk + 1 + IF ( ncomm_sequence(ji,2) .GT. 1 ) jf = jf + 1 + IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1 + jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2)) + END DO + WRITE(numcom,'(A,I3)') ' 3D Exchanged halos : ', jk + WRITE(numcom,'(A,I3)') ' Multi arrays exchanged halos : ', jf + WRITE(numcom,'(A,I3)') ' from which 3D : ', jj + WRITE(numcom,'(A,I10)') ' Array max size : ', jh*jpi*jpj + WRITE(numcom,*) ' ' + WRITE(numcom,*) ' lbc_lnk called' + DO ji = 1, n_sequence_lbc - 1 + IF ( crname_lbc(ji) /= 'already counted' ) THEN + ccountname = crname_lbc(ji) + crname_lbc(ji) = 'already counted' + jcount = 1 + DO jj = ji + 1, n_sequence_lbc + IF ( ccountname == crname_lbc(jj) ) THEN + jcount = jcount + 1 + crname_lbc(jj) = 'already counted' + END IF + END DO + WRITE(numcom,'(A, I4, A, A)') ' - ', jcount,' times by subroutine ', TRIM(ccountname) + END IF + END DO + IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN + WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc)) + END IF + WRITE(numcom,*) ' ' + IF ( n_sequence_glb > 0 ) THEN + WRITE(numcom,'(A,I4)') ' Global communications : ', n_sequence_glb + jj = 1 + DO ji = 2, n_sequence_glb + IF( crname_glb(ji-1) /= crname_glb(ji) ) THEN + WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(ji-1)) + jj = 0 + END IF + jj = jj + 1 + END DO + WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(n_sequence_glb)) + DEALLOCATE(crname_glb) + ELSE + WRITE(numcom,*) ' No MPI global communication ' + ENDIF + WRITE(numcom,*) ' ' + IF ( n_sequence_dlg > 0 ) THEN + WRITE(numcom,'(A,I4)') ' Delayed global communications : ', n_sequence_dlg + jj = 1 + DO ji = 2, n_sequence_dlg + IF( crname_dlg(ji-1) /= crname_dlg(ji) ) THEN + WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_dlg(ji-1)) + jj = 0 + END IF + jj = jj + 1 + END DO + WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_dlg(n_sequence_dlg)) + DEALLOCATE(crname_dlg) + ELSE + WRITE(numcom,*) ' No MPI delayed global communication ' + ENDIF + WRITE(numcom,*) ' ' + WRITE(numcom,*) ' -----------------------------------------------' + WRITE(numcom,*) ' ' + DEALLOCATE(ncomm_sequence) + DEALLOCATE(crname_lbc) + ENDIF +#endif + END SUBROUTINE mpp_report + + + SUBROUTINE tic_tac (ld_tic, ld_global) + + LOGICAL, INTENT(IN) :: ld_tic + LOGICAL, OPTIONAL, INTENT(IN) :: ld_global + REAL(dp), DIMENSION(2), SAVE :: tic_wt + REAL(dp), SAVE :: tic_ct = 0._dp + INTEGER :: ii +#if ! defined key_mpi_off + + IF( ncom_stp <= nit000 ) RETURN + IF( ncom_stp == nitend ) RETURN + ii = 1 + IF( PRESENT( ld_global ) ) THEN + IF( ld_global ) ii = 2 + END IF + + IF ( ld_tic ) THEN + tic_wt(ii) = MPI_Wtime() ! start count tic->tac (waiting time) + IF ( tic_ct > 0.0_dp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic + ELSE + waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii) ! cumulate count tic->tac + tic_ct = MPI_Wtime() ! start count tac->tic (waiting time) + ENDIF +#endif + + END SUBROUTINE tic_tac + +#if defined key_mpi_off + SUBROUTINE mpi_wait(request, status, ierror) + INTEGER , INTENT(in ) :: request + INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT( out) :: status + INTEGER , INTENT( out) :: ierror + IF (.FALSE.) THEN ! to avoid compilation warning + status(:) = -1 + ierror = -1 + ENDIF + END SUBROUTINE mpi_wait + + SUBROUTINE mpi_waitall(count, request, status, ierror) + INTEGER , INTENT(in ) :: count + INTEGER, DIMENSION(count) , INTENT(in ) :: request + INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT( out) :: status + INTEGER , INTENT( out) :: ierror + IF (.FALSE.) THEN ! to avoid compilation warning + status(:) = -1 + ierror = -1 + ENDIF + END SUBROUTINE mpi_waitall + + FUNCTION MPI_Wtime() + REAL(wp) :: MPI_Wtime + MPI_Wtime = -1. + END FUNCTION MPI_Wtime +#endif + + !!---------------------------------------------------------------------- + !! ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam, load_nml routines + !!---------------------------------------------------------------------- + + SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 , & + & cd6, cd7, cd8, cd9, cd10 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE stop_opa *** + !! + !! ** Purpose : print in ocean.outpput file a error message and + !! increment the error number (nstop) by one. + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cd1 + CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd2, cd3, cd4, cd5 + CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 + ! + CHARACTER(LEN=8) :: clfmt ! writing format + INTEGER :: inum + !!---------------------------------------------------------------------- + ! + nstop = nstop + 1 + ! + IF( cd1 == 'STOP' .AND. narea /= 1 ) THEN ! Immediate stop: add an arror message in 'ocean.output' file + CALL ctl_opn( inum, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) + WRITE(inum,*) + WRITE(inum,*) ' ==>>> Look for "E R R O R" messages in all existing *ocean.output* files' + CLOSE(inum) + ENDIF + IF( numout == 6 ) THEN ! force to open ocean.output file if not already opened + CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) + ENDIF + ! + WRITE(numout,*) + WRITE(numout,*) ' ===>>> : E R R O R' + WRITE(numout,*) + WRITE(numout,*) ' ===========' + WRITE(numout,*) + WRITE(numout,*) TRIM(cd1) + IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) + IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) + IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) + IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) + IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) + IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) + IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) + IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) + IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) + WRITE(numout,*) + ! + CALL FLUSH(numout ) + IF( numstp /= -1 ) CALL FLUSH(numstp ) + IF( numrun /= -1 ) CALL FLUSH(numrun ) + IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice) + ! + IF( cd1 == 'STOP' ) THEN + WRITE(numout,*) + WRITE(numout,*) 'huge E-R-R-O-R : immediate stop' + WRITE(numout,*) + CALL FLUSH(numout) + CALL SLEEP(60) ! make sure that all output and abort files are written by all cores. 60s should be enough... + CALL mppstop( ld_abort = .true. ) + ENDIF + ! + END SUBROUTINE ctl_stop + + + SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, & + & cd6, cd7, cd8, cd9, cd10 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE stop_warn *** + !! + !! ** Purpose : print in ocean.outpput file a error message and + !! increment the warning number (nwarn) by one. + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5 + CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 + !!---------------------------------------------------------------------- + ! + nwarn = nwarn + 1 + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ===>>> : W A R N I N G' + WRITE(numout,*) + WRITE(numout,*) ' ===============' + WRITE(numout,*) + IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) + IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) + IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) + IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) + IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) + IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) + IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) + IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) + IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) + IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) + WRITE(numout,*) + ENDIF + CALL FLUSH(numout) + ! + END SUBROUTINE ctl_warn + + + SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ctl_opn *** + !! + !! ** Purpose : Open file and check if required file is available. + !! + !! ** Method : Fortan open + !!---------------------------------------------------------------------- + INTEGER , INTENT( out) :: knum ! logical unit to open + CHARACTER(len=*) , INTENT(in ) :: cdfile ! file name to open + CHARACTER(len=*) , INTENT(in ) :: cdstat ! disposition specifier + CHARACTER(len=*) , INTENT(in ) :: cdform ! formatting specifier + CHARACTER(len=*) , INTENT(in ) :: cdacce ! access specifier + INTEGER , INTENT(in ) :: klengh ! record length + INTEGER , INTENT(in ) :: kout ! number of logical units for write + LOGICAL , INTENT(in ) :: ldwp ! boolean term for print + INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number + ! + CHARACTER(len=80) :: clfile + CHARACTER(LEN=10) :: clfmt ! writing format + INTEGER :: iost + INTEGER :: idg ! number of digits + !!---------------------------------------------------------------------- + ! + ! adapt filename + ! ---------------- + clfile = TRIM(cdfile) + IF( PRESENT( karea ) ) THEN + IF( karea > 1 ) THEN + ! Warning: jpnij is maybe not already defined when calling ctl_opn -> use mppsize instead of jpnij + idg = MAX( INT(LOG10(REAL(MAX(1,mppsize-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,a,i', i1, '.', i1, ')')") idg, idg ! '(a,a,ix.x)' + WRITE(clfile, clfmt) TRIM(clfile), '_', karea-1 + ENDIF + ENDIF +#if defined key_agrif + IF( .NOT. Agrif_Root() ) clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile) + knum=Agrif_Get_Unit() +#else + knum=get_unit() +#endif + IF( TRIM(cdfile) == '/dev/null' ) clfile = TRIM(cdfile) ! force the use of /dev/null + ! + IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters + OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh , ERR=100, IOSTAT=iost ) + ELSE IF( TRIM(cdstat) == 'APPEND' ) THEN ! cdstat can have less than 6 characters + OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS='UNKNOWN', POSITION='APPEND', ERR=100, IOSTAT=iost ) + ELSE + OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost ) + ENDIF + IF( iost /= 0 .AND. TRIM(clfile) == '/dev/null' ) & ! for windows + & OPEN(UNIT=knum,FILE='NUL', FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost ) + IF( iost == 0 ) THEN + IF(ldwp .AND. kout > 0) THEN + WRITE(kout,*) ' file : ', TRIM(clfile),' open ok' + WRITE(kout,*) ' unit = ', knum + WRITE(kout,*) ' status = ', cdstat + WRITE(kout,*) ' form = ', cdform + WRITE(kout,*) ' access = ', cdacce + WRITE(kout,*) + ENDIF + ENDIF +100 CONTINUE + IF( iost /= 0 ) THEN + WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile) + WRITE(ctmp2,*) ' ======= === ' + WRITE(ctmp3,*) ' unit = ', knum + WRITE(ctmp4,*) ' status = ', cdstat + WRITE(ctmp5,*) ' form = ', cdform + WRITE(ctmp6,*) ' access = ', cdacce + WRITE(ctmp7,*) ' iostat = ', iost + WRITE(ctmp8,*) ' we stop. verify the file ' + CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) + ENDIF + ! + END SUBROUTINE ctl_opn + + + SUBROUTINE ctl_nam ( kios, cdnam ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ctl_nam *** + !! + !! ** Purpose : Informations when error while reading a namelist + !! + !! ** Method : Fortan open + !!---------------------------------------------------------------------- + INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist + CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs + ! + CHARACTER(len=5) :: clios ! string to convert iostat in character for print + !!---------------------------------------------------------------------- + ! + WRITE (clios, '(I5.0)') kios + IF( kios < 0 ) THEN + CALL ctl_warn( 'end of record or file while reading namelist ' & + & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) ) + ENDIF + ! + IF( kios > 0 ) THEN + CALL ctl_stop( 'misspelled variable in namelist ' & + & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) ) + ENDIF + kios = 0 + ! + END SUBROUTINE ctl_nam + + + INTEGER FUNCTION get_unit() + !!---------------------------------------------------------------------- + !! *** FUNCTION get_unit *** + !! + !! ** Purpose : return the index of an unused logical unit + !!---------------------------------------------------------------------- + LOGICAL :: llopn + !!---------------------------------------------------------------------- + ! + get_unit = 15 ! choose a unit that is big enough then it is not already used in NEMO + llopn = .TRUE. + DO WHILE( (get_unit < 9999) .AND. llopn ) + get_unit = get_unit + 1 + INQUIRE( unit = get_unit, opened = llopn ) + END DO + IF( (get_unit == 9999) .AND. llopn ) THEN + CALL ctl_stop( 'STOP', 'get_unit: All logical units until 9999 are used...' ) + ENDIF + ! + END FUNCTION get_unit + + SUBROUTINE load_nml( cdnambuff , cdnamfile, kout, ldwp) + CHARACTER(LEN=:) , ALLOCATABLE, INTENT(INOUT) :: cdnambuff + CHARACTER(LEN=*), INTENT(IN ) :: cdnamfile + CHARACTER(LEN=256) :: chline + CHARACTER(LEN=1) :: csp + INTEGER, INTENT(IN) :: kout + LOGICAL, INTENT(IN) :: ldwp !: .true. only for the root broadcaster + INTEGER :: itot, iun, iltc, inl, ios, itotsav + ! + !csp = NEW_LINE('A') + ! a new line character is the best seperator but some systems (e.g.Cray) + ! seem to terminate namelist reads from internal files early if they + ! encounter new-lines. Use a single space for safety. + csp = ' ' + ! + ! Check if the namelist buffer has already been allocated. Return if it has. + ! + IF ( ALLOCATED( cdnambuff ) ) RETURN + IF( ldwp ) THEN + ! + ! Open namelist file + ! + CALL ctl_opn( iun, cdnamfile, 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, kout, ldwp ) + ! + ! First pass: count characters excluding comments and trimable white space + ! + itot=0 + 10 READ(iun,'(A256)',END=20,ERR=20) chline + iltc = LEN_TRIM(chline) + IF ( iltc.GT.0 ) THEN + inl = INDEX(chline, '!') + IF( inl.eq.0 ) THEN + itot = itot + iltc + 1 ! +1 for the newline character + ELSEIF( inl.GT.0 .AND. LEN_TRIM( chline(1:inl-1) ).GT.0 ) THEN + itot = itot + inl ! includes +1 for the newline character + ENDIF + ENDIF + GOTO 10 + 20 CONTINUE + ! + ! Allocate text cdnambuff for condensed namelist + ! +!$AGRIF_DO_NOT_TREAT + ALLOCATE( CHARACTER(LEN=itot) :: cdnambuff ) +!$AGRIF_END_DO_NOT_TREAT + itotsav = itot + ! + ! Second pass: read and transfer pruned characters into cdnambuff + ! + REWIND(iun) + itot=1 + 30 READ(iun,'(A256)',END=40,ERR=40) chline + iltc = LEN_TRIM(chline) + IF ( iltc.GT.0 ) THEN + inl = INDEX(chline, '!') + IF( inl.eq.0 ) THEN + inl = iltc + ELSE + inl = inl - 1 + ENDIF + IF( inl.GT.0 .AND. LEN_TRIM( chline(1:inl) ).GT.0 ) THEN + cdnambuff(itot:itot+inl-1) = chline(1:inl) + WRITE( cdnambuff(itot+inl:itot+inl), '(a)' ) csp + itot = itot + inl + 1 + ENDIF + ENDIF + GOTO 30 + 40 CONTINUE + itot = itot - 1 + IF( itotsav .NE. itot ) WRITE(*,*) 'WARNING in load_nml. Allocated ',itotsav,' for read buffer; but used ',itot + ! + ! Close namelist file + ! + CLOSE(iun) + !write(*,'(32A)') cdnambuff + ENDIF +#if ! defined key_mpi_off + CALL mpp_bcast_nml( cdnambuff, itot ) +#endif + END SUBROUTINE load_nml + + + !!---------------------------------------------------------------------- +END MODULE lib_mpp diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_allreduce_generic.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_allreduce_generic.h90 new file mode 100644 index 0000000..a0b41a2 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_allreduce_generic.h90 @@ -0,0 +1,89 @@ +! !== IN: ptab is an array ==! +# if defined REAL_TYPE +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i) REAL(sp) , INTENT(inout) :: ARRAY_IN(i) +# define TMP_TYPE(i) REAL(sp) , ALLOCATABLE :: work(i) +# define MPI_TYPE mpi_real +# else +# define ARRAY_TYPE(i) REAL(dp) , INTENT(inout) :: ARRAY_IN(i) +# define TMP_TYPE(i) REAL(dp) , ALLOCATABLE :: work(i) +# define MPI_TYPE mpi_double_precision +# endif +# endif +# if defined INTEGER_TYPE +# define ARRAY_TYPE(i) INTEGER , INTENT(inout) :: ARRAY_IN(i) +# define TMP_TYPE(i) INTEGER , ALLOCATABLE :: work(i) +# define MPI_TYPE mpi_integer +# endif +# if defined COMPLEX_TYPE +# define ARRAY_TYPE(i) COMPLEX(dp) , INTENT(inout) :: ARRAY_IN(i) +# define TMP_TYPE(i) COMPLEX(dp) , ALLOCATABLE :: work(i) +# define MPI_TYPE mpi_double_complex +# endif +# if defined DIM_0d +# define ARRAY_IN(i) ptab +# define I_SIZE(ptab) 1 +# endif +# if defined DIM_1d +# define ARRAY_IN(i) ptab(i) +# define I_SIZE(ptab) SIZE(ptab,1) +# endif +# if defined OPERATION_MAX +# define MPI_OPERATION mpi_max +# endif +# if defined OPERATION_MIN +# define MPI_OPERATION mpi_min +# endif +# if defined OPERATION_SUM +# define MPI_OPERATION mpi_sum +# endif +# if defined OPERATION_SUM_DD +# define MPI_OPERATION mpi_sumdd +# endif + + SUBROUTINE ROUTINE_ALLREDUCE( cdname, ptab, kdim, kcom ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + ARRAY_TYPE(:) ! array or pointer of arrays on which the boundary condition is applied + INTEGER, OPTIONAL, INTENT(in ) :: kdim ! optional pointer dimension + INTEGER, OPTIONAL, INTENT(in ) :: kcom ! optional communicator +#if ! defined key_mpi_off + ! + INTEGER :: ipi, ii, ierr + INTEGER :: ierror, ilocalcomm + TMP_TYPE(:) + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + ilocalcomm = mpi_comm_oce + IF( PRESENT(kcom) ) ilocalcomm = kcom + ! + IF( PRESENT(kdim) ) then + ipi = kdim + ELSE + ipi = I_SIZE(ptab) ! 1st dimension + ENDIF + ! + ALLOCATE(work(ipi)) + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( ARRAY_IN(:), work, ipi, MPI_TYPE, MPI_OPERATION, ilocalcomm, ierror ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + DO ii = 1, ipi + ARRAY_IN(ii) = work(ii) + ENDDO + DEALLOCATE(work) +#else + ! nothing to do if non-mpp case + RETURN +#endif + + END SUBROUTINE ROUTINE_ALLREDUCE + +#undef PRECISION +#undef ARRAY_TYPE +#undef ARRAY_IN +#undef I_SIZE +#undef MPI_OPERATION +#undef TMP_TYPE +#undef MPI_TYPE \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_lbc_north_icb_generic.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_lbc_north_icb_generic.h90 new file mode 100644 index 0000000..7e9608d --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_lbc_north_icb_generic.h90 @@ -0,0 +1,114 @@ +# if defined SINGLE_PRECISION +# define PRECISION sp +# define SENDROUTINE mppsend_sp +# define RECVROUTINE mpprecv_sp +# define MPI_TYPE MPI_REAL +# else +# define PRECISION dp +# define SENDROUTINE mppsend_dp +# define RECVROUTINE mpprecv_dp +# define MPI_TYPE MPI_DOUBLE_PRECISION +# endif + + SUBROUTINE ROUTINE_LNK( pt2d, cd_type, psgn, kextj) + !!--------------------------------------------------------------------- + !! *** routine mpp_lbc_north_icb *** + !! + !! ** Purpose : Ensure proper north fold horizontal bondary condition + !! in mpp configuration in case of jpn1 > 1 and for 2d + !! array with outer extra halo + !! + !! ** Method : North fold condition and mpp with more than one proc + !! in i-direction require a specific treatment. We gather + !! the 4+kextj northern lines of the global domain on 1 + !! processor and apply lbc north-fold on this sub array. + !! Then we scatter the north fold array back to the processors. + !! This routine accounts for an extra halo with icebergs + !! and assumes ghost rows and columns have been suppressed. + !! + !!---------------------------------------------------------------------- + REAL(PRECISION), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo + CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points + ! ! = T , U , V , F or W -points + REAL(PRECISION) , INTENT(in ) :: psgn ! = -1. the sign change across the + !! ! north fold, = 1. otherwise + INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold + ! + INTEGER :: ji, jj, jr + INTEGER :: ierr, itaille + INTEGER :: ipj, ij, iproc, ijnr, ii1, ipi, impp + ! + REAL(PRECISION), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e + REAL(PRECISION), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e + !!---------------------------------------------------------------------- +#if ! defined key_mpi_off + ! + ipj=4 + ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , & + & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , & + & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,ndim_rank_north) ) + ! +# if defined SINGLE_PRECISION + ztab_e(:,:) = 0._sp + znorthloc_e(:,:) = 0._sp +# else + ztab_e(:,:) = 0._dp + znorthloc_e(:,:) = 0._dp +# endif + ! + ij = 1 - kextj + ! put the last ipj+2*kextj lines of pt2d into znorthloc_e + DO jj = jpj - ipj + 1 - kextj , jpj + kextj + znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) + ij = ij + 1 + END DO + ! + itaille = jpimax * ( ipj + 2*kextj ) + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) +#if ! defined key_mpi_off + CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_TYPE, & + & znorthgloio_e(1,1-kextj,1), itaille, MPI_TYPE, & + & ncomm_north, ierr ) +#endif + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ijnr = 0 + DO jr = 1, ndim_rank_north ! recover the global north array + iproc = nfproc(jr) + IF( iproc /= -1 ) THEN + impp = nfimpp(jr) + ipi = nfjpi(jr) + ijnr = ijnr + 1 + DO jj = 1-kextj, ipj+kextj + DO ji = 1, ipi + ii1 = impp + ji - 1 ! corresponds to mig(ji) but for subdomain iproc + ztab_e(ii1,jj) = znorthgloio_e(ji,jj,ijnr) + END DO + END DO + ENDIF + END DO + + ! 2. North-Fold boundary conditions + ! ---------------------------------- + CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) + + ij = 1 - kextj + !! Scatter back to pt2d + DO jj = jpj - ipj + 1 - kextj , jpj + kextj + DO ji= 1, jpi + pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) + END DO + ij = ij +1 + END DO + ! + DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) + ! +#endif + END SUBROUTINE ROUTINE_LNK + +# undef PRECISION +# undef SENDROUTINE +# undef RECVROUTINE +# undef MPI_TYPE \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_lnk_icb_generic.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_lnk_icb_generic.h90 new file mode 100644 index 0000000..d5958b3 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_lnk_icb_generic.h90 @@ -0,0 +1,183 @@ +# if defined SINGLE_PRECISION +# define PRECISION sp +# define SENDROUTINE mppsend_sp +# define RECVROUTINE mpprecv_sp +# define LBCNORTH mpp_lbc_north_icb_sp +# else +# define PRECISION dp +# define SENDROUTINE mppsend_dp +# define RECVROUTINE mpprecv_dp +# define LBCNORTH mpp_lbc_north_icb_dp +# endif + + SUBROUTINE ROUTINE_LNK( cdname, pt2d, cd_type, psgn, kexti, kextj ) + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_2d_icb *** + !! + !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs) + !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) + !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. + !! + !! ** Method : Use mppsend and mpprecv function for passing mask + !! between processors following neighboring subdomains. + !! domain parameters + !! jpi : first dimension of the local subdomain + !! jpj : second dimension of the local subdomain + !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) + !! kexti : number of columns for extra outer halo + !! kextj : number of rows for extra outer halo + !!---------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + REAL(PRECISION), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo + CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points + REAL(PRECISION) , INTENT(in ) :: psgn ! sign used across the north fold + INTEGER , INTENT(in ) :: kexti ! extra i-halo width + INTEGER , INTENT(in ) :: kextj ! extra j-halo width + ! + INTEGER :: jl ! dummy loop indices + INTEGER :: imigr, iihom, ijhom ! local integers + INTEGER :: ipreci, iprecj ! - - + INTEGER :: ml_req1, ml_req2, ml_err ! for mpi_isend + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend + !! + REAL(PRECISION), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn + REAL(PRECISION), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew + !!---------------------------------------------------------------------- + ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area + iprecj = nn_hls + kextj + + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) + + ! 1. standard boundary treatment + ! ------------------------------ + ! Order matters Here !!!! + ! + ! ! East-West boundaries + ! !* Cyclic east-west + IF( l_Iperio ) THEN + pt2d(1-kexti: 1 ,:) = pt2d(jpi-1-kexti: jpi-1 ,:) ! east + pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west + ! + ELSE !* closed +# if defined SINGLE_PRECISION + IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._sp ! east except at F-point + pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._sp ! west +# else + IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._dp ! east except at F-point + pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._dp ! west +# endif + ENDIF + ! ! North-South boundaries + IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) + pt2d(:,1-kextj: 1 ) = pt2d(:,jpj-1-kextj: jpj-1) ! north + pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south + ELSE !* closed +# if defined SINGLE_PRECISION + IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._sp ! north except at F-point + pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._sp ! south +# else + IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._dp ! north except at F-point + pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._dp ! south +# endif + ENDIF + ! + + ! north fold treatment + ! ----------------------- + IF( l_IdoNFold ) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) + CASE DEFAULT ; CALL LBCNORTH ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) + END SELECT + ! + ENDIF + + ! 2. East and west directions exchange + ! ------------------------------------ + ! we play with the neigbours AND the row number because of the periodicity + ! + IF( mpinei(jpwe) >= 0 .OR. mpinei(jpea) >= 0 ) THEN ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) + iihom = jpi - (2 * nn_hls) -kexti + DO jl = 1, ipreci + r2dew(:,jl,1) = pt2d(nn_hls+jl,:) + r2dwe(:,jl,1) = pt2d(iihom +jl,:) + END DO + ENDIF + ! + ! ! Migrations + imigr = ipreci * ( jpj + 2*kextj ) + ! + ! ! Migrations + imigr = ipreci * ( jpj + 2*kextj ) + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + IF( mpinei(jpwe) >= 0 ) CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, mpinei(jpwe), ml_req1 ) + IF( mpinei(jpea) >= 0 ) CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, mpinei(jpea), ml_req2 ) + IF( mpinei(jpwe) >= 0 ) CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, mpinei(jpwe) ) + IF( mpinei(jpea) >= 0 ) CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, mpinei(jpea) ) + IF( mpinei(jpwe) >= 0 ) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF( mpinei(jpea) >= 0 ) CALL mpi_wait(ml_req2,ml_stat,ml_err) + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ! Write Dirichlet lateral conditions + iihom = jpi - nn_hls + IF( mpinei(jpwe) >= 0 ) THEN + DO jl = 1, ipreci + pt2d(jl-kexti,:) = r2dwe(:,jl,2) + END DO + ENDIF + IF( mpinei(jpea) >= 0 ) THEN + DO jl = 1, ipreci + pt2d(iihom+jl,:) = r2dew(:,jl,2) + END DO + ENDIF + + ! 3. North and south directions + ! ----------------------------- + ! always closed : we play only with the neigbours + ! + IF( mpinei(jpso) >= 0 .OR. mpinei(jpno) >= 0 ) THEN ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) + ijhom = jpj - (2 * nn_hls) - kextj + DO jl = 1, iprecj + r2dsn(:,jl,1) = pt2d(:,ijhom +jl) + r2dns(:,jl,1) = pt2d(:,nn_hls+jl) + END DO + ENDIF + ! + ! ! Migrations + imigr = iprecj * ( jpi + 2*kexti ) + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + IF( mpinei(jpso) >= 0 ) CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, mpinei(jpso), ml_req1 ) + IF( mpinei(jpno) >= 0 ) CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, mpinei(jpno), ml_req2 ) + IF( mpinei(jpso) >= 0 ) CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, mpinei(jpso) ) + IF( mpinei(jpno) >= 0 ) CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, mpinei(jpno) ) + IF( mpinei(jpso) >= 0 ) CALL mpi_wait(ml_req1,ml_stat,ml_err) + IF( mpinei(jpno) >= 0 ) CALL mpi_wait(ml_req2,ml_stat,ml_err) + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ! Write Dirichlet lateral conditions + ijhom = jpj - nn_hls + ! + IF( mpinei(jpso) >= 0 ) THEN + DO jl = 1, iprecj + pt2d(:,jl-kextj) = r2dsn(:,jl,2) + END DO + ENDIF + IF( mpinei(jpno) >= 0 ) THEN + DO jl = 1, iprecj + pt2d(:,ijhom+jl) = r2dns(:,jl,2) + END DO + ENDIF + ! + END SUBROUTINE ROUTINE_LNK + +# undef LBCNORTH +# undef PRECISION +# undef SENDROUTINE +# undef RECVROUTINE \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_loc_generic.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_loc_generic.h90 new file mode 100644 index 0000000..21783b8 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_loc_generic.h90 @@ -0,0 +1,139 @@ +!== IN: ptab is an array ==! +# if defined SINGLE_PRECISION +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +#if ! defined key_mpi_off +# define MPI_TYPE MPI_2REAL +#endif +# define PRECISION sp +# else +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +#if ! defined key_mpi_off +# define MPI_TYPE MPI_2DOUBLE_PRECISION +#endif +# define PRECISION dp +# endif + +# if defined DIM_2d +# define ARRAY_IN(i,j,k) ptab(i,j) +# define MASK_IN(i,j,k) ldmsk(i,j) +# define INDEX_TYPE(k) INTEGER , INTENT( out) :: kindex(2) +# define K_SIZE(ptab) 1 +# endif +# if defined DIM_3d +# define ARRAY_IN(i,j,k) ptab(i,j,k) +# define MASK_IN(i,j,k) ldmsk(i,j,k) +# define INDEX_TYPE(k) INTEGER , INTENT( out) :: kindex(3) +# define K_SIZE(ptab) SIZE(ptab,3) +# endif +# if defined OPERATION_MAXLOC +# define MPI_OPERATION MPI_MAXLOC +# define LOC_OPERATION MAXLOC +# define ERRVAL -HUGE +# endif +# if defined OPERATION_MINLOC +# define MPI_OPERATION MPI_MINLOC +# define LOC_OPERATION MINLOC +# define ERRVAL HUGE +# endif + + SUBROUTINE ROUTINE_LOC( cdname, ptab, ldmsk, pmin, kindex, ldhalo ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + ARRAY_TYPE(:,:,:) ! array on which loctrans operation is applied + LOGICAL , INTENT(in ) :: MASK_IN(:,:,:) ! local mask + REAL(PRECISION) , INTENT( out) :: pmin ! Global minimum of ptab + INDEX_TYPE(:) ! index of minimum in global frame + LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex + ! + INTEGER :: ierror, ii, idim + INTEGER :: index0 + INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs + REAL(PRECISION) :: zmin ! local minimum + REAL(PRECISION), DIMENSION(2,1) :: zain, zaout + LOGICAL :: llhalo + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo + ELSE ; llhalo = .FALSE. + ENDIF + ! + idim = SIZE(kindex) + ! + IF ( ANY( MASK_IN(:,:,:) ) ) THEN ! there is at least 1 valid point... + ! + ALLOCATE ( ilocs(idim) ) + ! + ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) ) + zmin = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3)) + ! + kindex(1) = mig( ilocs(1) ) +#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ + kindex(2) = mjg( ilocs(2) ) +#endif +#if defined DIM_3d /* avoid warning when kindex has 2 elements */ + kindex(3) = ilocs(3) +#endif + ! + DEALLOCATE (ilocs) + ! + index0 = kindex(1)-1 ! 1d index starting at 0 +#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ + index0 = index0 + jpiglo * (kindex(2)-1) +#endif +#if defined DIM_3d /* avoid warning when kindex has 2 elements */ + index0 = index0 + jpiglo * jpjglo * (kindex(3)-1) +#endif + ELSE + ! special case for land processors + zmin = ERRVAL(zmin) + index0 = 0 + END IF + ! + zain(1,:) = zmin + zain(2,:) = REAL(index0, PRECISION) + ! +#if ! defined key_mpi_off + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) + CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_TYPE, MPI_OPERATION ,MPI_COMM_OCE, ierror) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) +#else + zaout(:,:) = zain(:,:) +#endif + ! + pmin = zaout(1,1) + index0 = NINT( zaout(2,1) ) +#if defined DIM_3d /* avoid warning when kindex has 2 elements */ + kindex(3) = index0 / (jpiglo*jpjglo) + index0 = index0 - kindex(3) * (jpiglo*jpjglo) +#endif +#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ + kindex(2) = index0 / jpiglo + index0 = index0 - kindex(2) * jpiglo +#endif + kindex(1) = index0 + kindex(:) = kindex(:) + 1 ! start indices at 1 + + IF( .NOT. llhalo ) THEN + kindex(1) = kindex(1) - nn_hls +#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ + kindex(2) = kindex(2) - nn_hls +#endif + ENDIF + + END SUBROUTINE ROUTINE_LOC + + +#undef PRECISION +#undef ARRAY_TYPE +#undef ARRAY_IN +#undef MASK_IN +#undef K_SIZE +#if ! defined key_mpi_off +# undef MPI_TYPE +#endif +#undef MPI_OPERATION +#undef LOC_OPERATION +#undef INDEX_TYPE +#undef ERRVAL diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_nfd_generic.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_nfd_generic.h90 new file mode 100644 index 0000000..722d915 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mpp_nfd_generic.h90 @@ -0,0 +1,396 @@ +SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, khls, kfld ) + TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. + CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points + REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary + INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land + REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) + INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays + ! + LOGICAL :: ll_add_line + INTEGER :: ji, jj, jk, jl, jf, jr, jg, jn ! dummy loop indices + INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ierr, ibuffsize, iis0, iie0, impp + INTEGER :: ii1, ii2, ij1, ij2, iis, iie, iib, iig, iin + INTEGER :: i0max + INTEGER :: ij, iproc, ipni, ijnr + INTEGER, DIMENSION (:), ALLOCATABLE :: ireq_s, ireq_r ! for mpi_isend when avoiding mpi_allgather + INTEGER :: ipjtot ! sum of lines for all multi fields + INTEGER :: i012 ! 0, 1 or 2 + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijsnd ! j-position of sent lines for each field + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijbuf ! j-position of send buffer lines for each field + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijrcv ! j-position of recv buffer lines for each field + INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ii1st, iiend + INTEGER , DIMENSION(:) , ALLOCATABLE :: ipjfld ! number of sent lines for each field + REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: zbufs ! buffer, receive and work arrays + REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: zbufr ! buffer, receive and work arrays + REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc + REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo + TYPE(PTR_4D_/**/PRECISION), DIMENSION(:), ALLOCATABLE :: ztabglo ! array or pointer of arrays on which apply the b.c. + !!---------------------------------------------------------------------- + ! + ipk = SIZE(ptab(1)%pt4d,3) + ipl = SIZE(ptab(1)%pt4d,4) + ipf = kfld + ! + IF( ln_nnogather ) THEN !== no allgather exchanges ==! + + ! --- define number of exchanged lines --- + ! + ! In theory we should exchange only nn_hls lines. + ! + ! However, some other points are duplicated in the north pole folding: + ! - c_NFtype='T', grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) + ! - c_NFtype='T', grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) + ! - c_NFtype='T', grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) + ! - c_NFtype='T', grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) + ! - c_NFtype='F', grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) + ! - c_NFtype='F', grid=U : no points are duplicated + ! - c_NFtype='F', grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) + ! - c_NFtype='F', grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) + ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) + ! This explain why these duplicated points may have different values even if they are at the exact same location. + ! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE. + ! This is slightly slower but necessary to avoid different values on identical grid points!! + ! + !!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!! + !!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!! + !!!!!!!!! I don't know why we must do that... !!!!!!!! + l_full_nf_update = .TRUE. + ! also force it if not restart during the first 2 steps (leap frog?) + ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) + + ALLOCATE(ipjfld(ipf)) ! how many lines do we exchange for each field? + IF( ll_add_line ) THEN + DO jf = 1, ipf ! Loop over the number of arrays to be processed + ipjfld(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) + END DO + ELSE + ipjfld(:) = khls + ENDIF + + ipj = MAXVAL(ipjfld(:)) ! Max 2nd dimension of message transfers + ipjtot = SUM( ipjfld(:)) ! Total number of lines to be exchanged + + ! Index of modifying lines in input + ALLOCATE( ijsnd(ipj, ipf), ijbuf(ipj, ipf), ijrcv(ipj, ipf), ii1st(ipj, ipf), iiend(ipj, ipf) ) + + ij1 = 0 + DO jf = 1, ipf ! Loop over the number of arrays to be processed + ! + DO jj = 1, khls ! first khls lines (starting from top) must be fully defined + ii1st(jj, jf) = 1 + iiend(jj, jf) = jpi + END DO + ! + ! what do we do with line khls+1 (starting from top) + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + SELECT CASE ( cd_nat(jf) ) + CASE ('T','W') ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+2) ; iiend(khls+1, jf) = mi1(jpiglo-khls) + CASE ('U' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls) + CASE ('V' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi + CASE ('F' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi + END SELECT + ENDIF + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + SELECT CASE ( cd_nat(jf) ) + CASE ('T','W') ; i012 = 0 ! we don't touch line khls+1 + CASE ('U' ) ; i012 = 0 ! we don't touch line khls+1 + CASE ('V' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls ) + CASE ('F' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls-1) + END SELECT + ENDIF + ! + DO jj = 1, ipjfld(jf) + ij1 = ij1 + 1 + ijsnd(jj,jf) = jpj - 2*khls + jj - i012 ! sent lines (from bottom of sent lines) + ijbuf(jj,jf) = ij1 ! gather all lines in the snd/rcv buffers + ijrcv(jj,jf) = jpj - jj + 1 ! recv lines (from the top -> reverse order for jj) + END DO + ! + END DO + ! + i0max = jpimax - 2 * khls ! we are not sending the halos + ALLOCATE( zbufs(i0max,ipjtot,ipk,ipl), ireq_s(nfd_nbnei) ) ! store all the data to be sent in a buffer array + ibuffsize = i0max * ipjtot * ipk * ipl + ! + ! fill the send buffer with all the lines + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipjfld(jf) + ij1 = ijbuf(jj,jf) + ij2 = ijsnd(jj,jf) + DO ji = Nis0, Nie0 ! should not use any other value + iib = ji - Nis0 + 1 + zbufs(iib,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) + END DO + DO ji = Ni_0+1, i0max ! avoid sending uninitialized values (make sure we don't use it) + zbufs(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION) ! make sure we don't use it... + END DO + END DO + END DO ; END DO ; END DO + ! + ! start waiting time measurement + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + ! send the same buffer data to all neighbourgs as soon as possible + DO jn = 1, nfd_nbnei + iproc = nfd_rknei(jn) + IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN +#if ! defined key_mpi_off + CALL MPI_Isend( zbufs, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_s(jn), ierr ) +#endif + ELSE + ireq_s(jn) = MPI_REQUEST_NULL + ENDIF + END DO + ! + ALLOCATE( zbufr(i0max,ipjtot,ipk,ipl,nfd_nbnei), ireq_r(nfd_nbnei) ) + ! + DO jn = 1, nfd_nbnei + ! + iproc = nfd_rknei(jn) + ! + IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) + ! + ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received + zbufr(:,:,:,:,jn) = HUGE(0._/**/PRECISION) ! default: define it and make sure we don't use it... + SELECT CASE ( kfillmode ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillcopy ) ! filling with inner domain values + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipjfld(jf) + ij1 = ijbuf(jj,jf) + ij2 = ijsnd(jj,jf) ! we will use only the first value, see init_nfdcom + zbufr(1,ij1,jk,jl,jn) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point + END DO + END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + zbufr(1,:,:,:,jn) = pfillval ! we will use only the first value, see init_nfdcom + END SELECT + ! + ELSE IF( iproc == narea-1 ) THEN ! get data from myself! + ! + ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipjfld(jf) + ij1 = ijbuf(jj,jf) + ij2 = ijsnd(jj,jf) + DO ji = Nis0, Nie0 ! should not use any other value + iib = ji - Nis0 + 1 + zbufr(iib,ij1,jk,jl,jn) = ptab(jf)%pt4d(ji,ij2,jk,jl) + END DO + END DO + END DO ; END DO ; END DO + ! + ELSE ! get data from a neighbour trough communication +#if ! defined key_mpi_off + CALL MPI_Irecv( zbufr(:,:,:,:,jn), ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_r(jn), ierr ) +#endif + ENDIF + ! + END DO ! nfd_nbnei + ! + CALL mpi_waitall(nfd_nbnei, ireq_r, MPI_STATUSES_IGNORE, ierr) ! wait for all Irecv + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! North fold boundary condition + ! + DO jf = 1, ipf + ! + SELECT CASE ( cd_nat(jf) ) ! which grid number? + CASE ('T','W') ; iig = 1 ! T-, W-point + CASE ('U') ; iig = 2 ! U-point + CASE ('V') ; iig = 3 ! V-point + CASE ('F') ; iig = 4 ! F-point + END SELECT + ! + DO jl = 1, ipl ; DO jk = 1, ipk + ! + ! if T point with F-point pivot : must be done first + ! --> specific correction of 3 points near the 2 pivots (to be clean, usually masked -> so useless) + IF( c_NFtype == 'F' .AND. iig == 1 ) THEN + ij1 = jpj - khls ! j-index in the receiving array + ij2 = 1 ! only 1 line in the buffer + DO ji = mi0(khls), mi1(khls) ! change because of EW periodicity as we also change jpiglo-khls + iib = nfd_jisnd(mi0( khls),iig) ! i-index in the buffer + iin = nfd_rksnd(mi0( khls),iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) + END DO + DO ji = mi0(jpiglo/2+1), mi1(jpiglo/2+1) + iib = nfd_jisnd(mi0( jpiglo/2+1),iig) ! i-index in the buffer + iin = nfd_rksnd(mi0( jpiglo/2+1),iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) + END DO + DO ji = mi0(jpiglo-khls), mi1(jpiglo-khls) + iib = nfd_jisnd(mi0(jpiglo-khls),iig) ! i-index in the buffer + iin = nfd_rksnd(mi0(jpiglo-khls),iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) + END DO + ENDIF + ! + ! Apply the North pole folding. + DO jj = 1, ipjfld(jf) ! for all lines to be exchanged for this field + ij1 = ijrcv(jj,jf) ! j-index in the receiving array + ij2 = ijbuf(jj,jf) ! j-index in the buffer + iis = ii1st(jj,jf) ! stating i-index in the receiving array + iie = iiend(jj,jf) ! ending i-index in the receiving array + DO ji = iis, iie + iib = nfd_jisnd(ji,iig) ! i-index in the buffer + iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin) + END DO + END DO + ! + ! re-apply periodocity when we modified the eastern side of the inner domain (and not the full line) + IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot + IF( iig <= 2 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'T','W','U': update west halo + ELSE ; iis = 1 ; iie = 0 ! 'V','F' : full line already exchanged + ENDIF + ENDIF + IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot + IF( iig <= 2 ) THEN ; iis = 1 ; iie = 0 ! 'T','W','U': nothing to do + ELSEIF( iig == 3 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'V' : update west halo + ELSEIF( khls > 1 ) THEN ; iis = mi0(1) ; iie = mi1(khls-1) ! 'F' and khls > 1 + ELSE ; iis = 1 ; iie = 0 ! 'F' and khls == 1 : nothing to do + ENDIF + ENDIF + jj = ipjfld(jf) ! only for the last line of this field + ij1 = ijrcv(jj,jf) ! j-index in the receiving array + ij2 = ijbuf(jj,jf) ! j-index in the buffer + DO ji = iis, iie + iib = nfd_jisnd(ji,iig) ! i-index in the buffer + iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer + IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE + ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin) + END DO + ! + END DO ; END DO ! ipl ; ipk + ! + END DO ! ipf + + ! + DEALLOCATE( zbufr, ireq_r, ijsnd, ijbuf, ijrcv, ii1st, iiend, ipjfld ) + ! + CALL mpi_waitall(nfd_nbnei, ireq_s, MPI_STATUSES_IGNORE, ierr) ! wait for all Isend + ! + DEALLOCATE( zbufs, ireq_s ) + ! + ELSE !== allgather exchanges ==! + ! + ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...) + ipj = khls + 2 + ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...) + ipj2 = 2 * khls + 2 + ! + i0max = jpimax - 2 * khls + ibuffsize = i0max * ipj * ipk * ipl * ipf + ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) + ! + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab + DO jj = 1, ipj + ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines + DO ji = 1, Ni_0 + ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0 + znorthloc(ji,jj,jk,jl,jf) = ptab(jf)%pt4d(ii2,ij2,jk,jl) + END DO + DO ji = Ni_0+1, i0max + znorthloc(ji,jj,jk,jl,jf) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it) + END DO + END DO + END DO ; END DO ; END DO + ! + ! start waiting time measurement + IF( ln_timing ) CALL tic_tac(.TRUE.) +#if ! defined key_mpi_off + CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr ) +#endif + ! stop waiting time measurement + IF( ln_timing ) CALL tic_tac(.FALSE.) + DEALLOCATE( znorthloc ) + ALLOCATE( ztabglo(ipf) ) + DO jf = 1, ipf + ALLOCATE( ztabglo(jf)%pt4d(jpiglo,ipj2,ipk,ipl) ) + END DO + ! + ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last khls lines + ijnr = 0 + DO jr = 1, jpni ! recover the global north array + iproc = nfproc(jr) + impp = nfimpp(jr) + ipi = nfjpi( jr) - 2 * khls ! corresponds to Ni_0 but for subdomain iproc + IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) + ! + SELECT CASE ( kfillmode ) + CASE ( jpfillnothing ) ! no filling + CALL ctl_stop( 'STOP', 'mpp_nfd_generic : cannot use jpfillnothing with ln_nnogather = F') + CASE ( jpfillcopy ) ! filling with inner domain values + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipj + ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines + DO ji = 1, ipi + ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc + ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point + END DO + END DO + END DO ; END DO ; END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipj + DO ji = 1, ipi + ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc + ztabglo(jf)%pt4d(ii1,jj,jk,jl) = pfillval + END DO + END DO + END DO ; END DO ; END DO + END SELECT + ! + ELSE + ijnr = ijnr + 1 + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk + DO jj = 1, ipj + DO ji = 1, ipi + ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc + ztabglo(jf)%pt4d(ii1,jj,jk,jl) = znorthglo(ji,jj,jk,jl,jf,ijnr) + END DO + END DO + END DO ; END DO ; END DO + ENDIF + ! + END DO ! jpni + DEALLOCATE( znorthglo ) + ! + DO jf = 1, ipf + CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), khls, 1 ) ! North fold boundary condition + DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity + DO jj = 1, khls + 1 + ij1 = ipj2 - (khls + 1) + jj ! need only the last khls + 1 lines until ipj2 + ztabglo(jf)%pt4d( 1: khls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*khls+1:jpiglo-khls,ij1,jk,jl) + ztabglo(jf)%pt4d(jpiglo-khls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d( khls+1: 2*khls,ij1,jk,jl) + END DO + END DO ; END DO + END DO + ! + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN + DO jj = 1, khls + 1 + ij1 = jpj - (khls + 1) + jj ! last khls + 1 lines until jpj + ij2 = ipj2 - (khls + 1) + jj ! last khls + 1 lines until ipj2 + DO ji= 1, jpi + ii2 = mig(ji) + ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl) + END DO + END DO + END DO ; END DO ; END DO + ! + DO jf = 1, ipf + DEALLOCATE( ztabglo(jf)%pt4d ) + END DO + DEALLOCATE( ztabglo ) + ! + ENDIF ! ln_nnogather + ! + END SUBROUTINE mpp_nfd_/**/PRECISION \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mppini.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mppini.F90 new file mode 100644 index 0000000..4e619ab --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LBC/mppini.F90 @@ -0,0 +1,1453 @@ +MODULE mppini + !!====================================================================== + !! *** MODULE mppini *** + !! Ocean initialization : distributed memory computing initialization + !!====================================================================== + !! History : 6.0 ! 1994-11 (M. Guyon) Original code + !! OPA 7.0 ! 1995-04 (J. Escobar, M. Imbard) + !! 8.0 ! 1998-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions + !! NEMO 1.0 ! 2004-01 (G. Madec, J.M Molines) F90 : free form , north fold jpni > 1 + !! 3.4 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) add init_nfdcom + !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) init_nfdcom: setup avoiding MPI communication + !! 4.0 ! 2016-06 (G. Madec) use domain configuration file instead of bathymetry file + !! 4.0 ! 2017-06 (J.M. Molines, T. Lovato) merge of mppini and mppini_2 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! mpp_init : Lay out the global domain over processors with/without land processor elimination + !! init_ioipsl: IOIPSL initialization in mpp + !! init_nfdcom: Setup for north fold exchanges with explicit point-to-point messaging + !! init_doloop: set the starting/ending indices of DO-loop used in do_loop_substitute + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE bdy_oce ! open BounDarY + ! + USE lbcnfd ! Setup of north fold exchanges + USE lib_mpp ! distribued memory computing library + USE iom ! nemo I/O library + USE ioipsl ! I/O IPSL library + USE in_out_manager ! I/O Manager + + IMPLICIT NONE + PRIVATE + + PUBLIC mpp_init ! called by nemogcm.F90 + PUBLIC mpp_getnum ! called by prtctl + PUBLIC mpp_basesplit ! called by prtctl + PUBLIC mpp_is_ocean ! called by prtctl + + INTEGER :: numbot = -1 ! 'bottom_level' local logical unit + INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: mppini.F90 15302 2021-09-29 15:00:15Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +#if defined key_mpi_off + !!---------------------------------------------------------------------- + !! Default option : shared memory computing + !!---------------------------------------------------------------------- + + SUBROUTINE mpp_init + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_init *** + !! + !! ** Purpose : Lay out the global domain over processors. + !! + !! ** Method : Shared memory computing, set the local processor + !! variables to the value of the global domain + !!---------------------------------------------------------------------- + ! + nn_comm = 1 + nn_hls = 1 + jpiglo = Ni0glo + 2 * nn_hls + jpjglo = Nj0glo + 2 * nn_hls + jpimax = jpiglo + jpjmax = jpjglo + jpi = jpiglo + jpj = jpjglo + jpk = MAX( 2, jpkglo ) + jpij = jpi*jpj + jpni = 1 + jpnj = 1 + jpnij = jpni*jpnj + nimpp = 1 + njmpp = 1 + nidom = FLIO_DOM_NONE + ! + mpiSnei(:,:) = -1 + mpiRnei(:,:) = -1 + l_SelfPerio(1:2) = l_Iperio ! west, east periodicity by itself + l_SelfPerio(3:4) = l_Jperio ! south, north periodicity by itself + l_SelfPerio(5:8) = l_Iperio .AND. l_Jperio ! corners bi-periodicity by itself + l_IdoNFold = l_NFold ! is this process doing North fold? + ! + CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls) + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'mpp_init : NO massively parallel processing' + WRITE(numout,*) '~~~~~~~~ ' + WRITE(numout,*) ' l_Iperio = ', l_Iperio, ' l_Jperio = ', l_Jperio + WRITE(numout,*) ' njmpp = ', njmpp + ENDIF + ! +#if defined key_agrif + call agrif_nemo_init() +#endif + END SUBROUTINE mpp_init + +#else + !!---------------------------------------------------------------------- + !! MPI massively parallel processing + !!---------------------------------------------------------------------- + + + SUBROUTINE mpp_init + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_init *** + !! + !! ** Purpose : Lay out the global domain over processors. + !! If land processors are to be eliminated, this program requires the + !! presence of the domain configuration file. Land processors elimination + !! is performed if jpni x jpnj /= jpnij. In this case, using the MPP_PREP + !! preprocessing tool, help for defining the best cutting out. + !! + !! ** Method : Global domain is distributed in smaller local domains. + !! Periodic condition is a function of the local domain position + !! (global boundary or neighbouring domain) and of the global periodic + !! + !! ** Action : - set domain parameters + !! nimpp : longitudinal index + !! njmpp : latitudinal index + !! narea : number for local area + !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jn, jp, jh + INTEGER :: ii, ij, ii2, ij2 + INTEGER :: inijmin ! number of oce subdomains + INTEGER :: inum, inum0 + INTEGER :: ifreq, il1, imil, il2, ijm1 + INTEGER :: ierr, ios + INTEGER :: inbi, inbj, iimax, ijmax, icnt1, icnt2 + INTEGER, DIMENSION(16*n_hlsmax) :: ichanged + INTEGER, ALLOCATABLE, DIMENSION(: ) :: iin, ijn + INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: iimppt, ijpi, ipproc + INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: ijmppt, ijpj + INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: impi + INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: inei + LOGICAL :: llbest, llauto + LOGICAL :: llwrtlay + LOGICAL :: llmpi_Iperio, llmpi_Jperio, llmpiNFold + LOGICAL :: ln_listonly + LOGICAL, ALLOCATABLE, DIMENSION(:,: ) :: llisOce ! is not land-domain only? + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: llnei ! are neighbourgs existing? + NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & + & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & + & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, & + & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & + & cn_ice, nn_ice_dta, & + & ln_vol, nn_volctl, nn_rimwidth + NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly, nn_comm + !!---------------------------------------------------------------------- + ! + llwrtlay = lwm .OR. sn_cfctl%l_layout + ! + ! 0. read namelists parameters + ! ----------------------------------- + ! + READ ( numnam_ref, nammpp, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist' ) + READ ( numnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' ) + ! + nn_hls = MAX(1, nn_hls) ! nn_hls must be > 0 + IF(lwp) THEN + WRITE(numout,*) ' Namelist nammpp' + IF( jpni < 1 .OR. jpnj < 1 ) THEN + WRITE(numout,*) ' jpni and jpnj will be calculated automatically' + ELSE + WRITE(numout,*) ' processor grid extent in i jpni = ', jpni + WRITE(numout,*) ' processor grid extent in j jpnj = ', jpnj + ENDIF + WRITE(numout,*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather + WRITE(numout,*) ' halo width (applies to both rows and columns) nn_hls = ', nn_hls + ENDIF + ! + IF(lwm) WRITE( numond, nammpp ) + ! + jpiglo = Ni0glo + 2 * nn_hls + jpjglo = Nj0glo + 2 * nn_hls + ! + ! do we need to take into account bdy_msk? + READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)' ) + READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)' ) + ! + IF( ln_read_cfg ) CALL iom_open( cn_domcfg, numbot ) + IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy ) + ! + IF( ln_listonly ) CALL bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core + ! + ! 1. Dimension arrays for subdomains + ! ----------------------------------- + ! + ! If dimensions of MPI processes grid weren't specified in the namelist file + ! then we calculate them here now that we have our communicator size + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'mpp_init:' + WRITE(numout,*) '~~~~~~~~ ' + ENDIF + IF( jpni < 1 .OR. jpnj < 1 ) THEN + CALL bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes + llauto = .TRUE. + llbest = .TRUE. + ELSE + llauto = .FALSE. + CALL bestpartition( mppsize, inbi, inbj, icnt2 ) ! best mpi decomposition for mppsize mpi processes + ! largest subdomain size for mpi decoposition jpni*jpnj given in the namelist + CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax ) + ! largest subdomain size for mpi decoposition inbi*inbj given by bestpartition + CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, inbi, inbj, iimax, ijmax ) + icnt1 = jpni*jpnj - mppsize ! number of land subdomains that should be removed to use mppsize mpi processes + IF(lwp) THEN + WRITE(numout,9000) ' The chosen domain decomposition ', jpni, ' x ', jpnj, ' with ', icnt1, ' land subdomains' + WRITE(numout,9002) ' - uses a total of ', mppsize,' mpi process' + WRITE(numout,9000) ' - has mpi subdomains with a maximum size of (jpi = ', jpimax, ', jpj = ', jpjmax, & + & ', jpi*jpj = ', jpimax*jpjmax, ')' + WRITE(numout,9000) ' The best domain decompostion ', inbi, ' x ', inbj, ' with ', icnt2, ' land subdomains' + WRITE(numout,9002) ' - uses a total of ', inbi*inbj-icnt2,' mpi process' + WRITE(numout,9000) ' - has mpi subdomains with a maximum size of (jpi = ', iimax, ', jpj = ', ijmax, & + & ', jpi*jpj = ', iimax* ijmax, ')' + ENDIF + IF( iimax*ijmax < jpimax*jpjmax ) THEN ! chosen subdomain size is larger that the best subdomain size + llbest = .FALSE. + IF ( inbi*inbj-icnt2 < mppsize ) THEN + WRITE(ctmp1,*) ' ==> You could therefore have smaller mpi subdomains with less mpi processes' + ELSE + WRITE(ctmp1,*) ' ==> You could therefore have smaller mpi subdomains with the same number of mpi processes' + ENDIF + CALL ctl_warn( ' ', ctmp1, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' ) + ELSE IF ( iimax*ijmax == jpimax*jpjmax .AND. (inbi*inbj-icnt2) < mppsize) THEN + llbest = .FALSE. + WRITE(ctmp1,*) ' ==> You could therefore have the same mpi subdomains size with less mpi processes' + CALL ctl_warn( ' ', ctmp1, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' ) + ELSE + llbest = .TRUE. + ENDIF + ENDIF + + ! look for land mpi subdomains... + ALLOCATE( llisOce(jpni,jpnj) ) + CALL mpp_is_ocean( llisOce ) + inijmin = COUNT( llisOce ) ! number of oce subdomains + + IF( mppsize < inijmin ) THEN ! too many oce subdomains: can happen only if jpni and jpnj are prescribed... + WRITE(ctmp1,9001) ' With this specified domain decomposition: jpni = ', jpni, ' jpnj = ', jpnj + WRITE(ctmp2,9002) ' we can eliminate only ', jpni*jpnj - inijmin, ' land mpi subdomains therefore ' + WRITE(ctmp3,9001) ' the number of ocean mpi subdomains (', inijmin,') exceed the number of MPI processes:', mppsize + WRITE(ctmp4,*) ' ==>>> There is the list of best domain decompositions you should use: ' + CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' ) + CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core + ENDIF + + IF( mppsize > jpni*jpnj ) THEN ! not enough mpi subdomains for the total number of mpi processes + IF(lwp) THEN + WRITE(numout,9003) ' The number of mpi processes: ', mppsize + WRITE(numout,9003) ' exceeds the maximum number of subdomains (ocean+land) = ', jpni*jpnj + WRITE(numout,9001) ' defined by the following domain decomposition: jpni = ', jpni, ' jpnj = ', jpnj + WRITE(numout, *) ' You should: ' + IF( llauto ) THEN + WRITE(numout,*) ' - either prescribe your domain decomposition with the namelist variables' + WRITE(numout,*) ' jpni and jpnj to match the number of mpi process you want to use, ' + WRITE(numout,*) ' even IF it not the best choice...' + WRITE(numout,*) ' - or keep the automatic and optimal domain decomposition by picking up one' + WRITE(numout,*) ' of the number of mpi process proposed in the list bellow' + ELSE + WRITE(numout,*) ' - either properly prescribe your domain decomposition with jpni and jpnj' + WRITE(numout,*) ' in order to be consistent with the number of mpi process you want to use' + WRITE(numout,*) ' even IF it not the best choice...' + WRITE(numout,*) ' - or use the automatic and optimal domain decomposition and pick up one of' + WRITE(numout,*) ' the domain decomposition proposed in the list bellow' + ENDIF + WRITE(numout,*) + ENDIF + CALL bestpartition( mppsize, ldlist = .TRUE. ) ! must be done by all core + ENDIF + + jpnij = mppsize ! force jpnij definition <-- remove as much land subdomains as needed to reach this condition + IF( mppsize > inijmin ) THEN + WRITE(ctmp1,9003) ' The number of mpi processes: ', mppsize + WRITE(ctmp2,9003) ' exceeds the maximum number of ocean subdomains = ', inijmin + WRITE(ctmp3,9002) ' we suppressed ', jpni*jpnj - mppsize, ' land subdomains ' + WRITE(ctmp4,9002) ' BUT we had to keep ', mppsize - inijmin, ' land subdomains that are useless...' + CALL ctl_warn( ctmp1, ctmp2, ctmp3, ctmp4, ' ', ' --- YOU ARE WASTING CPU... ---', ' ' ) + ELSE ! mppsize = inijmin + IF(lwp) THEN + IF(llbest) WRITE(numout,*) ' ==> you use the best mpi decomposition' + WRITE(numout,*) + WRITE(numout,9003) ' Number of mpi processes: ', mppsize + WRITE(numout,9003) ' Number of ocean subdomains = ', inijmin + WRITE(numout,9003) ' Number of suppressed land subdomains = ', jpni*jpnj - inijmin + WRITE(numout,*) + ENDIF + ENDIF +9000 FORMAT (a, i4, a, i4, a, i7, a) +9001 FORMAT (a, i4, a, i4) +9002 FORMAT (a, i4, a) +9003 FORMAT (a, i5) + + ALLOCATE( nfimpp(jpni), nfproc(jpni), nfjpi(jpni), & + & iin(jpnij), ijn(jpnij), & + & iimppt(jpni,jpnj), ijmppt(jpni,jpnj), ijpi(jpni,jpnj), ijpj(jpni,jpnj), ipproc(jpni,jpnj), & + & inei(8,jpni,jpnj), llnei(8,jpni,jpnj), & + & impi(8,jpnij), & + & STAT=ierr ) + CALL mpp_sum( 'mppini', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_init: unable to allocate standard ocean arrays' ) + +#if defined key_agrif + CALL agrif_nemo_init() +#endif + ! + ! 2. Index arrays for subdomains + ! ----------------------------------- + ! + CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) + CALL mpp_getnum( llisOce, ipproc, iin, ijn ) + ! + ii = iin(narea) + ij = ijn(narea) + jpi = ijpi(ii,ij) + jpj = ijpj(ii,ij) + jpk = MAX( 2, jpkglo ) + jpij = jpi*jpj + nimpp = iimppt(ii,ij) + njmpp = ijmppt(ii,ij) + ! + CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) + CALL init_locglo ! define now functions needed to convert indices from/to global to/from local domains + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'MPI Message Passing MPI - domain lay out over processors' + WRITE(numout,*) + WRITE(numout,*) ' defines mpp subdomains' + WRITE(numout,*) ' jpni = ', jpni + WRITE(numout,*) ' jpnj = ', jpnj + WRITE(numout,*) ' jpnij = ', jpnij + WRITE(numout,*) ' nimpp = ', nimpp + WRITE(numout,*) ' njmpp = ', njmpp + WRITE(numout,*) + WRITE(numout,*) ' sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo + WRITE(numout,*) ' sum ijpj(1,j) = ', SUM(ijpj(1,:)), ' jpjglo = ', jpjglo + + ! Subdomain grid print + ifreq = 4 + il1 = 1 + DO jn = 1, (jpni-1)/ifreq+1 + il2 = MIN(jpni,il1+ifreq-1) + WRITE(numout,*) + WRITE(numout,9400) ('***',ji=il1,il2-1) + DO jj = jpnj, 1, -1 + WRITE(numout,9403) (' ',ji=il1,il2-1) + WRITE(numout,9402) jj, (ijpi(ji,jj),ijpj(ji,jj),ji=il1,il2) + WRITE(numout,9404) (ipproc(ji,jj),ji=il1,il2) + WRITE(numout,9403) (' ',ji=il1,il2-1) + WRITE(numout,9400) ('***',ji=il1,il2-1) + END DO + WRITE(numout,9401) (ji,ji=il1,il2) + il1 = il1+ifreq + END DO + 9400 FORMAT(' ***' ,20('*************',a3) ) + 9403 FORMAT(' * ',20(' * ',a3) ) + 9401 FORMAT(' ' ,20(' ',i3,' ') ) + 9402 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * ') ) + 9404 FORMAT(' * ' ,20(' ' ,i4,' * ') ) + ENDIF + ! + ! Store informations for the north pole folding communications + nfproc(:) = ipproc(:,jpnj) + nfimpp(:) = iimppt(:,jpnj) + nfjpi (:) = ijpi(:,jpnj) + ! + ! 3. Define Western, Eastern, Southern and Northern neighbors + corners in the subdomain grid reference + ! ------------------------------------------------------------------------------------------------------ + ! + ! note that North fold is has specific treatment for its MPI communications. + ! This must not be treated as a "usual" communication with a northern neighbor. + ! -> North fold processes have no Northern neighbor in the definition done bellow + ! + llmpi_Iperio = jpni > 1 .AND. l_Iperio ! do i-periodicity with an MPI communication? + llmpi_Jperio = jpnj > 1 .AND. l_Jperio ! do j-periodicity with an MPI communication? + ! + l_SelfPerio(1:2) = l_Iperio .AND. jpni == 1 ! west, east periodicity by itself + l_SelfPerio(3:4) = l_Jperio .AND. jpnj == 1 ! south, north periodicity by itself + l_SelfPerio(5:8) = l_SelfPerio(jpwe) .AND. l_SelfPerio(jpso) ! corners bi-periodicity by itself + ! + ! define neighbors mapping (1/2): default definition: ignore if neighbours are land-only subdomains or not + DO jj = 1, jpnj + DO ji = 1, jpni + ! + IF ( llisOce(ji,jj) ) THEN ! this subdomain has some ocean: it has neighbours + ! + inum0 = ji - 1 + ( jj - 1 ) * jpni ! index in the subdomains grid. start at 0 + ! + ! Is there a neighbor? + llnei(jpwe,ji,jj) = ji > 1 .OR. llmpi_Iperio ! West nei exists if not the first column or llmpi_Iperio + llnei(jpea,ji,jj) = ji < jpni .OR. llmpi_Iperio ! East nei exists if not the last column or llmpi_Iperio + llnei(jpso,ji,jj) = jj > 1 .OR. llmpi_Jperio ! South nei exists if not the first line or llmpi_Jperio + llnei(jpno,ji,jj) = jj < jpnj .OR. llmpi_Jperio ! North nei exists if not the last line or llmpi_Jperio + llnei(jpsw,ji,jj) = llnei(jpwe,ji,jj) .AND. llnei(jpso,ji,jj) ! So-We nei exists if both South and West nei exist + llnei(jpse,ji,jj) = llnei(jpea,ji,jj) .AND. llnei(jpso,ji,jj) ! So-Ea nei exists if both South and East nei exist + llnei(jpnw,ji,jj) = llnei(jpwe,ji,jj) .AND. llnei(jpno,ji,jj) ! No-We nei exists if both North and West nei exist + llnei(jpne,ji,jj) = llnei(jpea,ji,jj) .AND. llnei(jpno,ji,jj) ! No-Ea nei exists if both North and East nei exist + ! + ! Which index (starting at 0) have neighbors in the subdomains grid? + IF( llnei(jpwe,ji,jj) ) inei(jpwe,ji,jj) = inum0 - 1 + jpni * COUNT( (/ ji == 1 /) ) + IF( llnei(jpea,ji,jj) ) inei(jpea,ji,jj) = inum0 + 1 - jpni * COUNT( (/ ji == jpni /) ) + IF( llnei(jpso,ji,jj) ) inei(jpso,ji,jj) = inum0 - jpni + jpni * jpnj * COUNT( (/ jj == 1 /) ) + IF( llnei(jpno,ji,jj) ) inei(jpno,ji,jj) = inum0 + jpni - jpni * jpnj * COUNT( (/ jj == jpnj /) ) + IF( llnei(jpsw,ji,jj) ) inei(jpsw,ji,jj) = inei(jpso,ji,jj) - 1 + jpni * COUNT( (/ ji == 1 /) ) + IF( llnei(jpse,ji,jj) ) inei(jpse,ji,jj) = inei(jpso,ji,jj) + 1 - jpni * COUNT( (/ ji == jpni /) ) + IF( llnei(jpnw,ji,jj) ) inei(jpnw,ji,jj) = inei(jpno,ji,jj) - 1 + jpni * COUNT( (/ ji == 1 /) ) + IF( llnei(jpne,ji,jj) ) inei(jpne,ji,jj) = inei(jpno,ji,jj) + 1 - jpni * COUNT( (/ ji == jpni /) ) + ! + ELSE ! land-only domain has no neighbour + llnei(:,ji,jj) = .FALSE. + ENDIF + ! + END DO + END DO + ! + ! define neighbors mapping (2/2): check if neighbours are not land-only subdomains + DO jj = 1, jpnj + DO ji = 1, jpni + DO jn = 1, 8 + IF( llnei(jn,ji,jj) ) THEN ! if a neighbour is existing -> this should not be a land-only domain + ii = 1 + MOD( inei(jn,ji,jj) , jpni ) + ij = 1 + inei(jn,ji,jj) / jpni + llnei(jn,ji,jj) = llisOce( ii, ij ) + ENDIF + END DO + END DO + END DO + ! + ! update index of the neighbours in the subdomains grid + WHERE( .NOT. llnei ) inei = -1 + ! + ! Save processor layout in ascii file + IF (llwrtlay) THEN + CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) + WRITE(inum,'(a)') ' jpnij jpimax jpjmax jpk jpiglo jpjglo ( local: narea jpi jpj )' + WRITE(inum,'(6i7,a,3i7,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,' ( local: ',narea,jpi,jpj,' )' + WRITE(inum,*) + WRITE(inum, *) '------------------------------------' + WRITE(inum,'(a,i2)') ' Mapping of the default neighnourgs ' + WRITE(inum, *) '------------------------------------' + WRITE(inum,*) + WRITE(inum,'(a)') ' rank ii ij jpi jpj nimpp njmpp mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' + DO jp = 1, jpnij + ii = iin(jp) + ij = ijn(jp) + WRITE(inum,'(15i6)') jp-1, ii, ij, ijpi(ii,ij), ijpj(ii,ij), iimppt(ii,ij), ijmppt(ii,ij), inei(:,ii,ij) + END DO + ENDIF + + ! + ! 4. Define Western, Eastern, Southern and Northern neighbors + corners for each mpi process + ! ------------------------------------------------------------------------------------------ + ! + ! rewrite information from "subdomain grid" to mpi process list + ! Warning, for example: + ! position of the northern neighbor in the "subdomain grid" + ! position of the northern neighbor in the "mpi process list" + + ! default definition: no neighbors + impi(:,:) = -1 ! (starting at 0, -1 if no neighbourg) + + DO jp = 1, jpnij + ii = iin(jp) + ij = ijn(jp) + DO jn = 1, 8 + IF( llnei(jn,ii,ij) ) THEN ! must be tested as some land-domain can be kept to fit mppsize + ii2 = 1 + MOD( inei(jn,ii,ij) , jpni ) + ij2 = 1 + inei(jn,ii,ij) / jpni + impi(jn,jp) = ipproc( ii2, ij2 ) + ENDIF + END DO + END DO + + ! + ! 4. keep information for the local process + ! ----------------------------------------- + ! + ! set default neighbours + mpinei(:) = impi(:,narea) + DO jh = 1, n_hlsmax + mpiSnei(jh,:) = impi(:,narea) ! default definition + mpiRnei(jh,:) = impi(:,narea) + END DO + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' resulting internal parameters : ' + WRITE(numout,*) ' narea = ', narea + WRITE(numout,*) ' mpi nei west = ', mpinei(jpwe) , ' mpi nei east = ', mpinei(jpea) + WRITE(numout,*) ' mpi nei south = ', mpinei(jpso) , ' mpi nei north = ', mpinei(jpno) + WRITE(numout,*) ' mpi nei so-we = ', mpinei(jpsw) , ' mpi nei so-ea = ', mpinei(jpse) + WRITE(numout,*) ' mpi nei no-we = ', mpinei(jpnw) , ' mpi nei no-ea = ', mpinei(jpne) + ENDIF + ! + CALL mpp_ini_nc(nn_hls) ! Initialize communicator for neighbourhood collective communications + DO jh = 1, n_hlsmax + mpi_nc_com4(jh) = mpi_nc_com4(nn_hls) ! default definition + mpi_nc_com8(jh) = mpi_nc_com8(nn_hls) + END DO + ! ! Exclude exchanges which contain only land points + ! + IF( jpnij > 1 ) CALL init_excl_landpt + ! + ! ! Prepare mpp north fold + ! + llmpiNFold = jpni > 1 .AND. l_NFold ! is the North fold done with an MPI communication? + l_IdoNFold = ijn(narea) == jpnj .AND. l_NFold ! is this process doing North fold? + ! + IF( llmpiNFold ) CALL init_nfdcom( llwrtlay, inum ) ! init northfold communication, must be done after init_excl_landpt + ! + ! ! Save processor layout changes in ascii file + ! + DO jh = 1, n_hlsmax ! different halo size + DO ji = 1, 8 + ichanged(16*(jh-1) +ji) = COUNT( mpinei(ji:ji) /= mpiSnei(jh,ji:ji) ) + ichanged(16*(jh-1)+8+ji) = COUNT( mpinei(ji:ji) /= mpiRnei(jh,ji:ji) ) + END DO + END DO + CALL mpp_sum( "mpp_init", ichanged ) ! must be called by all processes + IF (llwrtlay) THEN + WRITE(inum,*) + WRITE(inum, *) '----------------------------------------------------------------------' + WRITE(inum,'(a,i2)') ' Mapping of the neighnourgs once excluding comm with only land points ' + WRITE(inum, *) '----------------------------------------------------------------------' + DO jh = 1, n_hlsmax ! different halo size + WRITE(inum,*) + WRITE(inum,'(a,i2)') 'halo size: ', jh + WRITE(inum, *) '---------' + WRITE(inum,'(a)') ' rank ii ij mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' + WRITE(inum, '(11i6,a)') narea-1, iin(narea), ijn(narea), mpinei(:), ' <- Org' + WRITE(inum,'(18x,8i6,a,i1,a)') mpiSnei(jh,:), ' <- Send ', COUNT( mpinei(:) /= mpiSnei(jh,:) ), ' modif' + WRITE(inum,'(18x,8i6,a,i1,a)') mpiRnei(jh,:), ' <- Recv ', COUNT( mpinei(:) /= mpiRnei(jh,:) ), ' modif' + WRITE(inum,*) ' total changes among all mpi tasks:' + WRITE(inum,*) ' mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' + WRITE(inum,'(a,8i6)') ' Send: ', ichanged(jh*16-15:jh*16-8) + WRITE(inum,'(a,8i6)') ' Recv: ', ichanged(jh*16 -7:jh*16 ) + END DO + ENDIF + ! + CALL init_ioipsl ! Prepare NetCDF output file (if necessary) + ! + IF (llwrtlay) CLOSE(inum) + ! + DEALLOCATE(iin, ijn, iimppt, ijmppt, ijpi, ijpj, ipproc, inei, llnei, impi, llisOce) + ! + END SUBROUTINE mpp_init + +#endif + + SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_basesplit *** + !! + !! ** Purpose : Lay out the global domain over processors. + !! + !! ** Method : Global domain is distributed in smaller local domains. + !! + !! ** Action : - set for all knbi*knbj domains: + !! kimppt : longitudinal index + !! kjmppt : latitudinal index + !! klci : first dimension + !! klcj : second dimension + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kiglo, kjglo + INTEGER, INTENT(in ) :: khls + INTEGER, INTENT(in ) :: knbi, knbj + INTEGER, INTENT( out) :: kimax, kjmax + INTEGER, DIMENSION(knbi,knbj), OPTIONAL, INTENT( out) :: kimppt, kjmppt + INTEGER, DIMENSION(knbi,knbj), OPTIONAL, INTENT( out) :: klci, klcj + ! + INTEGER :: ji, jj + INTEGER :: i2hls + INTEGER :: iresti, irestj, irm, ijpjmin + !!---------------------------------------------------------------------- + i2hls = 2*khls + ! +#if defined key_nemocice_decomp + kimax = ( nx_global+2-i2hls + (knbi-1) ) / knbi + i2hls ! first dim. + kjmax = ( ny_global+2-i2hls + (knbj-1) ) / knbj + i2hls ! second dim. +#else + kimax = ( kiglo - i2hls + (knbi-1) ) / knbi + i2hls ! first dim. + kjmax = ( kjglo - i2hls + (knbj-1) ) / knbj + i2hls ! second dim. +#endif + IF( .NOT. PRESENT(kimppt) ) RETURN + ! + ! 1. Dimension arrays for subdomains + ! ----------------------------------- + ! Computation of local domain sizes klci() klcj() + ! These dimensions depend on global sizes knbi,knbj and kiglo,kjglo + ! The subdomains are squares lesser than or equal to the global + ! dimensions divided by the number of processors minus the overlap array. + ! + iresti = 1 + MOD( kiglo - i2hls - 1 , knbi ) + irestj = 1 + MOD( kjglo - i2hls - 1 , knbj ) + ! + ! Need to use kimax and kjmax here since jpi and jpj not yet defined +#if defined key_nemocice_decomp + ! Change padding to be consistent with CICE + klci(1:knbi-1,: ) = kimax + klci( knbi ,: ) = kiglo - (knbi - 1) * (kimax - i2hls) + klcj(: ,1:knbj-1) = kjmax + klcj(: , knbj ) = kjglo - (knbj - 1) * (kjmax - i2hls) +#else + klci(1:iresti ,:) = kimax + klci(iresti+1:knbi ,:) = kimax-1 + IF( MINVAL(klci) < 3*khls ) THEN + WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpi must be >= ', 3*khls + WRITE(ctmp2,*) ' We have ', MINVAL(klci) + CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) + ENDIF + IF( l_NFold ) THEN + ! minimize the size of the last row to compensate for the north pole folding coast + IF( c_NFtype == 'T' ) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos + IF( c_NFtype == 'F' ) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos + irm = knbj - irestj ! total number of lines to be removed + klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row + irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove + irestj = knbj - 1 - irm + klcj(:, irestj+1:knbj-1) = kjmax-1 + ELSE + klcj(:, irestj+1:knbj ) = kjmax-1 + ENDIF + klcj(:,1:irestj) = kjmax + IF( MINVAL(klcj) < 3*khls ) THEN + WRITE(ctmp1,*) ' mpp_basesplit: minimum value of jpj must be >= ', 3*khls + WRITE(ctmp2,*) ' We have ', MINVAL(klcj) + CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) + ENDIF +#endif + + ! 2. Index arrays for subdomains + ! ------------------------------- + kimppt(:,:) = 1 + kjmppt(:,:) = 1 + ! + IF( knbi > 1 ) THEN + DO jj = 1, knbj + DO ji = 2, knbi + kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i2hls + END DO + END DO + ENDIF + ! + IF( knbj > 1 )THEN + DO jj = 2, knbj + DO ji = 1, knbi + kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i2hls + END DO + END DO + ENDIF + + END SUBROUTINE mpp_basesplit + + + SUBROUTINE bestpartition( knbij, knbi, knbj, knbcnt, ldlist ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bestpartition *** + !! + !! ** Purpose : + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: knbij ! total number of subdomains (knbi*knbj) + INTEGER, OPTIONAL, INTENT( out) :: knbi, knbj ! number if subdomains along i and j (knbi and knbj) + INTEGER, OPTIONAL, INTENT( out) :: knbcnt ! number of land subdomains + LOGICAL, OPTIONAL, INTENT(in ) :: ldlist ! .true.: print the list the best domain decompositions (with land) + ! + INTEGER :: ji, jj, ii, iitarget + INTEGER :: iszitst, iszjtst + INTEGER :: isziref, iszjref + INTEGER :: iszimin, iszjmin + INTEGER :: inbij, iszij + INTEGER :: inbimax, inbjmax, inbijmax, inbijold + INTEGER :: isz0, isz1 + INTEGER, DIMENSION( :), ALLOCATABLE :: indexok + INTEGER, DIMENSION( :), ALLOCATABLE :: inbi0, inbj0, inbij0 ! number of subdomains along i,j + INTEGER, DIMENSION( :), ALLOCATABLE :: iszi0, iszj0, iszij0 ! max size of the subdomains along i,j + INTEGER, DIMENSION( :), ALLOCATABLE :: inbi1, inbj1, inbij1 ! number of subdomains along i,j + INTEGER, DIMENSION( :), ALLOCATABLE :: iszi1, iszj1, iszij1 ! max size of the subdomains along i,j + LOGICAL :: llist + LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llmsk2d ! max size of the subdomains along i,j + LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisOce ! - - + REAL(wp):: zpropland + !!---------------------------------------------------------------------- + ! + llist = .FALSE. + IF( PRESENT(ldlist) ) llist = ldlist + + CALL mpp_init_landprop( zpropland ) ! get the proportion of land point over the gloal domain + inbij = NINT( REAL(knbij, wp) / ( 1.0 - zpropland ) ) ! define the largest possible value for jpni*jpnj + ! + IF( llist ) THEN ; inbijmax = inbij*2 + ELSE ; inbijmax = inbij + ENDIF + ! + ALLOCATE(inbi0(inbijmax),inbj0(inbijmax),iszi0(inbijmax),iszj0(inbijmax)) + ! + inbimax = 0 + inbjmax = 0 + isziref = jpiglo*jpjglo+1 ! define a value that is larger than the largest possible + iszjref = jpiglo*jpjglo+1 + ! + ! WARNING, see also init_excl_landpt: minimum subdomain size defined here according to nn_hls (and not n_hlsmax) + ! --> If, one day, we want to use local halos largers than nn_hls, we must replace nn_hls by n_hlsmax + ! + iszimin = 3*nn_hls ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain + iszjmin = 3*nn_hls + IF( c_NFtype == 'T' ) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos + IF( c_NFtype == 'F' ) iszjmin = MAX(iszjmin, 1+3*nn_hls) ! V and F folding must be outside of southern halos + ! + ! get the list of knbi that gives a smaller jpimax than knbi-1 + ! get the list of knbj that gives a smaller jpjmax than knbj-1 + DO ji = 1, inbijmax +#if defined key_nemocice_decomp + iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. +#else + iszitst = ( Ni0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain i-size +#endif + IF( iszitst < isziref .AND. iszitst >= iszimin ) THEN + isziref = iszitst + inbimax = inbimax + 1 + inbi0(inbimax) = ji + iszi0(inbimax) = isziref + ENDIF +#if defined key_nemocice_decomp + iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. +#else + iszjtst = ( Nj0glo + (ji-1) ) / ji + 2*nn_hls ! max subdomain j-size +#endif + IF( iszjtst < iszjref .AND. iszjtst >= iszjmin ) THEN + iszjref = iszjtst + inbjmax = inbjmax + 1 + inbj0(inbjmax) = ji + iszj0(inbjmax) = iszjref + ENDIF + END DO + IF( inbimax == 0 ) THEN + WRITE(ctmp1,'(a,i2,a,i2)') ' mpp_ini bestpartition: Ni0glo (', Ni0glo, ') is too small to be used with nn_hls = ', nn_hls + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + IF( inbjmax == 0 ) THEN + WRITE(ctmp1,'(a,i2,a,i2)') ' mpp_ini bestpartition: Nj0glo (', Nj0glo, ') is too small to be used with nn_hls = ', nn_hls + CALL ctl_stop( 'STOP', ctmp1 ) + ENDIF + + ! combine these 2 lists to get all possible knbi*knbj < inbijmax + ALLOCATE( llmsk2d(inbimax,inbjmax) ) + DO jj = 1, inbjmax + DO ji = 1, inbimax + IF ( inbi0(ji) * inbj0(jj) <= inbijmax ) THEN ; llmsk2d(ji,jj) = .TRUE. + ELSE ; llmsk2d(ji,jj) = .FALSE. + ENDIF + END DO + END DO + isz1 = COUNT(llmsk2d) + ALLOCATE( inbi1(isz1), inbj1(isz1), iszi1(isz1), iszj1(isz1) ) + ii = 0 + DO jj = 1, inbjmax + DO ji = 1, inbimax + IF( llmsk2d(ji,jj) .EQV. .TRUE. ) THEN + ii = ii + 1 + inbi1(ii) = inbi0(ji) + inbj1(ii) = inbj0(jj) + iszi1(ii) = iszi0(ji) + iszj1(ii) = iszj0(jj) + ENDIF + END DO + END DO + DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) + DEALLOCATE( llmsk2d ) + + ALLOCATE( inbij1(isz1), iszij1(isz1) ) + inbij1(:) = inbi1(:) * inbj1(:) + iszij1(:) = iszi1(:) * iszj1(:) + + ! if there is no land and no print + IF( .NOT. llist .AND. numbot == -1 .AND. numbdy == -1 ) THEN + ! get the smaller partition which gives the smallest subdomain size + ii = MINLOC(inbij1, mask = iszij1 == MINVAL(iszij1), dim = 1) + knbi = inbi1(ii) + knbj = inbj1(ii) + IF(PRESENT(knbcnt)) knbcnt = 0 + DEALLOCATE( inbi1, inbj1, inbij1, iszi1, iszj1, iszij1 ) + RETURN + ENDIF + + ! extract only the partitions which reduce the subdomain size in comparison with smaller partitions + ALLOCATE( indexok(isz1) ) ! to store indices of the best partitions + isz0 = 0 ! number of best partitions + inbij = 1 ! start with the min value of inbij1 => 1 + iszij = jpiglo*jpjglo+1 ! default: larger than global domain + DO WHILE( inbij <= inbijmax ) ! if we did not reach the max of inbij1 + ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1) ! warning: send back the first occurence if multiple results + IF ( iszij1(ii) < iszij ) THEN + ii = MINLOC( iszi1+iszj1, mask = iszij1 == iszij1(ii) .AND. inbij1 == inbij, dim = 1) ! select the smaller perimeter if multiple min + isz0 = isz0 + 1 + indexok(isz0) = ii + iszij = iszij1(ii) + ENDIF + inbij = MINVAL(inbij1, mask = inbij1 > inbij) ! warning: return largest integer value if mask = .false. everywhere + END DO + DEALLOCATE( inbij1, iszij1 ) + + ! keep only the best partitions (sorted by increasing order of subdomains number and decreassing subdomain size) + ALLOCATE( inbi0(isz0), inbj0(isz0), iszi0(isz0), iszj0(isz0) ) + DO ji = 1, isz0 + ii = indexok(ji) + inbi0(ji) = inbi1(ii) + inbj0(ji) = inbj1(ii) + iszi0(ji) = iszi1(ii) + iszj0(ji) = iszj1(ii) + END DO + DEALLOCATE( indexok, inbi1, inbj1, iszi1, iszj1 ) + + IF( llist ) THEN + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' For your information:' + WRITE(numout,*) ' list of the best partitions including land supression' + WRITE(numout,*) ' -----------------------------------------------------' + WRITE(numout,*) + ENDIF + ji = isz0 ! initialization with the largest value + ALLOCATE( llisOce(inbi0(ji), inbj0(ji)) ) + CALL mpp_is_ocean( llisOce ) ! Warning: must be call by all cores (call mpp_sum) + inbijold = COUNT(llisOce) + DEALLOCATE( llisOce ) + DO ji =isz0-1,1,-1 + ALLOCATE( llisOce(inbi0(ji), inbj0(ji)) ) + CALL mpp_is_ocean( llisOce ) ! Warning: must be call by all cores (call mpp_sum) + inbij = COUNT(llisOce) + DEALLOCATE( llisOce ) + IF(lwp .AND. inbij < inbijold) THEN + WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)') & + & 'nb_cores oce: ', inbij, ', land domains excluded: ', inbi0(ji)*inbj0(ji) - inbij, & + & ' (', REAL(inbi0(ji)*inbj0(ji) - inbij,wp) / REAL(inbi0(ji)*inbj0(ji),wp) *100., & + & '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' + inbijold = inbij + ENDIF + END DO + DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' -----------------------------------------------------------' + ENDIF + CALL mppsync + CALL mppstop( ld_abort = .TRUE. ) + ENDIF + + DEALLOCATE( iszi0, iszj0 ) + inbij = inbijmax + 1 ! default: larger than possible + ii = isz0+1 ! start from the end of the list (smaller subdomains) + DO WHILE( inbij > knbij ) ! while the number of ocean subdomains exceed the number of procs + ii = ii -1 + ALLOCATE( llisOce(inbi0(ii), inbj0(ii)) ) + CALL mpp_is_ocean( llisOce ) ! must be done by all core + inbij = COUNT(llisOce) + DEALLOCATE( llisOce ) + END DO + knbi = inbi0(ii) + knbj = inbj0(ii) + IF(PRESENT(knbcnt)) knbcnt = knbi * knbj - inbij + DEALLOCATE( inbi0, inbj0 ) + ! + END SUBROUTINE bestpartition + + + SUBROUTINE mpp_init_landprop( propland ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_init_landprop *** + !! + !! ** Purpose : the the proportion of land points in the surface land-sea mask + !! + !! ** Method : read iproc strips (of length Ni0glo) of the land-sea mask + !!---------------------------------------------------------------------- + REAL(wp), INTENT( out) :: propland ! proportion of land points in the global domain (between 0 and 1) + ! + INTEGER, DIMENSION(jpni*jpnj) :: kusedom_1d + INTEGER :: inboce, iarea + INTEGER :: iproc, idiv, ijsz + INTEGER :: ijstr + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce + !!---------------------------------------------------------------------- + ! do nothing if there is no land-sea mask + IF( numbot == -1 .and. numbdy == -1 ) THEN + propland = 0. + RETURN + ENDIF + + ! number of processes reading the bathymetry file + iproc = MINVAL( (/mppsize, Nj0glo/2, 100/) ) ! read a least 2 lines, no more that 100 processes reading at the same time + + ! we want to read iproc strips of the land-sea mask. -> pick up iproc processes every idiv processes starting at 1 + IF( iproc == 1 ) THEN ; idiv = mppsize + ELSE ; idiv = ( mppsize - 1 ) / ( iproc - 1 ) + ENDIF + + iarea = (narea-1)/idiv ! involed process number (starting counting at 0) + IF( MOD( narea-1, idiv ) == 0 .AND. iarea < iproc ) THEN ! beware idiv can be = to 1 + ! + ijsz = Nj0glo / iproc ! width of the stripe to read + IF( iarea < MOD(Nj0glo,iproc) ) ijsz = ijsz + 1 + ijstr = iarea*(Nj0glo/iproc) + MIN(iarea, MOD(Nj0glo,iproc)) + 1 ! starting j position of the reading + ! + ALLOCATE( lloce(Ni0glo, ijsz) ) ! allocate the strip + CALL read_mask( 1, ijstr, Ni0glo, ijsz, lloce ) + inboce = COUNT(lloce) ! number of ocean point in the stripe + DEALLOCATE(lloce) + ! + ELSE + inboce = 0 + ENDIF + CALL mpp_sum( 'mppini', inboce ) ! total number of ocean points over the global domain + ! + propland = REAL( Ni0glo*Nj0glo - inboce, wp ) / REAL( Ni0glo*Nj0glo, wp ) + ! + END SUBROUTINE mpp_init_landprop + + + SUBROUTINE mpp_is_ocean( ldIsOce ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_is_ocean *** + !! + !! ** Purpose : Check for a mpi domain decomposition inbi x inbj which + !! subdomains, including 1 halo (even if nn_hls>1), contain + !! at least 1 ocean point. + !! We must indeed ensure that each subdomain that is a neighbour + !! of a land subdomain, has only land points on its boundary + !! (inside the inner subdomain) with the land subdomain. + !! This is needed to get the proper bondary conditions on + !! a subdomain with a closed boundary. + !! + !! ** Method : read inbj strips (of length Ni0glo) of the land-sea mask + !!---------------------------------------------------------------------- + LOGICAL, DIMENSION(:,:), INTENT( out) :: ldIsOce ! .true. if a sub domain constains 1 ocean point + ! + INTEGER :: idiv, iimax, ijmax, iarea + INTEGER :: inbi, inbj, inx, iny, inry, isty + INTEGER :: ji, jj, jn + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: inboce ! number oce oce pint in each mpi subdomain + INTEGER, ALLOCATABLE, DIMENSION(: ) :: inboce_1d + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean + !!---------------------------------------------------------------------- + ! do nothing if there is no land-sea mask + IF( numbot == -1 .AND. numbdy == -1 ) THEN + ldIsOce(:,:) = .TRUE. + RETURN + ENDIF + ! + inbi = SIZE( ldIsOce, dim = 1 ) + inbj = SIZE( ldIsOce, dim = 2 ) + ! + ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 + IF ( inbj == 1 ) THEN ; idiv = mppsize + ELSE IF ( mppsize < inbj ) THEN ; idiv = 1 + ELSE ; idiv = ( mppsize - 1 ) / ( inbj - 1 ) + ENDIF + ! + ALLOCATE( inboce(inbi,inbj), inboce_1d(inbi*inbj) ) + inboce(:,:) = 0 ! default no ocean point found + ! + DO jn = 0, (inbj-1)/mppsize ! if mppsize < inbj : more strips than mpi processes (because of potential land domains) + ! + iarea = (narea-1)/idiv + jn * mppsize + 1 ! involed process number (starting counting at 1) + IF( MOD( narea-1, idiv ) == 0 .AND. iarea <= inbj ) THEN ! beware idiv can be = to 1 + ! + ALLOCATE( iimppt(inbi,inbj), ijmppt(inbi,inbj), ijpi(inbi,inbj), ijpj(inbi,inbj) ) + CALL mpp_basesplit( Ni0glo, Nj0glo, 0, inbi, inbj, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj ) + ! + inx = Ni0glo + 2 ; iny = ijpj(1,iarea) + 2 ! strip size + 1 halo on each direction (even if nn_hls>1) + ALLOCATE( lloce(inx, iny) ) ! allocate the strip + inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) ) ! number of point to read in y-direction + isty = 1 + COUNT( (/ iarea == 1 /) ) ! read from the first or the second line? + CALL read_mask( 1, ijmppt(1,iarea) - 2 + isty, Ni0glo, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip + ! + IF( iarea == 1 ) THEN ! the first line was not read + IF( l_Jperio ) THEN ! north-south periodocity + CALL read_mask( 1, Nj0glo, Ni0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce + ELSE + lloce(2:inx-1, 1) = .FALSE. ! closed boundary + ENDIF + ENDIF + IF( iarea == inbj ) THEN ! the last line was not read + IF( l_Jperio ) THEN ! north-south periodocity + CALL read_mask( 1, 1, Ni0glo, 1, lloce(2:inx-1,iny) ) ! read the first line -> last line of lloce + ELSEIF( c_NFtype == 'T' ) THEN ! north-pole folding T-pivot, T-point + lloce(2,iny) = lloce(2,iny-2) ! here we have 1 halo (even if nn_hls>1) + DO ji = 3,inx-1 + lloce(ji,iny ) = lloce(inx-ji+2,iny-2) ! ok, we have at least 3 lines + END DO + DO ji = inx/2+2,inx-1 + lloce(ji,iny-1) = lloce(inx-ji+2,iny-1) + END DO + ELSEIF( c_NFtype == 'F' ) THEN ! north-pole folding F-pivot, T-point, 1 halo + lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1) ! here we have 1 halo (even if nn_hls>1) + lloce(inx -1,iny-1) = lloce(2 ,iny-1) + DO ji = 2,inx-1 + lloce(ji,iny) = lloce(inx-ji+1,iny-1) + END DO + ELSE ! closed boundary + lloce(2:inx-1,iny) = .FALSE. + ENDIF + ENDIF + ! ! first and last column were not read + IF( l_Iperio ) THEN + lloce(1,:) = lloce(inx-1,:) ; lloce(inx,:) = lloce(2,:) ! east-west periodocity + ELSE + lloce(1,:) = .FALSE. ; lloce(inx,:) = .FALSE. ! closed boundary + ENDIF + ! + DO ji = 1, inbi + inboce(ji,iarea) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ijpi(ji,1)+1,:) ) ! lloce as 2 points more than Ni0glo + END DO + ! + DEALLOCATE(lloce) + DEALLOCATE(iimppt, ijmppt, ijpi, ijpj) + ! + ENDIF + END DO + + inboce_1d = RESHAPE(inboce, (/ inbi*inbj /)) + CALL mpp_sum( 'mppini', inboce_1d ) + inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) + ldIsOce(:,:) = inboce(:,:) /= 0 + DEALLOCATE(inboce, inboce_1d) + ! +#if defined key_xios + ! Only when using XIOS: XIOS does a domain decomposition only in bands (for IO performances). + ! XIOS is crashing if one of these bands contains only land-domains which have been suppressed. + ! -> solution (before a fix of xios): force to keep at least one land-domain by band of mpi domains + DO jj = 1, inbj + IF( COUNT( ldIsOce(:,jj) ) == 0 ) ldIsOce(1,jj) = .TRUE. ! for to keep 1st MPI domain in the row of domains + END DO +#endif + ! + END SUBROUTINE mpp_is_ocean + + + SUBROUTINE read_mask( kistr, kjstr, kicnt, kjcnt, ldoce ) + !!---------------------------------------------------------------------- + !! *** ROUTINE read_mask *** + !! + !! ** Purpose : Read relevant bathymetric information in order to + !! provide a land/sea mask used for the elimination + !! of land domains, in an mpp computation. + !! + !! ** Method : read stipe of size (Ni0glo,...) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kistr, kjstr ! starting i and j position of the reading + INTEGER , INTENT(in ) :: kicnt, kjcnt ! number of points to read in i and j directions + LOGICAL, DIMENSION(kicnt,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean + ! + INTEGER :: inumsave ! local logical unit + REAL(wp), DIMENSION(kicnt,kjcnt) :: zbot, zbdy + !!---------------------------------------------------------------------- + ! + inumsave = numout ; numout = numnul ! redirect all print to /dev/null + ! + IF( numbot /= -1 ) THEN + CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/kistr,kjstr/), kcount = (/kicnt, kjcnt/) ) + ELSE + zbot(:,:) = 1._wp ! put a non-null value + ENDIF + ! + IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists + CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/kistr,kjstr/), kcount = (/kicnt, kjcnt/) ) + zbot(:,:) = zbot(:,:) * zbdy(:,:) + ENDIF + ! + ldoce(:,:) = NINT(zbot(:,:)) > 0 + numout = inumsave + ! + END SUBROUTINE read_mask + + + SUBROUTINE mpp_getnum( ldIsOce, kproc, kipos, kjpos ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_getnum *** + !! + !! ** Purpose : give a number to each MPI subdomains (starting at 0) + !! + !! ** Method : start from bottom left. First skip land subdomain, and finally use them if needed + !!---------------------------------------------------------------------- + LOGICAL, DIMENSION(:,:), INTENT(in ) :: ldIsOce ! F if land process + INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if not existing, starting at 0) + INTEGER, DIMENSION( :), INTENT( out) :: kipos ! i-position of the subdomain (from 1 to jpni) + INTEGER, DIMENSION( :), INTENT( out) :: kjpos ! j-position of the subdomain (from 1 to jpnj) + ! + INTEGER :: ii, ij, jarea, iarea0 + INTEGER :: icont, i2add , ini, inj, inij + !!---------------------------------------------------------------------- + ! + ini = SIZE(ldIsOce, dim = 1) + inj = SIZE(ldIsOce, dim = 2) + inij = SIZE(kipos) + ! + ! specify which subdomains are oce subdomains; other are land subdomains + kproc(:,:) = -1 + icont = -1 + DO jarea = 1, ini*inj + iarea0 = jarea - 1 + ii = 1 + MOD(iarea0,ini) + ij = 1 + iarea0/ini + IF( ldIsOce(ii,ij) ) THEN + icont = icont + 1 + kproc(ii,ij) = icont + kipos(icont+1) = ii + kjpos(icont+1) = ij + ENDIF + END DO + ! if needed add some land subdomains to reach inij active subdomains + i2add = inij - COUNT( ldIsOce ) + DO jarea = 1, ini*inj + iarea0 = jarea - 1 + ii = 1 + MOD(iarea0,ini) + ij = 1 + iarea0/ini + IF( .NOT. ldIsOce(ii,ij) .AND. i2add > 0 ) THEN + icont = icont + 1 + kproc(ii,ij) = icont + kipos(icont+1) = ii + kjpos(icont+1) = ij + i2add = i2add - 1 + ENDIF + END DO + ! + END SUBROUTINE mpp_getnum + + + SUBROUTINE init_excl_landpt + !!---------------------------------------------------------------------- + !! *** ROUTINE *** + !! + !! ** Purpose : exclude exchanges which contain only land points + !! + !! ** Method : if a send or receive buffer constains only land point we + !! flag off the corresponding communication + !! Warning: this selection depend on the halo size -> loop on halo size + !! + !!---------------------------------------------------------------------- + INTEGER :: inumsave + INTEGER :: jh + INTEGER :: ipi, ipj + INTEGER :: iiwe, iiea, iist, iisz + INTEGER :: ijso, ijno, ijst, ijsz + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zmsk + LOGICAL , DIMENSION(Ni_0,Nj_0,1) :: lloce + !!---------------------------------------------------------------------- + ! + ! read the land-sea mask on the inner domain + CALL read_mask( nimpp, njmpp, Ni_0, Nj_0, lloce(:,:,1) ) + ! + ! Here we look only at communications excluding the NP folding. + ! --> we switch off lbcnfd at this stage (init_nfdcom called after init_excl_landpt)... + l_IdoNFold = .FALSE. + ! + ! WARNING, see also bestpartition: minimum subdomain size defined in bestpartition according to nn_hls. + ! If, one day, we want to use local halos largers than nn_hls, we must replace nn_hls by n_hlsmax in bestpartition + ! + DO jh = 1, MIN(nn_hls, n_hlsmax) ! different halo size + ! + ipi = Ni_0 + 2*jh ! local domain size + ipj = Nj_0 + 2*jh + ! + ALLOCATE( zmsk(ipi,ipj) ) + zmsk(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = REAL(COUNT(lloce, dim = 3), wp) ! define inner domain -> need REAL to use lbclnk + CALL lbc_lnk('mppini', zmsk, 'T', 1._wp, khls = jh) ! fill halos + ! Beware, coastal F points can be used in the code -> we may need communications for these points F points even if tmask = 0 + ! -> the mask we must use here is equal to 1 as soon as one of the 4 neighbours is oce (sum of the mask, not multiplication) + zmsk(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = zmsk(jh+1:jh+Ni_0,jh+1 :jh+Nj_0 ) + zmsk(jh+1+1:jh+Ni_0+1,jh+1 :jh+Nj_0 ) & + & + zmsk(jh+1:jh+Ni_0,jh+1+1:jh+Nj_0+1) + zmsk(jh+1+1:jh+Ni_0+1,jh+1+1:jh+Nj_0+1) + CALL lbc_lnk('mppini', zmsk, 'T', 1._wp, khls = jh) ! fill halos again! + ! + iiwe = jh ; iiea = Ni_0 ! bottom-left corner - 1 of the sent data + ijso = jh ; ijno = Nj_0 + IF( nn_comm == 1 ) THEN + iist = 0 ; iisz = ipi + ijst = jh ; ijsz = Nj_0 + ELSE + iist = jh ; iisz = Ni_0 + ijst = jh ; ijsz = Nj_0 + ENDIF +IF( nn_comm == 1 ) THEN ! SM: NOT WORKING FOR NEIGHBOURHOOD COLLECTIVE COMMUNICATIONS, I DON'T KNOW WHY... + ! do not send if we send only land points + IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiSnei(jh,jpwe) = -1 + IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiSnei(jh,jpea) = -1 + IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpso) = -1 + IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpno) = -1 + IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpsw) = -1 + IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpse) = -1 + IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpnw) = -1 + IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpne) = -1 + ! + iiwe = iiwe-jh ; iiea = iiea+jh ! bottom-left corner - 1 of the received data + ijso = ijso-jh ; ijno = ijno+jh + ! do not send if we send only land points + IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiRnei(jh,jpwe) = -1 + IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiRnei(jh,jpea) = -1 + IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpso) = -1 + IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpno) = -1 + IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpsw) = -1 + IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpse) = -1 + IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpnw) = -1 + IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpne) = -1 +ENDIF + ! + ! Specific (and rare) problem in corner treatment because we do 1st West-East comm, next South-North comm + IF( nn_comm == 1 ) THEN + IF( mpiSnei(jh,jpwe) > -1 ) mpiSnei(jh, (/jpsw,jpnw/) ) = -1 ! SW and NW corners already sent through West nei + IF( mpiSnei(jh,jpea) > -1 ) mpiSnei(jh, (/jpse,jpne/) ) = -1 ! SE and NE corners already sent through East nei + IF( mpiRnei(jh,jpso) > -1 ) mpiRnei(jh, (/jpsw,jpse/) ) = -1 ! SW and SE corners will be received through South nei + IF( mpiRnei(jh,jpno) > -1 ) mpiRnei(jh, (/jpnw,jpne/) ) = -1 ! NW and NE corners will be received through North nei + ENDIF + ! + DEALLOCATE( zmsk ) + ! + CALL mpp_ini_nc(jh) ! Initialize/Update communicator for neighbourhood collective communications + ! + END DO + + END SUBROUTINE init_excl_landpt + + + SUBROUTINE init_ioipsl + !!---------------------------------------------------------------------- + !! *** ROUTINE init_ioipsl *** + !! + !! ** Purpose : + !! + !! ** Method : + !! + !! History : + !! 9.0 ! 04-03 (G. Madec ) MPP-IOIPSL + !! " " ! 08-12 (A. Coward) addition in case of jpni*jpnj < jpnij + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(2) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid + !!---------------------------------------------------------------------- + + ! The domain is split only horizontally along i- or/and j- direction + ! So we need at the most only 1D arrays with 2 elements. + ! Set idompar values equivalent to the jpdom_local_noextra definition + ! used in IOM. This works even if jpnij .ne. jpni*jpnj. + iglo( :) = (/ Ni0glo, Nj0glo /) + iloc( :) = (/ Ni_0 , Nj_0 /) + iabsf(:) = (/ Nis0 , Njs0 /) + (/ nimpp, njmpp /) - 1 - nn_hls ! corresponds to mig0(Nis0) but mig0 is not yet defined! + iabsl(:) = iabsf(:) + iloc(:) - 1 + ihals(:) = (/ 0 , 0 /) + ihale(:) = (/ 0 , 0 /) + idid( :) = (/ 1 , 2 /) + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'mpp init_ioipsl : iloc = ', iloc + WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf + WRITE(numout,*) ' ihals = ', ihals + WRITE(numout,*) ' ihale = ', ihale + ENDIF + ! + CALL flio_dom_set ( jpnij, narea-1, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom) + ! + END SUBROUTINE init_ioipsl + + + SUBROUTINE init_nfdcom( ldwrtlay, knum ) + !!---------------------------------------------------------------------- + !! *** ROUTINE init_nfdcom *** + !! ** Purpose : Setup for north fold exchanges with explicit + !! point-to-point messaging + !! + !! ** Method : Initialization of the northern neighbours lists. + !!---------------------------------------------------------------------- + !! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) + !! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC) + !! 3.0 ! 2021-09 complete rewrite using informations from gather north fold + !!---------------------------------------------------------------------- + LOGICAL, INTENT(in ) :: ldwrtlay ! true if additional prints in layout.dat + INTEGER, INTENT(in ) :: knum ! layout.dat unit + ! + REAL(wp), DIMENSION(jpi,jpj,2,4) :: zinfo + INTEGER , DIMENSION(10) :: irknei ! too many elements but safe... + INTEGER :: ji, jj, jg, jn ! dummy loop indices + INTEGER :: iitmp + LOGICAL :: lnew + !!---------------------------------------------------------------------- + ! + IF (lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ==>>> North fold boundary prepared for jpni >1' + ENDIF + ! + CALL mpp_ini_northgather ! we need to init the nfd with gathering in all cases as it is used to define the no-gather case + ! + IF(ldwrtlay) THEN ! additional prints in layout.dat + WRITE(knum,*) + WRITE(knum,*) + WRITE(knum,*) 'Number of subdomains located along the north fold : ', ndim_rank_north + WRITE(knum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north + DO jn = 1, ndim_rank_north, 5 + WRITE(knum,*) nrank_north( jn:MINVAL( (/jn+4,ndim_rank_north/) ) ) + END DO + ENDIF + + nfd_nbnei = 0 ! defaul def (useless?) + IF( ln_nnogather ) THEN + ! + ! Use the "gather nfd" to know how to do the nfd: for ji point, which process send data from which of its ji-index? + ! Note that nfd is perfectly symetric: I receive data from X <=> I send data to X (-> no deadlock) + ! + zinfo(:,:,:,:) = HUGE(0._wp) ! default def to make sure we don't use the halos + DO jg = 1, 4 ! grid type: T, U, V, F + DO jj = nn_hls+1, jpj-nn_hls ! inner domain (warning do_loop_substitute not yet defined) + DO ji = nn_hls+1, jpi-nn_hls ! inner domain (warning do_loop_substitute not yet defined) + zinfo(ji,jj,1,jg) = REAL(narea, wp) ! mpi_rank + 1 (as default lbc_lnk fill is 0 + zinfo(ji,jj,2,jg) = REAL(ji, wp) ! ji of this proc + END DO + END DO + END DO + ! + ln_nnogather = .FALSE. ! force "classical" North pole folding to fill all halos -> should be no more HUGE values... + CALL lbc_lnk( 'mppini', zinfo(:,:,:,1), 'T', 1._wp ) ! Do 4 calls instead of 1 to save memory as the nogather version + CALL lbc_lnk( 'mppini', zinfo(:,:,:,2), 'U', 1._wp ) ! creates buffer arrays with jpiglo as the first dimension + CALL lbc_lnk( 'mppini', zinfo(:,:,:,3), 'V', 1._wp ) ! + CALL lbc_lnk( 'mppini', zinfo(:,:,:,4), 'F', 1._wp ) ! + ln_nnogather = .TRUE. + + IF( l_IdoNFold ) THEN ! only the procs involed in the NFD must take care of this + + ALLOCATE( nfd_rksnd(jpi,4), nfd_jisnd(jpi,4) ) ! neighbour rand and remote ji-index for each grid (T, U, V, F) + nfd_rksnd(:,:) = NINT( zinfo(:, jpj, 1, :) ) - 1 ! neighbour MPI rank + nfd_jisnd(:,:) = NINT( zinfo(:, jpj, 2, :) ) - nn_hls ! neighbour ji index (shifted as we don't send the halos) + WHERE( nfd_rksnd == -1 ) nfd_jisnd = 1 ! use ji=1 if no neighbour, see mpp_nfd_generic.h90 + + nfd_nbnei = 1 ! Number of neighbour sending data for the nfd. We have at least 1 neighbour! + irknei(1) = nfd_rksnd(1,1) ! which is the 1st one (I can be neighbour of myself, exclude land-proc are also ok) + DO jg = 1, 4 + DO ji = 1, jpi ! we must be able to fill the full line including halos + lnew = .TRUE. ! new neighbour? + DO jn = 1, nfd_nbnei + IF( irknei(jn) == nfd_rksnd(ji,jg) ) lnew = .FALSE. ! already found + END DO + IF( lnew ) THEN + jn = nfd_nbnei + 1 + nfd_nbnei = jn + irknei(jn) = nfd_rksnd(ji,jg) + ENDIF + END DO + END DO + + ALLOCATE( nfd_rknei(nfd_nbnei) ) + nfd_rknei(:) = irknei(1:nfd_nbnei) + ! re-number nfd_rksnd according to the indexes of nfd_rknei + DO jg = 1, 4 + DO ji = 1, jpi + iitmp = nfd_rksnd(ji,jg) ! must store a copy of nfd_rksnd(ji,jg) to make sure we don't change it twice + DO jn = 1, nfd_nbnei + IF( iitmp == nfd_rknei(jn) ) nfd_rksnd(ji,jg) = jn + END DO + END DO + END DO + + IF( ldwrtlay ) THEN + WRITE(knum,*) + WRITE(knum,*) 'north fold exchanges with explicit point-to-point messaging :' + WRITE(knum,*) ' number of neighbours for the NF: nfd_nbnei : ', nfd_nbnei + IF( nfd_nbnei > 0 ) WRITE(knum,*) ' neighbours MPI ranks : ', nfd_rknei + ENDIF + + ENDIF ! l_IdoNFold + ! + ENDIF ! ln_nnogather + ! + END SUBROUTINE init_nfdcom + + + SUBROUTINE init_doloop + !!---------------------------------------------------------------------- + !! *** ROUTINE init_doloop *** + !! + !! ** Purpose : set the starting/ending indices of DO-loop + !! These indices are used in do_loop_substitute.h90 + !!---------------------------------------------------------------------- + ! + Nis0 = 1+nn_hls + Njs0 = 1+nn_hls + Nie0 = jpi-nn_hls + Nje0 = jpj-nn_hls + ! + Ni_0 = Nie0 - Nis0 + 1 + Nj_0 = Nje0 - Njs0 + 1 + ! + jpkm1 = jpk-1 ! " " + ! + END SUBROUTINE init_doloop + + + SUBROUTINE init_locglo + !!---------------------------------------------------------------------- + !! *** ROUTINE init_locglo *** + !! + !! ** Purpose : initialization of global domain <--> local domain indices + !! + !! ** Method : + !! + !! ** Action : - mig , mjg : local domain indices ==> global domain, including halos, indices + !! - mig0, mjg0: local domain indices ==> global domain, excluding halos, indices + !! - mi0 , mi1 : global domain indices ==> local domain indices + !! - mj0 , mj1 (if global point not in the local domain ==> mi0>mi1 and/or mj0>mj1) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop argument + !!---------------------------------------------------------------------- + ! + ALLOCATE( mig(jpi), mjg(jpj), mig0(jpi), mjg0(jpj) ) + ALLOCATE( mi0(jpiglo), mi1(jpiglo), mj0(jpjglo), mj1(jpjglo) ) + ! + DO ji = 1, jpi ! local domain indices ==> global domain indices, including halos + mig(ji) = ji + nimpp - 1 + END DO + DO jj = 1, jpj + mjg(jj) = jj + njmpp - 1 + END DO + ! ! local domain indices ==> global domain indices, excluding halos + ! + mig0(:) = mig(:) - nn_hls + mjg0(:) = mjg(:) - nn_hls + ! ! global domain, including halos, indices ==> local domain indices + ! ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the + ! ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain. + DO ji = 1, jpiglo + mi0(ji) = MAX( 1 , MIN( ji - nimpp + 1, jpi+1 ) ) + mi1(ji) = MAX( 0 , MIN( ji - nimpp + 1, jpi ) ) + END DO + DO jj = 1, jpjglo + mj0(jj) = MAX( 1 , MIN( jj - njmpp + 1, jpj+1 ) ) + mj1(jj) = MAX( 0 , MIN( jj - njmpp + 1, jpj ) ) + END DO + ! + END SUBROUTINE init_locglo + + !!====================================================================== +END MODULE mppini \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldfc1d_c2d.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldfc1d_c2d.F90 new file mode 100644 index 0000000..4b1b439 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldfc1d_c2d.F90 @@ -0,0 +1,158 @@ +MODULE ldfc1d_c2d + !!====================================================================== + !! *** MODULE ldfc1d_c2d *** + !! Ocean physics: profile and horizontal shape of lateral eddy coefficients + !!===================================================================== + !! History : 3.7 ! 2013-12 (G. Madec) restructuration/simplification of aht/aeiv specification, + !! ! add velocity dependent coefficient and optional read in file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! ldf_c1d : ah reduced by 1/4 on the vertical (tanh profile, inflection at 300m) + !! ldf_c2d : ah = F(e1,e2) (laplacian or = F(e1^3,e2^3) (bilaplacian) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC ldf_c1d ! called by ldftra and ldfdyn modules + PUBLIC ldf_c2d ! called by ldftra and ldfdyn modules + + REAL(wp) :: r1_2 = 0.5_wp ! =1/2 + REAL(wp) :: r1_4 = 0.25_wp ! =1/4 + REAL(wp) :: r1_12 = 1._wp / 12._wp ! =1/12 + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ldfc1d_c2d.F90 15014 2021-06-17 17:02:04Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ldf_c1d( cd_type, pahs1, pahs2, pah1, pah2 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_c1d *** + !! + !! ** Purpose : 1D eddy diffusivity/viscosity coefficients + !! + !! ** Method : 1D eddy diffusivity coefficients F( depth ) + !! Reduction by zratio from surface to bottom + !! hyperbolic tangent profile with inflection point + !! at zh=500m and a width of zw=200m + !! + !! cd_type = TRA pah1, pah2 defined at U- and V-points + !! DYN pah1, pah2 defined at T- and F-points + !!---------------------------------------------------------------------- + CHARACTER(len=3) , INTENT(in ) :: cd_type ! DYNamique or TRAcers + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pahs1, pahs2 ! surface value of eddy coefficient [m2/s] + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pah1 , pah2 ! eddy coefficient [m2/s] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zh, zc, zdep1 ! local scalars + REAL(wp) :: zw , zdep2 ! - - + REAL(wp) :: zratio ! - - + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ldf_c1d : set a given profile to eddy mixing coefficients' + ! + ! initialization of the profile + zratio = 0.25_wp ! surface/bottom ratio + zh = 500._wp ! depth of the inflection point [m] + zw = 1._wp / 200._wp ! width^-1 - - - [1/m] + ! ! associated coefficient [-] + zc = ( 1._wp - zratio ) / ( 1._wp + TANH( zh * zw) ) + ! + ! + SELECT CASE( cd_type ) ! point of calculation + ! + CASE( 'DYN' ) ! T- and F-points + DO jk = jpkm1, 1, -1 ! pah1 at T-point + pah1(:,:,jk) = pahs1(:,:) * ( zratio + zc * ( 1._wp + TANH( - ( gdept_0(:,:,jk) - zh ) * zw) ) ) + END DO + DO_3DS( 0, 0, 0, 0, jpkm1, 1, -1 ) ! pah2 at F-point (zdep2 is an approximation in zps-coord.) + zdep2 = ( gdept_0(ji,jj+1,jk) + gdept_0(ji+1,jj+1,jk) & + & + gdept_0(ji,jj ,jk) + gdept_0(ji+1,jj ,jk) ) * r1_4 + pah2(ji,jj,jk) = pahs2(ji,jj) * ( zratio + zc * ( 1._wp + TANH( - ( zdep2 - zh ) * zw) ) ) + END_3D + CALL lbc_lnk( 'ldfc1d_c2d', pah2, 'F', 1.0_wp ) ! Lateral boundary conditions + ! + CASE( 'TRA' ) ! U- and V-points (zdep1 & 2 are an approximation in zps-coord.) + DO_3DS( 0, 0, 0, 0, jpkm1, 1, -1 ) + zdep1 = ( gdept_0(ji,jj,jk) + gdept_0(ji+1,jj,jk) ) * 0.5_wp + zdep2 = ( gdept_0(ji,jj,jk) + gdept_0(ji,jj+1,jk) ) * 0.5_wp + pah1(ji,jj,jk) = pahs1(ji,jj) * ( zratio + zc * ( 1._wp + TANH( - ( zdep1 - zh ) * zw) ) ) + pah2(ji,jj,jk) = pahs2(ji,jj) * ( zratio + zc * ( 1._wp + TANH( - ( zdep2 - zh ) * zw) ) ) + END_3D + ! Lateral boundary conditions + CALL lbc_lnk( 'ldfc1d_c2d', pah1, 'U', 1.0_wp , pah2, 'V', 1.0_wp ) + ! + CASE DEFAULT ! error + CALL ctl_stop( 'ldf_c1d: ', cd_type, ' Unknown, i.e. /= DYN or TRA' ) + END SELECT + ! + END SUBROUTINE ldf_c1d + + + SUBROUTINE ldf_c2d( cd_type, pUfac, knn, pah1, pah2 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_c2d *** + !! + !! ** Purpose : 2D eddy diffusivity/viscosity coefficients + !! + !! ** Method : 2D eddy diffusivity coefficients F( e1 , e2 ) + !! laplacian operator : ah proportional to the scale factor [m2/s] + !! bilaplacian operator : ah proportional to the (scale factor)^3 [m4/s] + !! In both cases, pah0 is the maximum value reached by the coefficient + !! at the Equator in case of e1=ra*rad= ~111km, not over the whole domain. + !! + !! cd_type = TRA pah1, pah2 defined at U- and V-points + !! DYN pah1, pah2 defined at T- and F-points + !!---------------------------------------------------------------------- + CHARACTER(len=3) , INTENT(in ) :: cd_type ! DYNamique or TRAcers + REAL(wp) , INTENT(in ) :: pUfac ! =1/2*Uc LAPlacian BiLaPlacian + INTEGER , INTENT(in ) :: knn ! characteristic velocity [m/s] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pah1, pah2 ! eddy coefficients [m2/s or m4/s] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: inn ! local integer + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ldf_c2d : aht = Ufac * max(e1,e2) with Ufac = ', pUfac, ' m/s' + ! + ! + SELECT CASE( cd_type ) !== surface values ==! (chosen grid point function of DYN or TRA) + ! + CASE( 'DYN' ) ! T- and F-points + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + pah1(ji,jj,1) = pUfac * MAX( e1t(ji,jj) , e2t(ji,jj) )**knn + pah2(ji,jj,1) = pUfac * MAX( e1f(ji,jj) , e2f(ji,jj) )**knn + END_2D + CASE( 'TRA' ) ! U- and V-points + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + pah1(ji,jj,1) = pUfac * MAX( e1u(ji,jj), e2u(ji,jj) )**knn + pah2(ji,jj,1) = pUfac * MAX( e1v(ji,jj), e2v(ji,jj) )**knn + END_2D + CASE DEFAULT ! error + CALL ctl_stop( 'ldf_c2d: ', cd_type, ' Unknown, i.e. /= DYN or TRA' ) + END SELECT + ! !== deeper values = surface one ==! (except jpk) + DO jk = 2, jpkm1 + pah1(:,:,jk) = pah1(:,:,1) + pah2(:,:,jk) = pah2(:,:,1) + END DO + ! + END SUBROUTINE ldf_c2d + + !!====================================================================== +END MODULE ldfc1d_c2d \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldfdyn.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldfdyn.F90 new file mode 100644 index 0000000..b21c731 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldfdyn.F90 @@ -0,0 +1,503 @@ +MODULE ldfdyn + !!====================================================================== + !! *** MODULE ldfdyn *** + !! Ocean physics: lateral viscosity coefficient + !!===================================================================== + !! History : OPA ! 1997-07 (G. Madec) multi dimensional coefficients + !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module + !! 3.7 ! 2014-01 (F. Lemarie, G. Madec) restructuration/simplification of ahm specification, + !! ! add velocity dependent coefficient and optional read in file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! ldf_dyn_init : initialization, namelist read, and parameters control + !! ldf_dyn : update lateral eddy viscosity coefficients at each time step + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE ldfslp ! lateral diffusion: slopes of mixing orientation + USE ldfc1d_c2d ! lateral diffusion: 1D and 2D cases + ! + USE in_out_manager ! I/O manager + USE iom ! I/O module for ehanced bottom friction file + USE timing ! Timing + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC ldf_dyn_init ! called by nemogcm.F90 + PUBLIC ldf_dyn ! called by step.F90 + + ! !!* Namelist namdyn_ldf : lateral mixing on momentum * + LOGICAL , PUBLIC :: ln_dynldf_OFF !: No operator (i.e. no explicit diffusion) + INTEGER , PUBLIC :: nn_dynldf_typ !: operator type (0: div-rot ; 1: symmetric) + LOGICAL , PUBLIC :: ln_dynldf_lap !: laplacian operator + LOGICAL , PUBLIC :: ln_dynldf_blp !: bilaplacian operator + LOGICAL , PUBLIC :: ln_dynldf_lev !: iso-level direction + LOGICAL , PUBLIC :: ln_dynldf_hor !: horizontal (geopotential) direction +! LOGICAL , PUBLIC :: ln_dynldf_iso !: iso-neutral direction (see ldfslp) + INTEGER , PUBLIC :: nn_ahm_ijk_t !: choice of time & space variations of the lateral eddy viscosity coef. + ! ! time invariant coefficients: aht = 1/2 Ud*Ld (lap case) + ! ! bht = 1/12 Ud*Ld^3 (blp case) + REAL(wp), PUBLIC :: rn_Uv !: lateral viscous velocity [m/s] + REAL(wp), PUBLIC :: rn_Lv !: lateral viscous length [m] + ! ! Smagorinsky viscosity (nn_ahm_ijk_t = 32) + REAL(wp), PUBLIC :: rn_csmc !: Smagorinsky constant of proportionality + REAL(wp), PUBLIC :: rn_minfac !: Multiplicative factor of theorectical minimum Smagorinsky viscosity + REAL(wp), PUBLIC :: rn_maxfac !: Multiplicative factor of theorectical maximum Smagorinsky viscosity + ! ! iso-neutral laplacian (ln_dynldf_lap=ln_dynldf_iso=T) + REAL(wp), PUBLIC :: rn_ahm_b !: lateral laplacian background eddy viscosity [m2/s] + + ! !!* Parameter to control the type of lateral viscous operator + INTEGER, PARAMETER, PUBLIC :: np_ERROR =-10 !: error in setting the operator + INTEGER, PARAMETER, PUBLIC :: np_no_ldf = 00 !: without operator (i.e. no lateral viscous trend) + ! + INTEGER, PARAMETER, PUBLIC :: np_typ_rot = 0 !: div-rot operator + INTEGER, PARAMETER, PUBLIC :: np_typ_sym = 1 !: symmetric operator + ! + ! !! laplacian ! bilaplacian ! + INTEGER, PARAMETER, PUBLIC :: np_lap = 10 , np_blp = 20 !: iso-level operator + INTEGER, PARAMETER, PUBLIC :: np_lap_i = 11 !: iso-neutral or geopotential operator + ! + INTEGER , PUBLIC :: nldf_dyn !: type of lateral diffusion used defined from ln_dynldf_... (namlist logicals) + LOGICAL , PUBLIC :: l_ldfdyn_time !: flag for time variation of the lateral eddy viscosity coef. + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahmt, ahmf !: eddy viscosity coef. at T- and F-points [m2/s or m4/s] + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dtensq !: horizontal tension squared (Smagorinsky only) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dshesq !: horizontal shearing strain squared (Smagorinsky only) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: esqt, esqf !: Square of the local gridscale (e1e2/(e1+e2))**2 + + REAL(wp) :: r1_2 = 0.5_wp ! =1/2 + REAL(wp) :: r1_4 = 0.25_wp ! =1/4 + REAL(wp) :: r1_8 = 0.125_wp ! =1/8 + REAL(wp) :: r1_12 = 1._wp / 12._wp ! =1/12 + REAL(wp) :: r1_288 = 1._wp / 288._wp ! =1/( 12^2 * 2 ) + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ldfdyn.F90 15014 2021-06-17 17:02:04Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ldf_dyn_init + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_dyn_init *** + !! + !! ** Purpose : set the horizontal ocean dynamics physics + !! + !! ** Method : the eddy viscosity coef. specification depends on: + !! - the operator: + !! ln_dynldf_lap = T laplacian operator + !! ln_dynldf_blp = T bilaplacian operator + !! - the parameter nn_ahm_ijk_t: + !! nn_ahm_ijk_t = 0 => = constant + !! = 10 => = F(z) : = constant with a reduction of 1/4 with depth + !! =-20 => = F(i,j) = shape read in 'eddy_viscosity_2D.nc' file + !! = 20 = F(i,j) = F(e1,e2) or F(e1^3,e2^3) (lap or bilap case) + !! =-30 => = F(i,j,k) = shape read in 'eddy_viscosity_3D.nc' file + !! = 30 = F(i,j,k) = 2D (case 20) + decrease with depth (case 10) + !! = 31 = F(i,j,k,t) = F(local velocity) ( |u|e /12 laplacian operator + !! or |u|e^3/12 bilaplacian operator ) + !! = 32 = F(i,j,k,t) = F(local deformation rate and gridscale) (D and L) (Smagorinsky) + !! ( L^2|D| laplacian operator + !! or L^4|D|/8 bilaplacian operator ) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ioptio, ierr, inum, ios, inn ! local integer + REAL(wp) :: zah0, zah_max, zUfac ! local scalar + CHARACTER(len=5) :: cl_Units ! units (m2/s or m4/s) + !! + NAMELIST/namdyn_ldf/ ln_dynldf_OFF, nn_dynldf_typ, ln_dynldf_lap, ln_dynldf_blp, & ! type of operator + & ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso, & ! acting direction of the operator + & nn_ahm_ijk_t , rn_Uv , rn_Lv , rn_ahm_b, & ! lateral eddy coefficient + & rn_csmc , rn_minfac , rn_maxfac ! Smagorinsky settings + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namdyn_ldf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in reference namelist' ) + + READ ( numnam_cfg, namdyn_ldf, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in configuration namelist' ) + IF(lwm) WRITE ( numond, namdyn_ldf ) + + IF(lwp) THEN ! Parameter print + WRITE(numout,*) + WRITE(numout,*) 'ldf_dyn : lateral momentum physics' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) ' Namelist namdyn_ldf : set lateral mixing parameters' + ! + WRITE(numout,*) ' type :' + WRITE(numout,*) ' no explicit diffusion ln_dynldf_OFF = ', ln_dynldf_OFF + WRITE(numout,*) ' type of operator (div-rot or sym) nn_dynldf_typ = ', nn_dynldf_typ + WRITE(numout,*) ' laplacian operator ln_dynldf_lap = ', ln_dynldf_lap + WRITE(numout,*) ' bilaplacian operator ln_dynldf_blp = ', ln_dynldf_blp + ! + WRITE(numout,*) ' direction of action :' + WRITE(numout,*) ' iso-level ln_dynldf_lev = ', ln_dynldf_lev + WRITE(numout,*) ' horizontal (geopotential) ln_dynldf_hor = ', ln_dynldf_hor + WRITE(numout,*) ' iso-neutral ln_dynldf_iso = ', ln_dynldf_iso + ! + WRITE(numout,*) ' coefficients :' + WRITE(numout,*) ' type of time-space variation nn_ahm_ijk_t = ', nn_ahm_ijk_t + WRITE(numout,*) ' lateral viscous velocity (if cst) rn_Uv = ', rn_Uv, ' m/s' + WRITE(numout,*) ' lateral viscous length (if cst) rn_Lv = ', rn_Lv, ' m' + WRITE(numout,*) ' background viscosity (iso-lap case) rn_ahm_b = ', rn_ahm_b, ' m2/s' + ! + WRITE(numout,*) ' Smagorinsky settings (nn_ahm_ijk_t = 32) :' + WRITE(numout,*) ' Smagorinsky coefficient rn_csmc = ', rn_csmc + WRITE(numout,*) ' factor multiplier for eddy visc.' + WRITE(numout,*) ' lower limit (default 1.0) rn_minfac = ', rn_minfac + WRITE(numout,*) ' upper limit (default 1.0) rn_maxfac = ', rn_maxfac + ENDIF + + ! + ! !== type of lateral operator used ==! (set nldf_dyn) + ! !=====================================! + ! + nldf_dyn = np_ERROR + ioptio = 0 + IF( ln_dynldf_OFF ) THEN ; nldf_dyn = np_no_ldf ; ioptio = ioptio + 1 ; ENDIF + IF( ln_dynldf_lap ) THEN ; ioptio = ioptio + 1 ; ENDIF + IF( ln_dynldf_blp ) THEN ; ioptio = ioptio + 1 ; ENDIF + IF( ioptio /= 1 ) CALL ctl_stop( 'ldf_dyn_init: use ONE of the 3 operator options (NONE/lap/blp)' ) + ! + IF(.NOT.ln_dynldf_OFF ) THEN !== direction ==>> type of operator ==! + ! + SELECT CASE( nn_dynldf_typ ) ! div-rot or symmetric + CASE( np_typ_rot ) ; IF(lwp) WRITE(numout,*) ' ==>>> use div-rot operator ' + CASE( np_typ_sym ) ; IF(lwp) WRITE(numout,*) ' ==>>> use symmetric operator ' + CASE DEFAULT ! error + CALL ctl_stop('ldf_dyn_init: wrong value for nn_dynldf_typ (0 or 1)' ) + END SELECT + ! + ioptio = 0 + IF( ln_dynldf_lev ) ioptio = ioptio + 1 + IF( ln_dynldf_hor ) ioptio = ioptio + 1 + IF( ln_dynldf_iso ) ioptio = ioptio + 1 + IF( ioptio /= 1 ) CALL ctl_stop( 'ldf_dyn_init: use ONE of the 3 direction options (level/hor/iso)' ) + ! + ! ! Set nldf_dyn, the type of lateral diffusion, from ln_dynldf_... logicals + ierr = 0 + IF( ln_dynldf_lap ) THEN ! laplacian operator + IF( ln_zco ) THEN ! z-coordinate + IF ( ln_dynldf_lev ) nldf_dyn = np_lap ! iso-level = horizontal (no rotation) + IF ( ln_dynldf_hor ) nldf_dyn = np_lap ! iso-level = horizontal (no rotation) + IF ( ln_dynldf_iso ) nldf_dyn = np_lap_i ! iso-neutral ( rotation) + ENDIF + IF( ln_zps ) THEN ! z-coordinate with partial step + IF ( ln_dynldf_lev ) nldf_dyn = np_lap ! iso-level (no rotation) + IF ( ln_dynldf_hor ) nldf_dyn = np_lap ! iso-level (no rotation) + IF ( ln_dynldf_iso ) nldf_dyn = np_lap_i ! iso-neutral ( rotation) + ENDIF + IF( ln_sco ) THEN ! s-coordinate + IF ( ln_dynldf_lev ) nldf_dyn = np_lap ! iso-level = horizontal (no rotation) + IF ( ln_dynldf_hor ) nldf_dyn = np_lap_i ! horizontal ( rotation) + IF ( ln_dynldf_iso ) nldf_dyn = np_lap_i ! iso-neutral ( rotation) + ENDIF + ENDIF + ! + IF( ln_dynldf_blp ) THEN ! bilaplacian operator + IF( ln_zco ) THEN ! z-coordinate + IF( ln_dynldf_lev ) nldf_dyn = np_blp ! iso-level = horizontal (no rotation) + IF( ln_dynldf_hor ) nldf_dyn = np_blp ! iso-level = horizontal (no rotation) + IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation) + ENDIF + IF( ln_zps ) THEN ! z-coordinate with partial step + IF( ln_dynldf_lev ) nldf_dyn = np_blp ! iso-level (no rotation) + IF( ln_dynldf_hor ) nldf_dyn = np_blp ! iso-level (no rotation) + IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation) + ENDIF + IF( ln_sco ) THEN ! s-coordinate + IF( ln_dynldf_lev ) nldf_dyn = np_blp ! iso-level (no rotation) + IF( ln_dynldf_hor ) ierr = 2 ! horizontal ( rotation) + IF( ln_dynldf_iso ) ierr = 2 ! iso-neutral ( rotation) + ENDIF + ENDIF + ! + IF( ierr == 2 ) CALL ctl_stop( 'rotated bi-laplacian operator does not exist' ) + ! + IF( nldf_dyn == np_lap_i ) l_ldfslp = .TRUE. ! rotation require the computation of the slopes + ! + ENDIF + ! + IF(lwp) THEN + WRITE(numout,*) + SELECT CASE( nldf_dyn ) + CASE( np_no_ldf ) ; WRITE(numout,*) ' ==>>> NO lateral viscosity' + CASE( np_lap ) ; WRITE(numout,*) ' ==>>> iso-level laplacian operator' + CASE( np_lap_i ) ; WRITE(numout,*) ' ==>>> rotated laplacian operator with iso-level background' + CASE( np_blp ) ; WRITE(numout,*) ' ==>>> iso-level bi-laplacian operator' + END SELECT + WRITE(numout,*) + ENDIF + + ! + ! !== Space/time variation of eddy coefficients ==! + ! !=================================================! + ! + l_ldfdyn_time = .FALSE. ! no time variation except in case defined below + ! + IF( ln_dynldf_OFF ) THEN + IF(lwp) WRITE(numout,*) ' ==>>> No viscous operator selected. ahmt and ahmf are not allocated' + RETURN + ! + ELSE !== a lateral diffusion operator is used ==! + ! + ! ! allocate the ahm arrays + ALLOCATE( ahmt(jpi,jpj,jpk) , ahmf(jpi,jpj,jpk) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate arrays') + ! + ahmt(:,:,:) = 0._wp ! init to 0 needed + ahmf(:,:,:) = 0._wp + ! + ! ! value of lap/blp eddy mixing coef. + IF( ln_dynldf_lap ) THEN ; zUfac = r1_2 *rn_Uv ; inn = 1 ; cl_Units = ' m2/s' ! laplacian + ELSEIF( ln_dynldf_blp ) THEN ; zUfac = r1_12*rn_Uv ; inn = 3 ; cl_Units = ' m4/s' ! bilaplacian + ENDIF + zah0 = zUfac * rn_Lv**inn ! mixing coefficient + zah_max = zUfac * (ra*rad)**inn ! maximum reachable coefficient (value at the Equator) + ! + SELECT CASE( nn_ahm_ijk_t ) !* Specification of space-time variations of ahmt, ahmf + ! + CASE( 0 ) !== constant ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity. = constant = ', zah0, cl_Units + ahmt(:,:,1:jpkm1) = zah0 + ahmf(:,:,1:jpkm1) = zah0 + ! + CASE( 10 ) !== fixed profile ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( depth )' + IF(lwp) WRITE(numout,*) ' surface viscous coef. = constant = ', zah0, cl_Units + ahmt(:,:,1) = zah0 ! constant surface value + ahmf(:,:,1) = zah0 + CALL ldf_c1d( 'DYN', ahmt(:,:,1), ahmf(:,:,1), ahmt, ahmf ) + ! + CASE ( -20 ) !== fixed horizontal shape read in file ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F(i,j) read in eddy_viscosity.nc file' + CALL iom_open( 'eddy_viscosity_2D.nc', inum ) + CALL iom_get ( inum, jpdom_global, 'ahmt_2d', ahmt(:,:,1), cd_type = 'T', psgn = 1._dp ) + CALL iom_get ( inum, jpdom_global, 'ahmf_2d', ahmf(:,:,1), cd_type = 'F', psgn = 1._dp ) + CALL iom_close( inum ) + DO jk = 2, jpkm1 + ahmt(:,:,jk) = ahmt(:,:,1) + ahmf(:,:,jk) = ahmf(:,:,1) + END DO + ! + CASE( 20 ) !== fixed horizontal shape ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( e1, e2 ) or F( e1^3, e2^3 ) (lap. or blp. case)' + IF(lwp) WRITE(numout,*) ' using a fixed viscous velocity = ', rn_Uv ,' m/s and Lv = Max(e1,e2)' + IF(lwp) WRITE(numout,*) ' maximum reachable coefficient (at the Equator) = ', zah_max, cl_Units, ' for e1=1°)' + CALL ldf_c2d( 'DYN', zUfac , inn , ahmt, ahmf ) ! surface value proportional to scale factor^inn + ! + CASE( -30 ) !== fixed 3D shape read in file ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F(i,j,k) read in eddy_viscosity_3D.nc file' + CALL iom_open( 'eddy_viscosity_3D.nc', inum ) + CALL iom_get ( inum, jpdom_global, 'ahmt_3d', ahmt, cd_type = 'T', psgn = 1._dp ) + CALL iom_get ( inum, jpdom_global, 'ahmf_3d', ahmf, cd_type = 'F', psgn = 1._dp ) + CALL iom_close( inum ) + ! + CASE( 30 ) !== fixed 3D shape ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( latitude, longitude, depth )' + IF(lwp) WRITE(numout,*) ' using a fixed viscous velocity = ', rn_Uv ,' m/s and Ld = Max(e1,e2)' + IF(lwp) WRITE(numout,*) ' maximum reachable coefficient (at the Equator) = ', zah_max, cl_Units, ' for e1=1°)' + CALL ldf_c2d( 'DYN', zUfac , inn , ahmt, ahmf ) ! surface value proportional to scale factor^inn + CALL ldf_c1d( 'DYN', ahmt(:,:,1), ahmf(:,:,1), ahmt, ahmf ) ! reduction with depth + ! + CASE( 31 ) !== time varying 3D field ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( latitude, longitude, depth , time )' + IF(lwp) WRITE(numout,*) ' proportional to the local velocity : 1/2 |u|e (lap) or 1/12 |u|e^3 (blp)' + ! + l_ldfdyn_time = .TRUE. ! will be calculated by call to ldf_dyn routine in step.F90 + ! + CASE( 32 ) !== time varying 3D field ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy viscosity = F( latitude, longitude, depth , time )' + IF(lwp) WRITE(numout,*) ' proportional to the local deformation rate and gridscale (Smagorinsky)' + ! + l_ldfdyn_time = .TRUE. ! will be calculated by call to ldf_dyn routine in step.F90 + ! + ! ! allocate arrays used in ldf_dyn. + ALLOCATE( dtensq(jpi,jpj,jpk) , dshesq(jpi,jpj,jpk) , esqt(jpi,jpj) , esqf(jpi,jpj) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate Smagorinsky arrays') + ! + DO_2D( 1, 1, 1, 1 ) ! Set local gridscale values + esqt(ji,jj) = ( 2._wp * e1e2t(ji,jj) / ( e1t(ji,jj) + e2t(ji,jj) ) )**2 + esqf(ji,jj) = ( 2._wp * e1e2f(ji,jj) / ( e1f(ji,jj) + e2f(ji,jj) ) )**2 + END_2D + ! + CASE DEFAULT + CALL ctl_stop('ldf_dyn_init: wrong choice for nn_ahm_ijk_t, the type of space-time variation of ahm') + END SELECT + ! + IF( .NOT.l_ldfdyn_time ) THEN !* No time variation + IF( ln_dynldf_lap ) THEN ! laplacian operator (mask only) + ahmt(:,:,1:jpkm1) = ahmt(:,:,1:jpkm1) * tmask(:,:,1:jpkm1) + ahmf(:,:,1:jpkm1) = ahmf(:,:,1:jpkm1) * fmask(:,:,1:jpkm1) + ELSEIF( ln_dynldf_blp ) THEN ! bilaplacian operator (square root + mask) + ahmt(:,:,1:jpkm1) = SQRT( ahmt(:,:,1:jpkm1) ) * tmask(:,:,1:jpkm1) + ahmf(:,:,1:jpkm1) = SQRT( ahmf(:,:,1:jpkm1) ) * fmask(:,:,1:jpkm1) + ENDIF + ENDIF + ! + ENDIF + ! + END SUBROUTINE ldf_dyn_init + + + SUBROUTINE ldf_dyn( kt, Kbb ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_dyn *** + !! + !! ** Purpose : update at kt the momentum lateral mixing coeff. (ahmt and ahmf) + !! + !! ** Method : time varying eddy viscosity coefficients: + !! + !! nn_ahm_ijk_t = 31 ahmt, ahmf = F(i,j,k,t) = F(local velocity) + !! ( |u|e /12 or |u|e^3/12 for laplacian or bilaplacian operator ) + !! + !! nn_ahm_ijk_t = 32 ahmt, ahmf = F(i,j,k,t) = F(local deformation rate and gridscale) (D and L) (Smagorinsky) + !! ( L^2|D| or L^4|D|/8 for laplacian or bilaplacian operator ) + !! + !! ** note : in BLP cases the sqrt of the eddy coef is returned, since bilaplacian is en re-entrant laplacian + !! ** action : ahmt, ahmf updated at each time step + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step index + INTEGER, INTENT(in) :: Kbb ! ocean time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zu2pv2_ij_p1, zu2pv2_ij, zu2pv2_ij_m1, zemax ! local scalar (option 31) + REAL(wp) :: zcmsmag, zstabf_lo, zstabf_up, zdelta, zdb ! local scalar (option 32) + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('ldf_dyn') + ! + SELECT CASE( nn_ahm_ijk_t ) !== Eddy vicosity coefficients ==! + ! + CASE( 31 ) !== time varying 3D field ==! = F( local velocity ) + ! + IF( ln_dynldf_lap ) THEN ! laplacian operator : |u| e /12 = |u/144| e + DO jk = 1, jpkm1 + DO_2D( 0, 0, 0, 0 ) + zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb) + zu2pv2_ij_m1 = uu(ji-1,jj ,jk,Kbb) * uu(ji-1,jj ,jk,Kbb) + vv(ji ,jj-1,jk,Kbb) * vv(ji ,jj-1,jk,Kbb) + zu2pv2_ij_p1 = uu(ji ,jj+1,jk,Kbb) * uu(ji ,jj+1,jk,Kbb) + vv(ji+1,jj ,jk,Kbb) * vv(ji+1,jj ,jk,Kbb) + zemax = MAX( e1t(ji,jj) , e2t(ji,jj) ) + ahmt(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zemax * tmask(ji,jj,jk) ! 288= 12*12 * 2 + zemax = MAX( e1f(ji,jj) , e2f(ji,jj) ) + ahmf(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zemax * fmask(ji,jj,jk) ! 288= 12*12 * 2 + END_2D + END DO + ELSEIF( ln_dynldf_blp ) THEN ! bilaplacian operator : sqrt( |u| e^3 /12 ) = sqrt( |u/144| e ) * e + DO jk = 1, jpkm1 + DO_2D( 0, 0, 0, 0 ) + zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb) + zu2pv2_ij_m1 = uu(ji-1,jj ,jk,Kbb) * uu(ji-1,jj ,jk,Kbb) + vv(ji ,jj-1,jk,Kbb) * vv(ji ,jj-1,jk,Kbb) + zu2pv2_ij_p1 = uu(ji ,jj+1,jk,Kbb) * uu(ji ,jj+1,jk,Kbb) + vv(ji+1,jj ,jk,Kbb) * vv(ji+1,jj ,jk,Kbb) + zemax = MAX( e1t(ji,jj) , e2t(ji,jj) ) + ahmt(ji,jj,jk) = SQRT( SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zemax ) * zemax * tmask(ji,jj,jk) + zemax = MAX( e1f(ji,jj) , e2f(ji,jj) ) + ahmf(ji,jj,jk) = SQRT( SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zemax ) * zemax * fmask(ji,jj,jk) + END_2D + END DO + ENDIF + ! + CALL lbc_lnk( 'ldfdyn', ahmt, 'T', 1.0_wp, ahmf, 'F', 1.0_wp ) + ! + ! + CASE( 32 ) !== time varying 3D field ==! = F( local deformation rate and gridscale ) (Smagorinsky) + ! + IF( ln_dynldf_lap .OR. ln_dynldf_blp ) THEN ! laplacian operator : (C_smag/pi)^2 L^2 |D| + ! + zcmsmag = (rn_csmc/rpi)**2 ! (C_smag/pi)^2 + zstabf_lo = rn_minfac * rn_minfac / ( 2._wp * 12._wp * 12._wp * zcmsmag ) ! lower limit stability factor scaling + zstabf_up = rn_maxfac / ( 4._wp * zcmsmag * 2._wp * rn_Dt ) ! upper limit stability factor scaling + IF( ln_dynldf_blp ) zstabf_lo = ( 16._wp / 9._wp ) * zstabf_lo ! provide |U|L^3/12 lower limit instead + ! ! of |U|L^3/16 in blp case + DO jk = 1, jpkm1 + ! + DO_2D( 0, 0, 0, 0 ) + zdb = ( uu(ji,jj,jk,Kbb) * r1_e2u(ji,jj) - uu(ji-1,jj,jk,Kbb) * r1_e2u(ji-1,jj) ) & + & * r1_e1t(ji,jj) * e2t(ji,jj) & + & - ( vv(ji,jj,jk,Kbb) * r1_e1v(ji,jj) - vv(ji,jj-1,jk,Kbb) * r1_e1v(ji,jj-1) ) & + & * r1_e2t(ji,jj) * e1t(ji,jj) + dtensq(ji,jj,jk) = zdb * zdb * tmask(ji,jj,jk) + END_2D + ! + DO_2D( 1, 0, 1, 0 ) + zdb = ( uu(ji,jj+1,jk,Kbb) * r1_e1u(ji,jj+1) - uu(ji,jj,jk,Kbb) * r1_e1u(ji,jj) ) & + & * r1_e2f(ji,jj) * e1f(ji,jj) & + & + ( vv(ji+1,jj,jk,Kbb) * r1_e2v(ji+1,jj) - vv(ji,jj,jk,Kbb) * r1_e2v(ji,jj) ) & + & * r1_e1f(ji,jj) * e2f(ji,jj) + dshesq(ji,jj,jk) = zdb * zdb * fmask(ji,jj,jk) + END_2D + ! + END DO + ! + CALL lbc_lnk( 'ldfdyn', dtensq, 'T', 1.0_wp ) ! lbc_lnk on dshesq not needed + ! + DO jk = 1, jpkm1 + ! + DO_2D( 0, 0, 0, 0 ) ! T-point value + ! + zu2pv2_ij = uu(ji ,jj ,jk,Kbb) * uu(ji ,jj ,jk,Kbb) + vv(ji ,jj ,jk,Kbb) * vv(ji ,jj ,jk,Kbb) + zu2pv2_ij_m1 = uu(ji-1,jj ,jk,Kbb) * uu(ji-1,jj ,jk,Kbb) + vv(ji ,jj-1,jk,Kbb) * vv(ji ,jj-1,jk,Kbb) + ! + zdelta = zcmsmag * esqt(ji,jj) ! L^2 * (C_smag/pi)^2 + ahmt(ji,jj,jk) = zdelta * SQRT( dtensq(ji ,jj,jk) + & + & r1_4 * ( dshesq(ji ,jj,jk) + dshesq(ji ,jj-1,jk) + & + & dshesq(ji-1,jj,jk) + dshesq(ji-1,jj-1,jk) ) ) + ahmt(ji,jj,jk) = MAX( ahmt(ji,jj,jk), SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac * |U|L/2 + ahmt(ji,jj,jk) = MIN( ahmt(ji,jj,jk), zdelta * zstabf_up ) ! Impose upper limit == maxfac * L^2/(4*2dt) + ! + END_2D + ! + DO_2D( 1, 0, 1, 0 ) ! F-point value + ! + zu2pv2_ij_p1 = uu(ji ,jj+1,jk, kbb) * uu(ji ,jj+1,jk, kbb) + vv(ji+1,jj ,jk, kbb) * vv(ji+1,jj ,jk, kbb) + zu2pv2_ij = uu(ji ,jj ,jk, kbb) * uu(ji ,jj ,jk, kbb) + vv(ji ,jj ,jk, kbb) * vv(ji ,jj ,jk, kbb) + ! + zdelta = zcmsmag * esqf(ji,jj) ! L^2 * (C_smag/pi)^2 + ahmf(ji,jj,jk) = zdelta * SQRT( dshesq(ji ,jj,jk) + & + & r1_4 * ( dtensq(ji ,jj,jk) + dtensq(ji ,jj+1,jk) + & + & dtensq(ji+1,jj,jk) + dtensq(ji+1,jj+1,jk) ) ) + ahmf(ji,jj,jk) = MAX( ahmf(ji,jj,jk), SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac * |U|L/2 + ahmf(ji,jj,jk) = MIN( ahmf(ji,jj,jk), zdelta * zstabf_up ) ! Impose upper limit == maxfac * L^2/(4*2dt) + ! + END_2D + ! + END DO + ! + ENDIF + ! + IF( ln_dynldf_blp ) THEN ! bilaplacian operator : sqrt( (C_smag/pi)^2 L^4 |D|/8) + ! ! = sqrt( A_lap_smag L^2/8 ) + ! ! stability limits already applied to laplacian values + ! ! effective default limits are 1/12 |U|L^3 < B_hm < 1//(32*2dt) L^4 + DO jk = 1, jpkm1 + DO_2D( 0, 0, 0, 0 ) + ahmt(ji,jj,jk) = SQRT( r1_8 * esqt(ji,jj) * ahmt(ji,jj,jk) ) + ahmf(ji,jj,jk) = SQRT( r1_8 * esqf(ji,jj) * ahmf(ji,jj,jk) ) + END_2D + END DO + ! + ENDIF + ! + CALL lbc_lnk( 'ldfdyn', ahmt, 'T', 1.0_wp , ahmf, 'F', 1.0_wp ) + ! + END SELECT + ! + CALL iom_put( "ahmt_2d", ahmt(:,:,1) ) ! surface u-eddy diffusivity coeff. + CALL iom_put( "ahmf_2d", ahmf(:,:,1) ) ! surface v-eddy diffusivity coeff. + CALL iom_put( "ahmt_3d", ahmt(:,:,:) ) ! 3D u-eddy diffusivity coeff. + CALL iom_put( "ahmf_3d", ahmf(:,:,:) ) ! 3D v-eddy diffusivity coeff. + ! + IF( ln_timing ) CALL timing_stop('ldf_dyn') + ! + END SUBROUTINE ldf_dyn + + !!====================================================================== +END MODULE ldfdyn diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldfslp.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldfslp.F90 new file mode 100644 index 0000000..5a70f56 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldfslp.F90 @@ -0,0 +1,736 @@ +MODULE ldfslp + !!====================================================================== + !! *** MODULE ldfslp *** + !! Ocean physics: slopes of neutral surfaces + !!====================================================================== + !! History : OPA ! 1994-12 (G. Madec, M. Imbard) Original code + !! 8.0 ! 1997-06 (G. Madec) optimization, lbc + !! 8.1 ! 1999-10 (A. Jouzeau) NEW profile in the mixed layer + !! NEMO 1.0 ! 2002-10 (G. Madec) Free form, F90 + !! - ! 2005-10 (A. Beckmann) correction for s-coordinates + !! 3.3 ! 2010-10 (G. Nurser, C. Harris, G. Madec) add Griffies operator + !! - ! 2010-11 (F. Dupond, G. Madec) bug correction in slopes just below the ML + !! 3.7 ! 2013-12 (F. Lemarie, G. Madec) add limiter on triad slopes + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! ldf_slp : calculates the slopes of neutral surface (Madec operator) + !! ldf_slp_triad : calculates the triads of isoneutral slopes (Griffies operator) + !! ldf_slp_mxl : calculates the slopes at the base of the mixed layer (Madec operator) + !! ldf_slp_init : initialization of the slopes computation + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE isf_oce ! ice shelf + USE dom_oce ! ocean space and time domain +! USE ldfdyn ! lateral diffusion: eddy viscosity coef. + USE phycst ! physical constants + USE zdfmxl ! mixed layer depth + USE eosbn2 ! equation of states + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distribued memory computing library + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC ldf_slp ! routine called by step.F90 + PUBLIC ldf_slp_triad ! routine called by step.F90 + PUBLIC ldf_slp_init ! routine called by nemogcm.F90 + + LOGICAL , PUBLIC :: l_ldfslp = .FALSE. !: slopes flag + + LOGICAL , PUBLIC :: ln_traldf_iso = .TRUE. !: iso-neutral direction (nam_traldf namelist) + LOGICAL , PUBLIC :: ln_traldf_triad = .FALSE. !: griffies triad scheme (nam_traldf namelist) + LOGICAL , PUBLIC :: ln_dynldf_iso !: iso-neutral direction (nam_dynldf namelist) + + LOGICAL , PUBLIC :: ln_triad_iso = .FALSE. !: pure horizontal mixing in ML (nam_traldf namelist) + LOGICAL , PUBLIC :: ln_botmix_triad = .FALSE. !: mixing on bottom (nam_traldf namelist) + REAL(wp), PUBLIC :: rn_sw_triad = 1._wp !: =1 switching triads ; =0 all four triads used (nam_traldf namelist) + REAL(wp), PUBLIC :: rn_slpmax = 0.01_wp !: slope limit (nam_traldf namelist) + + LOGICAL , PUBLIC :: l_grad_zps = .FALSE. !: special treatment for Horz Tgradients w partial steps (triad operator) + + ! !! Classic operator (Madec) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uslp, wslpi !: i_slope at U- and W-points + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vslp, wslpj !: j-slope at V- and W-points + ! !! triad operator (Griffies) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wslp2 !: wslp**2 from Griffies quarter cells + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) :: triadi_g, triadj_g !: skew flux slopes relative to geopotentials + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) :: triadi , triadj !: isoneutral slopes relative to model-coordinate + ! !! both operators + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ah_wslp2 !: ah * slope^2 at w-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: akz !: stabilizing vertical diffusivity + + ! !! Madec operator + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: omlmask ! mask of the surface mixed layer at T-pt + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: uslpml, wslpiml ! i_slope at U- and W-points just below the mixed layer + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: vslpml, wslpjml ! j_slope at V- and W-points just below the mixed layer + + REAL(wp) :: repsln = 1.e-25_wp ! tiny value used as minium of di(rho), dj(rho) and dk(rho) + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ldfslp.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ldf_slp( kt, prd, pn2, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_slp *** + !! + !! ** Purpose : Compute the slopes of neutral surface (slope of isopycnal + !! surfaces referenced locally) (ln_traldf_iso=T). + !! + !! ** Method : The slope in the i-direction is computed at U- and + !! W-points (uslp, wslpi) and the slope in the j-direction is + !! computed at V- and W-points (vslp, wslpj). + !! They are bounded by 1/100 over the whole ocean, and within the + !! surface layer they are bounded by the distance to the surface + !! ( slope<= depth/l where l is the length scale of horizontal + !! diffusion (here, aht=2000m2/s ==> l=20km with a typical velocity + !! of 10cm/s) + !! A horizontal shapiro filter is applied to the slopes + !! ln_sco=T, s-coordinate, add to the previously computed slopes + !! the slope of the model level surface. + !! macro-tasked on horizontal slab (jk-loop) (2, jpk-1) + !! [slopes already set to zero at level 1, and to zero or the ocean + !! bottom slope (ln_sco=T) at level jpk in inildf] + !! + !! ** Action : - uslp, wslpi, and vslp, wslpj, the i- and j-slopes + !! of now neutral surfaces at u-, w- and v- w-points, resp. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step index + INTEGER , INTENT(in) :: Kbb, Kmm ! ocean time level indices + REAL(wp), INTENT(in), DIMENSION(:,:,:) :: prd ! in situ density + REAL(wp), INTENT(in), DIMENSION(:,:,:) :: pn2 ! Brunt-Vaisala frequency (locally ref.) + !! + INTEGER :: ji , jj , jk ! dummy loop indices + INTEGER :: ii0, ii1 ! temporary integer + INTEGER :: ij0, ij1 ! temporary integer + REAL(wp) :: zeps, zm1_g, zm1_2g, z1_16, zcofw, z1_slpmax ! local scalars + REAL(wp) :: zci, zfi, zau, zbu, zai, zbi ! - - + REAL(wp) :: zcj, zfj, zav, zbv, zaj, zbj ! - - + REAL(wp) :: zck, zfk, zbw ! - - + REAL(wp) :: zdepu, zdepv ! - - + REAL(wp), DIMENSION(jpi,jpj) :: zslpml_hmlpu, zslpml_hmlpv + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgru, zwz, zdzr + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgrv, zww + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('ldf_slp') + ! + zeps = 1.e-20_wp !== Local constant initialization ==! + z1_16 = 1.0_wp / 16._wp + zm1_g = -1.0_wp / grav + zm1_2g = -0.5_wp / grav + z1_slpmax = 1._wp / rn_slpmax + ! + zww(:,:,:) = 0._wp + zwz(:,:,:) = 0._wp + ! + DO_3D( 1, 0, 1, 0, 1, jpk ) !== i- & j-gradient of density ==! + zgru(ji,jj,jk) = umask(ji,jj,jk) * ( prd(ji+1,jj ,jk) - prd(ji,jj,jk) ) + zgrv(ji,jj,jk) = vmask(ji,jj,jk) * ( prd(ji ,jj+1,jk) - prd(ji,jj,jk) ) + END_3D + IF( ln_zps ) THEN ! partial steps correction at the bottom ocean level + DO_2D( 1, 0, 1, 0 ) + zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj) + zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj) + END_2D + ENDIF + IF( ln_zps .AND. ln_isfcav ) THEN ! partial steps correction at the bottom ocean level + DO_2D( 1, 0, 1, 0 ) + IF( miku(ji,jj) > 1 ) zgru(ji,jj,miku(ji,jj)) = grui(ji,jj) + IF( mikv(ji,jj) > 1 ) zgrv(ji,jj,mikv(ji,jj)) = grvi(ji,jj) + END_2D + ENDIF + ! + zdzr(:,:,1) = 0._wp !== Local vertical density gradient at T-point == ! (evaluated from N^2) + DO jk = 2, jpkm1 + ! ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point + ! ! trick: tmask(ik ) = 0 => all pn2 = 0 => zdzr = 0 + ! ! else tmask(ik+1) = 0 => pn2(ik+1) = 0 => zdzr divides by 1 + ! ! umask(ik+1) /= 0 => all pn2 /= 0 => zdzr divides by 2 + ! ! NB: 1/(tmask+1) = (1-.5*tmask) substitute a / by a * ==> faster + zdzr(:,:,jk) = zm1_g * ( prd(:,:,jk) + 1._wp ) & + & * ( pn2(:,:,jk) + pn2(:,:,jk+1) ) * ( 1._wp - 0.5_wp * tmask(:,:,jk+1) ) + END DO + ! + ! !== Slopes just below the mixed layer ==! + CALL ldf_slp_mxl( prd, pn2, zgru, zgrv, zdzr, Kmm ) ! output: uslpml, vslpml, wslpiml, wslpjml + + + ! I. slopes at u and v point | uslp = d/di( prd ) / d/dz( prd ) + ! =========================== | vslp = d/dj( prd ) / d/dz( prd ) + ! + IF ( ln_isfcav ) THEN + DO_2D( 0, 0, 0, 0 ) + zslpml_hmlpu(ji,jj) = uslpml(ji,jj) / ( MAX(hmlpt (ji,jj), hmlpt (ji+1,jj ), 5._wp) & + & - MAX(risfdep(ji,jj), risfdep(ji+1,jj ) ) ) + zslpml_hmlpv(ji,jj) = vslpml(ji,jj) / ( MAX(hmlpt (ji,jj), hmlpt (ji ,jj+1), 5._wp) & + & - MAX(risfdep(ji,jj), risfdep(ji ,jj+1) ) ) + END_2D + ELSE + DO_2D( 0, 0, 0, 0 ) + zslpml_hmlpu(ji,jj) = uslpml(ji,jj) / MAX(hmlpt(ji,jj), hmlpt(ji+1,jj ), 5._wp) + zslpml_hmlpv(ji,jj) = vslpml(ji,jj) / MAX(hmlpt(ji,jj), hmlpt(ji ,jj+1), 5._wp) + END_2D + END IF + + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* Slopes at u and v points + ! ! horizontal and vertical density gradient at u- and v-points + zau = zgru(ji,jj,jk) * r1_e1u(ji,jj) + zav = zgrv(ji,jj,jk) * r1_e2v(ji,jj) + zbu = 0.5_wp * ( zdzr(ji,jj,jk) + zdzr(ji+1,jj ,jk) ) + zbv = 0.5_wp * ( zdzr(ji,jj,jk) + zdzr(ji ,jj+1,jk) ) + ! ! bound the slopes: abs(zw.)<= 1/100 and zb..<0 + ! ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) + zbu = MIN( zbu, - z1_slpmax * ABS( zau ) , -7.e+3_wp/e3u(ji,jj,jk,Kmm)* ABS( zau ) ) + zbv = MIN( zbv, - z1_slpmax * ABS( zav ) , -7.e+3_wp/e3v(ji,jj,jk,Kmm)* ABS( zav ) ) + ! ! Fred Dupont: add a correction for bottom partial steps: + ! ! max slope = 1/2 * e3 / e1 + IF (ln_zps .AND. jk==mbku(ji,jj)) & + zbu = MIN( zbu, - z1_slpmax * ABS( zau ) , & + & - 2._wp * e1u(ji,jj) / e3u(ji,jj,jk,Kmm)* ABS( zau ) ) + IF (ln_zps .AND. jk==mbkv(ji,jj)) & + zbv = MIN( zbv, - z1_slpmax * ABS( zav ) , & + & - 2._wp * e2v(ji,jj) / e3v(ji,jj,jk,Kmm)* ABS( zav ) ) + ! ! uslp and vslp output in zwz and zww, resp. + zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj,jk) ) + zfj = MAX( omlmask(ji,jj,jk), omlmask(ji,jj+1,jk) ) + ! thickness of water column between surface and level k at u/v point + zdepu = 0.5_wp * ( ( gdept(ji,jj,jk,Kmm) + gdept(ji+1,jj,jk,Kmm) ) & + & - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj) ) & + & - e3u(ji,jj,miku(ji,jj),Kmm) ) + zdepv = 0.5_wp * ( ( gdept(ji,jj,jk,Kmm) + gdept(ji,jj+1,jk,Kmm) ) & + & - 2 * MAX( risfdep(ji,jj), risfdep(ji,jj+1) ) & + & - e3v(ji,jj,mikv(ji,jj),Kmm) ) + ! + zwz(ji,jj,jk) = ( ( 1._wp - zfi) * zau / ( zbu - zeps ) & + & + zfi * zdepu * zslpml_hmlpu(ji,jj) ) * umask(ji,jj,jk) + zww(ji,jj,jk) = ( ( 1._wp - zfj) * zav / ( zbv - zeps ) & + & + zfj * zdepv * zslpml_hmlpv(ji,jj) ) * vmask(ji,jj,jk) +!!gm modif to suppress omlmask.... (as in Griffies case) +! ! ! jk must be >= ML level for zf=1. otherwise zf=0. +! zfi = REAL( 1 - 1/(1 + jk / MAX( nmln(ji+1,jj), nmln(ji,jj) ) ), wp ) +! zfj = REAL( 1 - 1/(1 + jk / MAX( nmln(ji,jj+1), nmln(ji,jj) ) ), wp ) +! zci = 0.5 * ( gdept(ji+1,jj,jk,Kmm)+gdept(ji,jj,jk,Kmm) ) / MAX( hmlpt(ji,jj), hmlpt(ji+1,jj), 10. ) ) +! zcj = 0.5 * ( gdept(ji,jj+1,jk,Kmm)+gdept(ji,jj,jk,Kmm) ) / MAX( hmlpt(ji,jj), hmlpt(ji,jj+1), 10. ) ) +! zwz(ji,jj,jk) = ( zfi * zai / ( zbi - zeps ) + ( 1._wp - zfi ) * wslpiml(ji,jj) * zci ) * tmask(ji,jj,jk) +! zww(ji,jj,jk) = ( zfj * zaj / ( zbj - zeps ) + ( 1._wp - zfj ) * wslpjml(ji,jj) * zcj ) * tmask(ji,jj,jk) +!!gm end modif + END_3D + CALL lbc_lnk( 'ldfslp', zwz, 'U', -1.0_wp, zww, 'V', -1.0_wp ) ! lateral boundary conditions + ! + ! !* horizontal Shapiro filter + DO jk = 2, jpkm1 + DO_2D( 0, 0, 0, 0 ) ! rows jj=2 and =jpjm1 only + uslp(ji,jj,jk) = z1_16 * ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & + & + zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk) & + & + 2.*( zwz(ji ,jj-1,jk) + zwz(ji-1,jj ,jk) & + & + zwz(ji+1,jj ,jk) + zwz(ji ,jj+1,jk) ) & + & + 4.* zwz(ji ,jj ,jk) ) + vslp(ji,jj,jk) = z1_16 * ( zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk) & + & + zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk) & + & + 2.*( zww(ji ,jj-1,jk) + zww(ji-1,jj ,jk) & + & + zww(ji+1,jj ,jk) + zww(ji ,jj+1,jk) ) & + & + 4.* zww(ji,jj ,jk) ) + END_2D + ! !* decrease along coastal boundaries + DO_2D( 0, 0, 0, 0 ) + uslp(ji,jj,jk) = uslp(ji,jj,jk) * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk ) ) * 0.5_wp & + & * ( umask(ji,jj ,jk) + umask(ji,jj ,jk+1) ) * 0.5_wp + vslp(ji,jj,jk) = vslp(ji,jj,jk) * ( vmask(ji+1,jj,jk) + vmask(ji-1,jj,jk ) ) * 0.5_wp & + & * ( vmask(ji ,jj,jk) + vmask(ji ,jj,jk+1) ) * 0.5_wp + END_2D + END DO + + + ! II. slopes at w point | wslpi = mij( d/di( prd ) / d/dz( prd ) + ! =========================== | wslpj = mij( d/dj( prd ) / d/dz( prd ) + ! + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + ! !* Local vertical density gradient evaluated from N^2 + zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. ) + ! !* Slopes at w point + ! ! i- & j-gradient of density at w-points + zci = MAX( umask(ji-1,jj,jk ) + umask(ji,jj,jk ) & + & + umask(ji-1,jj,jk-1) + umask(ji,jj,jk-1) , zeps ) * e1t(ji,jj) + zcj = MAX( vmask(ji,jj-1,jk ) + vmask(ji,jj,jk-1) & + & + vmask(ji,jj-1,jk-1) + vmask(ji,jj,jk ) , zeps ) * e2t(ji,jj) + zai = ( zgru (ji-1,jj,jk ) + zgru (ji,jj,jk-1) & + & + zgru (ji-1,jj,jk-1) + zgru (ji,jj,jk ) ) / zci * wmask (ji,jj,jk) + zaj = ( zgrv (ji,jj-1,jk ) + zgrv (ji,jj,jk-1) & + & + zgrv (ji,jj-1,jk-1) + zgrv (ji,jj,jk ) ) / zcj * wmask (ji,jj,jk) + ! ! bound the slopes: abs(zw.)<= 1/100 and zb..<0. + ! ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) + zbi = MIN( zbw ,- 100._wp* ABS( zai ) , -7.e+3_wp/e3w(ji,jj,jk,Kmm)* ABS( zai ) ) + zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/e3w(ji,jj,jk,Kmm)* ABS( zaj ) ) + ! ! wslpi and wslpj with ML flattening (output in zwz and zww, resp.) + zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) ) ! zfk=1 in the ML otherwise zfk=0 + zck = ( gdepw(ji,jj,jk,Kmm) - gdepw(ji,jj,mikt(ji,jj),Kmm) ) / MAX( hmlp(ji,jj) - gdepw(ji,jj,mikt(ji,jj),Kmm), 10._wp ) + zwz(ji,jj,jk) = ( zai / ( zbi - zeps ) * ( 1._wp - zfk ) + zck * wslpiml(ji,jj) * zfk ) * wmask(ji,jj,jk) + zww(ji,jj,jk) = ( zaj / ( zbj - zeps ) * ( 1._wp - zfk ) + zck * wslpjml(ji,jj) * zfk ) * wmask(ji,jj,jk) + +!!gm modif to suppress omlmask.... (as in Griffies operator) +! ! ! jk must be >= ML level for zfk=1. otherwise zfk=0. +! zfk = REAL( 1 - 1/(1 + jk / nmln(ji+1,jj)), wp ) +! zck = gdepw(ji,jj,jk,Kmm) / MAX( hmlp(ji,jj), 10. ) +! zwz(ji,jj,jk) = ( zfk * zai / ( zbi - zeps ) + ( 1._wp - zfk ) * wslpiml(ji,jj) * zck ) * tmask(ji,jj,jk) +! zww(ji,jj,jk) = ( zfk * zaj / ( zbj - zeps ) + ( 1._wp - zfk ) * wslpjml(ji,jj) * zck ) * tmask(ji,jj,jk) +!!gm end modif + END_3D + CALL lbc_lnk( 'ldfslp', zwz, 'T', -1.0_wp, zww, 'T', -1.0_wp ) ! lateral boundary conditions + ! + ! !* horizontal Shapiro filter + DO jk = 2, jpkm1 + DO_2D( 0, 0, 0, 0 ) ! rows jj=2 and =jpjm1 only + zcofw = wmask(ji,jj,jk) * z1_16 + wslpi(ji,jj,jk) = ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & + & + zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk) & + & + 2.*( zwz(ji ,jj-1,jk) + zwz(ji-1,jj ,jk) & + & + zwz(ji+1,jj ,jk) + zwz(ji ,jj+1,jk) ) & + & + 4.* zwz(ji ,jj ,jk) ) * zcofw + + wslpj(ji,jj,jk) = ( zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk) & + & + zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk) & + & + 2.*( zww(ji ,jj-1,jk) + zww(ji-1,jj ,jk) & + & + zww(ji+1,jj ,jk) + zww(ji ,jj+1,jk) ) & + & + 4.* zww(ji ,jj ,jk) ) * zcofw + END_2D + ! !* decrease in vicinity of topography + DO_2D( 0, 0, 0, 0 ) + zck = ( umask(ji,jj,jk) + umask(ji-1,jj,jk) ) & + & * ( vmask(ji,jj,jk) + vmask(ji,jj-1,jk) ) * 0.25 + wslpi(ji,jj,jk) = wslpi(ji,jj,jk) * zck + wslpj(ji,jj,jk) = wslpj(ji,jj,jk) * zck + END_2D + END DO + + ! IV. Lateral boundary conditions + ! =============================== + CALL lbc_lnk( 'ldfslp', uslp , 'U', -1.0_wp , vslp , 'V', -1.0_wp , wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) + + IF(sn_cfctl%l_prtctl) THEN + CALL prt_ctl(tab3d_1=REAL(uslp,dp), clinfo1=' slp - u : ', tab3d_2=REAL(vslp,dp), clinfo2=' v : ') + CALL prt_ctl(tab3d_1=REAL(wslpi,dp), clinfo1=' slp - wi: ', tab3d_2=REAL(wslpj,dp), clinfo2=' wj: ') + ENDIF + ! + IF( ln_timing ) CALL timing_stop('ldf_slp') + ! + END SUBROUTINE ldf_slp + + + SUBROUTINE ldf_slp_triad ( kt, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_slp_triad *** + !! + !! ** Purpose : Compute the squared slopes of neutral surfaces (slope + !! of iso-pycnal surfaces referenced locally) (ln_traldf_triad=T) + !! at W-points using the Griffies quarter-cells. + !! + !! ** Method : calculates alpha and beta at T-points + !! + !! ** Action : - triadi_g, triadj_g T-pts i- and j-slope triads relative to geopot. (used for eiv) + !! - triadi , triadj T-pts i- and j-slope triads relative to model-coordinate + !! - wslp2 squared slope of neutral surfaces at w-points. + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER , INTENT(in) :: Kbb, Kmm ! ocean time level indices + !! + INTEGER :: ji, jj, jk, jl, ip, jp, kp ! dummy loop indices + INTEGER :: iku, ikv ! local integer + REAL(wp) :: zfacti, zfactj ! local scalars + REAL(wp) :: znot_thru_surface ! local scalars + REAL(wp) :: zdit, zdis, zdkt, zbu, zbti, zisw + REAL(wp) :: zdjt, zdjs, zdks, zbv, zbtj, zjsw + REAL(wp) :: zdxrho_raw, zti_coord, zti_raw, zti_lim, zti_g_raw, zti_g_lim + REAL(wp) :: zdyrho_raw, ztj_coord, ztj_raw, ztj_lim, ztj_g_raw, ztj_g_lim + REAL(wp) :: zdzrho_raw + REAL(wp) :: zbeta0, ze3_e1, ze3_e2 + REAL(wp), DIMENSION(jpi,jpj) :: z1_mlbw + REAL(wp), DIMENSION(jpi,jpj,jpk,0:1) :: zdxrho , zdyrho, zdzrho ! Horizontal and vertical density gradients + REAL(wp), DIMENSION(jpi,jpj,0:1,0:1) :: zti_mlb, ztj_mlb ! for Griffies operator only + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('ldf_slp_triad') + ! + !--------------------------------! + ! Some preliminary calculation ! + !--------------------------------! + ! + DO jl = 0, 1 !== unmasked before density i- j-, k-gradients ==! + ! + ip = jl ; jp = jl ! guaranteed nonzero gradients ( absolute value larger than repsln) + DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) ! done each pair of triad ! NB: not masked ==> a minimum value is set + zdit = ( ts(ji+1,jj,jk,jp_tem,Kbb) - ts(ji,jj,jk,jp_tem,Kbb) ) ! i-gradient of T & S at u-point + zdis = ( ts(ji+1,jj,jk,jp_sal,Kbb) - ts(ji,jj,jk,jp_sal,Kbb) ) + zdjt = ( ts(ji,jj+1,jk,jp_tem,Kbb) - ts(ji,jj,jk,jp_tem,Kbb) ) ! j-gradient of T & S at v-point + zdjs = ( ts(ji,jj+1,jk,jp_sal,Kbb) - ts(ji,jj,jk,jp_sal,Kbb) ) + zdxrho_raw = ( - rab_b(ji+ip,jj ,jk,jp_tem) * zdit + rab_b(ji+ip,jj ,jk,jp_sal) * zdis ) * r1_e1u(ji,jj) + zdyrho_raw = ( - rab_b(ji ,jj+jp,jk,jp_tem) * zdjt + rab_b(ji ,jj+jp,jk,jp_sal) * zdjs ) * r1_e2v(ji,jj) + zdxrho(ji+ip,jj ,jk,1-ip) = SIGN( MAX( repsln, ABS( zdxrho_raw ) ), zdxrho_raw ) ! keep the sign + zdyrho(ji ,jj+jp,jk,1-jp) = SIGN( MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw ) + END_3D + ! + IF( ln_zps .AND. l_grad_zps ) THEN ! partial steps: correction of i- & j-grad on bottom + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + iku = mbku(ji,jj) ; ikv = mbkv(ji,jj) ! last ocean level (u- & v-points) + zdit = gtsu(ji,jj,jp_tem) ; zdjt = gtsv(ji,jj,jp_tem) ! i- & j-gradient of Temperature + zdis = gtsu(ji,jj,jp_sal) ; zdjs = gtsv(ji,jj,jp_sal) ! i- & j-gradient of Salinity + zdxrho_raw = ( - rab_b(ji+ip,jj ,iku,jp_tem) * zdit + rab_b(ji+ip,jj ,iku,jp_sal) * zdis ) * r1_e1u(ji,jj) + zdyrho_raw = ( - rab_b(ji ,jj+jp,ikv,jp_tem) * zdjt + rab_b(ji ,jj+jp,ikv,jp_sal) * zdjs ) * r1_e2v(ji,jj) + zdxrho(ji+ip,jj ,iku,1-ip) = SIGN( MAX( repsln, ABS( zdxrho_raw ) ), zdxrho_raw ) ! keep the sign + zdyrho(ji ,jj+jp,ikv,1-jp) = SIGN( MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw ) + END_2D + ENDIF + ! + END DO + + DO kp = 0, 1 !== unmasked before density i- j-, k-gradients ==! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) ! done each pair of triad ! NB: not masked ==> a minimum value is set + IF( jk+kp > 1 ) THEN ! k-gradient of T & S a jk+kp + zdkt = ( ts(ji,jj,jk+kp-1,jp_tem,Kbb) - ts(ji,jj,jk+kp,jp_tem,Kbb) ) + zdks = ( ts(ji,jj,jk+kp-1,jp_sal,Kbb) - ts(ji,jj,jk+kp,jp_sal,Kbb) ) + ELSE + zdkt = 0._wp ! 1st level gradient set to zero + zdks = 0._wp + ENDIF + zdzrho_raw = ( - rab_b(ji,jj,jk ,jp_tem) * zdkt & + & + rab_b(ji,jj,jk ,jp_sal) * zdks & + & ) / e3w(ji,jj,jk+kp,Kmm) + zdzrho(ji,jj,jk,kp) = - MIN( - repsln , zdzrho_raw ) ! force zdzrho >= repsln + END_3D + END DO + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) !== Reciprocal depth of the w-point below ML base ==! + jk = MIN( nmln(ji,jj), mbkt(ji,jj) ) + 1 ! MIN in case ML depth is the ocean depth + z1_mlbw(ji,jj) = 1._wp / gdepw(ji,jj,jk,Kmm) + END_2D + ! + ! !== intialisations to zero ==! + ! + wslp2 (:,:,:) = 0._wp ! wslp2 will be cumulated 3D field set to zero + triadi_g(:,:,1,:,:) = 0._wp ; triadi_g(:,:,jpk,:,:) = 0._wp ! set surface and bottom slope to zero + triadj_g(:,:,1,:,:) = 0._wp ; triadj_g(:,:,jpk,:,:) = 0._wp + !!gm _iso set to zero missing + triadi (:,:,1,:,:) = 0._wp ; triadj (:,:,jpk,:,:) = 0._wp ! set surface and bottom slope to zero + triadj (:,:,1,:,:) = 0._wp ; triadj (:,:,jpk,:,:) = 0._wp + + !-------------------------------------! + ! Triads just below the Mixed Layer ! + !-------------------------------------! + ! + DO jl = 0, 1 ! calculate slope of the 4 triads immediately ONE level below mixed-layer base + DO kp = 0, 1 ! with only the slope-max limit and MASKED + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + ip = jl ; jp = jl + ! + jk = nmln(ji+ip,jj) + 1 + IF( jk > mbkt(ji+ip,jj) ) THEN ! ML reaches bottom + zti_mlb(ji+ip,jj ,1-ip,kp) = 0.0_wp + ELSE + ! Add s-coordinate slope at t-points (do this by *subtracting* gradient of depth) + zti_g_raw = ( zdxrho(ji+ip,jj,jk-kp,1-ip) / zdzrho(ji+ip,jj,jk-kp,kp) & + & - ( gdept(ji+1,jj,jk-kp,Kmm) - gdept(ji,jj,jk-kp,Kmm) ) * r1_e1u(ji,jj) ) * umask(ji,jj,jk) + ze3_e1 = e3w(ji+ip,jj,jk-kp,Kmm) * r1_e1u(ji,jj) + zti_mlb(ji+ip,jj ,1-ip,kp) = SIGN( MIN( rn_slpmax, 5.0_wp * ze3_e1 , ABS( zti_g_raw ) ), zti_g_raw ) + ENDIF + ! + jk = nmln(ji,jj+jp) + 1 + IF( jk > mbkt(ji,jj+jp) ) THEN !ML reaches bottom + ztj_mlb(ji ,jj+jp,1-jp,kp) = 0.0_wp + ELSE + ztj_g_raw = ( zdyrho(ji,jj+jp,jk-kp,1-jp) / zdzrho(ji,jj+jp,jk-kp,kp) & + & - ( gdept(ji,jj+1,jk-kp,Kmm) - gdept(ji,jj,jk-kp,Kmm) ) / e2v(ji,jj) ) * vmask(ji,jj,jk) + ze3_e2 = e3w(ji,jj+jp,jk-kp,Kmm) / e2v(ji,jj) + ztj_mlb(ji ,jj+jp,1-jp,kp) = SIGN( MIN( rn_slpmax, 5.0_wp * ze3_e2 , ABS( ztj_g_raw ) ), ztj_g_raw ) + ENDIF + END_2D + END DO + END DO + + !-------------------------------------! + ! Triads with surface limits ! + !-------------------------------------! + ! + DO kp = 0, 1 ! k-index of triads + DO jl = 0, 1 + ip = jl ; jp = jl ! i- and j-indices of triads (i-k and j-k planes) + DO jk = 1, jpkm1 + ! Must mask contribution to slope from dz/dx at constant s for triads jk=1,kp=0 that poke up though ocean surface + znot_thru_surface = REAL( 1-1/(jk+kp), wp ) !jk+kp=1,=0.; otherwise=1.0 + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + ! + ! Calculate slope relative to geopotentials used for GM skew fluxes + ! Add s-coordinate slope at t-points (do this by *subtracting* gradient of depth) + ! Limit by slope *relative to geopotentials* by rn_slpmax, and mask by psi-point + ! masked by umask taken at the level of dz(rho) + ! + ! raw slopes: unmasked unbounded slopes (relative to geopotential (zti_g) and model surface (zti) + ! + zti_raw = zdxrho(ji+ip,jj ,jk,1-ip) / zdzrho(ji+ip,jj ,jk,kp) ! unmasked + ztj_raw = zdyrho(ji ,jj+jp,jk,1-jp) / zdzrho(ji ,jj+jp,jk,kp) + ! + ! Must mask contribution to slope for triad jk=1,kp=0 that poke up though ocean surface + zti_coord = znot_thru_surface * ( gdept(ji+1,jj ,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e1u(ji,jj) + ztj_coord = znot_thru_surface * ( gdept(ji ,jj+1,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e2v(ji,jj) ! unmasked + zti_g_raw = zti_raw - zti_coord ! ref to geopot surfaces + ztj_g_raw = ztj_raw - ztj_coord + ! additional limit required in bilaplacian case + ze3_e1 = e3w(ji+ip,jj ,jk+kp,Kmm) * r1_e1u(ji,jj) + ze3_e2 = e3w(ji ,jj+jp,jk+kp,Kmm) * r1_e2v(ji,jj) + ! NB: hard coded factor 5 (can be a namelist parameter...) + zti_g_lim = SIGN( MIN( rn_slpmax, 5.0_wp * ze3_e1, ABS( zti_g_raw ) ), zti_g_raw ) + ztj_g_lim = SIGN( MIN( rn_slpmax, 5.0_wp * ze3_e2, ABS( ztj_g_raw ) ), ztj_g_raw ) + ! + ! Below ML use limited zti_g as is & mask + ! Inside ML replace by linearly reducing sx_mlb towards surface & mask + ! + zfacti = REAL( 1 - 1/(1 + (jk+kp-1)/nmln(ji+ip,jj)), wp ) ! k index of uppermost point(s) of triad is jk+kp-1 + zfactj = REAL( 1 - 1/(1 + (jk+kp-1)/nmln(ji,jj+jp)), wp ) ! must be .ge. nmln(ji,jj) for zfact=1 + ! ! otherwise zfact=0 + zti_g_lim = ( zfacti * zti_g_lim & + & + ( 1._wp - zfacti ) * zti_mlb(ji+ip,jj,1-ip,kp) & + & * gdepw(ji+ip,jj,jk+kp,Kmm) * z1_mlbw(ji+ip,jj) ) * umask(ji,jj,jk+kp) + ztj_g_lim = ( zfactj * ztj_g_lim & + & + ( 1._wp - zfactj ) * ztj_mlb(ji,jj+jp,1-jp,kp) & + & * gdepw(ji,jj+jp,jk+kp,Kmm) * z1_mlbw(ji,jj+jp) ) * vmask(ji,jj,jk+kp) + ! + triadi_g(ji+ip,jj ,jk,1-ip,kp) = zti_g_lim + triadj_g(ji ,jj+jp,jk,1-jp,kp) = ztj_g_lim + ! + ! Get coefficients of isoneutral diffusion tensor + ! 1. Utilise gradients *relative* to s-coordinate, so add t-point slopes (*subtract* depth gradients) + ! 2. We require that isoneutral diffusion gives no vertical buoyancy flux + ! i.e. 33 term = (real slope* 31, 13 terms) + ! To do this, retain limited sx**2 in vertical flux, but divide by real slope for 13/31 terms + ! Equivalent to tapering A_iso = sx_limited**2/(real slope)**2 + ! + zti_lim = ( zti_g_lim + zti_coord ) * umask(ji,jj,jk+kp) ! remove coordinate slope => relative to coordinate surfaces + ztj_lim = ( ztj_g_lim + ztj_coord ) * vmask(ji,jj,jk+kp) + ! + IF( ln_triad_iso ) THEN + zti_raw = zti_lim*zti_lim / zti_raw + ztj_raw = ztj_lim*ztj_lim / ztj_raw + zti_raw = SIGN( MIN( ABS(zti_lim), ABS( zti_raw ) ), zti_raw ) + ztj_raw = SIGN( MIN( ABS(ztj_lim), ABS( ztj_raw ) ), ztj_raw ) + zti_lim = zfacti * zti_lim + ( 1._wp - zfacti ) * zti_raw + ztj_lim = zfactj * ztj_lim + ( 1._wp - zfactj ) * ztj_raw + ENDIF + ! ! switching triad scheme + zisw = (1._wp - rn_sw_triad ) + rn_sw_triad & + & * 2._wp * ABS( 0.5_wp - kp - ( 0.5_wp - ip ) * SIGN( 1._wp , zdxrho(ji+ip,jj,jk,1-ip) ) ) + zjsw = (1._wp - rn_sw_triad ) + rn_sw_triad & + & * 2._wp * ABS( 0.5_wp - kp - ( 0.5_wp - jp ) * SIGN( 1._wp , zdyrho(ji,jj+jp,jk,1-jp) ) ) + ! + triadi(ji+ip,jj ,jk,1-ip,kp) = zti_lim * zisw + triadj(ji ,jj+jp,jk,1-jp,kp) = ztj_lim * zjsw + ! + zbu = e1e2u(ji ,jj ) * e3u(ji ,jj ,jk ,Kmm) + zbv = e1e2v(ji ,jj ) * e3v(ji ,jj ,jk ,Kmm) + zbti = e1e2t(ji+ip,jj ) * e3w(ji+ip,jj ,jk+kp,Kmm) + zbtj = e1e2t(ji ,jj+jp) * e3w(ji ,jj+jp,jk+kp,Kmm) + ! + wslp2(ji+ip,jj,jk+kp) = wslp2(ji+ip,jj,jk+kp) + 0.25_wp * zbu / zbti * zti_g_lim*zti_g_lim ! masked + wslp2(ji,jj+jp,jk+kp) = wslp2(ji,jj+jp,jk+kp) + 0.25_wp * zbv / zbtj * ztj_g_lim*ztj_g_lim + END_2D + END DO + END DO + END DO + ! + wslp2(:,:,1) = 0._wp ! force the surface wslp to zero + + CALL lbc_lnk( 'ldfslp', wslp2, 'W', 1.0_wp ) ! lateral boundary confition on wslp2 only ==>>> gm : necessary ? to be checked + ! + IF( ln_timing ) CALL timing_stop('ldf_slp_triad') + ! + END SUBROUTINE ldf_slp_triad + + + SUBROUTINE ldf_slp_mxl( prd, pn2, p_gru, p_grv, p_dzr, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_slp_mxl *** + !! + !! ** Purpose : Compute the slopes of iso-neutral surface just below + !! the mixed layer. + !! + !! ** Method : The slope in the i-direction is computed at u- & w-points + !! (uslpml, wslpiml) and the slope in the j-direction is computed + !! at v- and w-points (vslpml, wslpjml) with the same bounds as + !! in ldf_slp. + !! + !! ** Action : uslpml, wslpiml : i- & j-slopes of neutral surfaces + !! vslpml, wslpjml just below the mixed layer + !! omlmask : mixed layer mask + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: prd ! in situ density + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pn2 ! Brunt-Vaisala frequency (locally ref.) + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: p_gru, p_grv ! i- & j-gradient of density (u- & v-pts) + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: p_dzr ! z-gradient of density (T-point) + INTEGER , INTENT(in) :: Kmm ! ocean time level indices + !! + INTEGER :: ji , jj , jk ! dummy loop indices + INTEGER :: iku, ikv, ik, ikm1 ! local integers + REAL(wp) :: zeps, zm1_g, zm1_2g, z1_slpmax ! local scalars + REAL(wp) :: zci, zfi, zau, zbu, zai, zbi ! - - + REAL(wp) :: zcj, zfj, zav, zbv, zaj, zbj ! - - + REAL(wp) :: zck, zfk, zbw ! - - + !!---------------------------------------------------------------------- + ! + zeps = 1.e-20_wp !== Local constant initialization ==! + zm1_g = -1.0_wp / grav + zm1_2g = -0.5_wp / grav + z1_slpmax = 1._wp / rn_slpmax + ! + uslpml (1,:) = 0._wp ; uslpml (jpi,:) = 0._wp + vslpml (1,:) = 0._wp ; vslpml (jpi,:) = 0._wp + wslpiml(1,:) = 0._wp ; wslpiml(jpi,:) = 0._wp + wslpjml(1,:) = 0._wp ; wslpjml(jpi,:) = 0._wp + ! + ! !== surface mixed layer mask ! + DO_3D( 1, 1, 1, 1, 1, jpk ) ! =1 inside the mixed layer, =0 otherwise + ik = nmln(ji,jj) - 1 + IF( jk <= ik ) THEN ; omlmask(ji,jj,jk) = 1._wp + ELSE ; omlmask(ji,jj,jk) = 0._wp + ENDIF + END_3D + + + ! Slopes of isopycnal surfaces just before bottom of mixed layer + ! -------------------------------------------------------------- + ! The slope are computed as in the 3D case. + ! A key point here is the definition of the mixed layer at u- and v-points. + ! It is assumed to be the maximum of the two neighbouring T-point mixed layer depth. + ! Otherwise, a n2 value inside the mixed layer can be involved in the computation + ! of the slope, resulting in a too steep diagnosed slope and thus a spurious eddy + ! induce velocity field near the base of the mixed layer. + !----------------------------------------------------------------------- + ! + DO_2D( 0, 0, 0, 0 ) + ! !== Slope at u- & v-points just below the Mixed Layer ==! + ! + ! !- vertical density gradient for u- and v-slopes (from dzr at T-point) + iku = MIN( MAX( 1, nmln(ji,jj) , nmln(ji+1,jj) ) , jpkm1 ) ! ML (MAX of T-pts, bound by jpkm1) + ikv = MIN( MAX( 1, nmln(ji,jj) , nmln(ji,jj+1) ) , jpkm1 ) ! + zbu = 0.5_wp * ( p_dzr(ji,jj,iku) + p_dzr(ji+1,jj ,iku) ) + zbv = 0.5_wp * ( p_dzr(ji,jj,ikv) + p_dzr(ji ,jj+1,ikv) ) + ! !- horizontal density gradient at u- & v-points + zau = p_gru(ji,jj,iku) * r1_e1u(ji,jj) + zav = p_grv(ji,jj,ikv) * r1_e2v(ji,jj) + ! !- bound the slopes: abs(zw.)<= 1/100 and zb..<0 + ! kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) + zbu = MIN( zbu , - z1_slpmax * ABS( zau ) , -7.e+3_wp/e3u(ji,jj,iku,Kmm)* ABS( zau ) ) + zbv = MIN( zbv , - z1_slpmax * ABS( zav ) , -7.e+3_wp/e3v(ji,jj,ikv,Kmm)* ABS( zav ) ) + ! !- Slope at u- & v-points (uslpml, vslpml) + uslpml(ji,jj) = zau / ( zbu - zeps ) * umask(ji,jj,iku) + vslpml(ji,jj) = zav / ( zbv - zeps ) * vmask(ji,jj,ikv) + ! + ! !== i- & j-slopes at w-points just below the Mixed Layer ==! + ! + ik = MIN( nmln(ji,jj) + 1, jpk ) + ikm1 = MAX( 1, ik-1 ) + ! !- vertical density gradient for w-slope (from N^2) + zbw = zm1_2g * pn2 (ji,jj,ik) * ( prd (ji,jj,ik) + prd (ji,jj,ikm1) + 2. ) + ! !- horizontal density i- & j-gradient at w-points + zci = MAX( umask(ji-1,jj,ik ) + umask(ji,jj,ik ) & + & + umask(ji-1,jj,ikm1) + umask(ji,jj,ikm1) , zeps ) * e1t(ji,jj) + zcj = MAX( vmask(ji,jj-1,ik ) + vmask(ji,jj,ik ) & + & + vmask(ji,jj-1,ikm1) + vmask(ji,jj,ikm1) , zeps ) * e2t(ji,jj) + zai = ( p_gru(ji-1,jj,ik ) + p_gru(ji,jj,ik) & + & + p_gru(ji-1,jj,ikm1) + p_gru(ji,jj,ikm1 ) ) / zci * tmask(ji,jj,ik) + zaj = ( p_grv(ji,jj-1,ik ) + p_grv(ji,jj,ik ) & + & + p_grv(ji,jj-1,ikm1) + p_grv(ji,jj,ikm1) ) / zcj * tmask(ji,jj,ik) + ! !- bound the slopes: abs(zw.)<= 1/100 and zb..<0. + ! kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) + zbi = MIN( zbw , -100._wp* ABS( zai ) , -7.e+3_wp/e3w(ji,jj,ik,Kmm)* ABS( zai ) ) + zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/e3w(ji,jj,ik,Kmm)* ABS( zaj ) ) + ! !- i- & j-slope at w-points (wslpiml, wslpjml) + wslpiml(ji,jj) = zai / ( zbi - zeps ) * tmask (ji,jj,ik) + wslpjml(ji,jj) = zaj / ( zbj - zeps ) * tmask (ji,jj,ik) + END_2D + !!gm this lbc_lnk should be useless.... + CALL lbc_lnk( 'ldfslp', uslpml , 'U', -1.0_wp , vslpml , 'V', -1.0_wp , wslpiml, 'W', -1.0_wp , wslpjml, 'W', -1.0_wp ) + ! + END SUBROUTINE ldf_slp_mxl + + + SUBROUTINE ldf_slp_init + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_slp_init *** + !! + !! ** Purpose : Initialization for the isopycnal slopes computation + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ierr ! local integer + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'ldf_slp_init : direction of lateral mixing' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + ALLOCATE( ah_wslp2(jpi,jpj,jpk) , akz(jpi,jpj,jpk) , STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate ah_slp2 or akz' ) + ! + IF( ln_traldf_triad ) THEN ! Griffies operator : triad of slopes + IF(lwp) WRITE(numout,*) ' ==>>> triad) operator (Griffies)' + ALLOCATE( triadi_g(jpi,jpj,jpk,0:1,0:1) , triadj_g(jpi,jpj,jpk,0:1,0:1) , & + & triadi (jpi,jpj,jpk,0:1,0:1) , triadj (jpi,jpj,jpk,0:1,0:1) , & + & wslp2 (jpi,jpj,jpk) , STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Griffies operator slope' ) + IF( ln_dynldf_iso ) CALL ctl_stop( 'ldf_slp_init: Griffies operator on momentum not supported' ) + ! + ELSE ! Madec operator : slopes at u-, v-, and w-points + IF(lwp) WRITE(numout,*) ' ==>>> iso operator (Madec)' + ALLOCATE( omlmask(jpi,jpj,jpk) , & + & uslp(jpi,jpj,jpk) , uslpml(jpi,jpj) , wslpi(jpi,jpj,jpk) , wslpiml(jpi,jpj) , & + & vslp(jpi,jpj,jpk) , vslpml(jpi,jpj) , wslpj(jpi,jpj,jpk) , wslpjml(jpi,jpj) , STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Madec operator slope ' ) + + ! Direction of lateral diffusion (tracers and/or momentum) + ! ------------------------------ + uslp (:,:,:) = 0._wp ; uslpml (:,:) = 0._wp ! set the slope to zero (even in s-coordinates) + vslp (:,:,:) = 0._wp ; vslpml (:,:) = 0._wp + wslpi(:,:,:) = 0._wp ; wslpiml(:,:) = 0._wp + wslpj(:,:,:) = 0._wp ; wslpjml(:,:) = 0._wp + + !!gm I no longer understand this..... +!!gm IF( (ln_traldf_hor .OR. ln_dynldf_hor) .AND. .NOT. (.NOT.ln_linssh .AND. ln_rstart) ) THEN +! IF(lwp) WRITE(numout,*) ' Horizontal mixing in s-coordinate: slope = slope of s-surfaces' +! +! ! geopotential diffusion in s-coordinates on tracers and/or momentum +! ! The slopes of s-surfaces are computed once (no call to ldfslp in step) +! ! The slopes for momentum diffusion are i- or j- averaged of those on tracers +! +! ! set the slope of diffusion to the slope of s-surfaces +! ! ( c a u t i o n : minus sign as dep has positive value ) +! DO jk = 1, jpk +! DO jj = 2, jpjm1 +! DO ji = 2, jpim1 ! vector opt. +! uslp (ji,jj,jk) = - ( gdept(ji+1,jj,jk,Kmm) - gdept(ji ,jj ,jk,Kmm) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) +! vslp (ji,jj,jk) = - ( gdept(ji,jj+1,jk,Kmm) - gdept(ji ,jj ,jk,Kmm) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) +! wslpi(ji,jj,jk) = - ( gdepw(ji+1,jj,jk,Kmm) - gdepw(ji-1,jj,jk,Kmm) ) * r1_e1t(ji,jj) * wmask(ji,jj,jk) * 0.5 +! wslpj(ji,jj,jk) = - ( gdepw(ji,jj+1,jk,Kmm) - gdepw(ji,jj-1,jk,Kmm) ) * r1_e2t(ji,jj) * wmask(ji,jj,jk) * 0.5 +! END DO +! END DO +! END DO +! CALL lbc_lnk( 'ldfslp', uslp , 'U', -1. ; CALL lbc_lnk( 'ldfslp', vslp , 'V', -1., wslpi, 'W', -1., wslpj, 'W', -1. ) +!!gm ENDIF + ENDIF + ! + END SUBROUTINE ldf_slp_init + + !!====================================================================== +END MODULE ldfslp diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldftra.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldftra.F90 new file mode 100644 index 0000000..3958984 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/LDF/ldftra.F90 @@ -0,0 +1,900 @@ +MODULE ldftra + !!====================================================================== + !! *** MODULE ldftra *** + !! Ocean physics: lateral diffusivity coefficients + !!===================================================================== + !! History : ! 1997-07 (G. Madec) from inimix.F split in 2 routines + !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module + !! 2.0 ! 2005-11 (G. Madec) + !! 3.7 ! 2013-12 (F. Lemarie, G. Madec) restructuration/simplification of aht/aeiv specification, + !! ! add velocity dependent coefficient and optional read in file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! ldf_tra_init : initialization, namelist read, and parameters control + !! ldf_tra : update lateral eddy diffusivity coefficients at each time step + !! ldf_eiv_init : initialization of the eiv coeff. from namelist choices + !! ldf_eiv : time evolution of the eiv coefficients (function of the growth rate of baroclinic instability) + !! ldf_eiv_trp : add to the input ocean transport the contribution of the EIV parametrization + !! ldf_eiv_dia : diagnose the eddy induced velocity from the eiv streamfunction + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE ldfslp ! lateral diffusion: slope of iso-neutral surfaces + USE ldfc1d_c2d ! lateral diffusion: 1D & 2D cases + USE diaptr + ! + USE in_out_manager ! I/O manager + USE iom ! I/O module for ehanced bottom friction file + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC ldf_tra_init ! called by nemogcm.F90 + PUBLIC ldf_tra ! called by step.F90 + PUBLIC ldf_eiv_init ! called by nemogcm.F90 + PUBLIC ldf_eiv ! called by step.F90 + PUBLIC ldf_eiv_trp ! called by traadv.F90 + PUBLIC ldf_eiv_dia ! called by traldf_iso and traldf_iso_triad.F90 + + ! !!* Namelist namtra_ldf : lateral mixing on tracers * + ! != Operator type =! + LOGICAL , PUBLIC :: ln_traldf_OFF !: no operator: No explicit diffusion + LOGICAL , PUBLIC :: ln_traldf_lap !: laplacian operator + LOGICAL , PUBLIC :: ln_traldf_blp !: bilaplacian operator + ! != Direction of action =! + LOGICAL , PUBLIC :: ln_traldf_lev !: iso-level direction + LOGICAL , PUBLIC :: ln_traldf_hor !: horizontal (geopotential) direction +! LOGICAL , PUBLIC :: ln_traldf_iso !: iso-neutral direction (see ldfslp) + ! != iso-neutral options =! +! LOGICAL , PUBLIC :: ln_traldf_triad !: griffies triad scheme (see ldfslp) + LOGICAL , PUBLIC :: ln_traldf_msc !: Method of Stabilizing Correction +! LOGICAL , PUBLIC :: ln_triad_iso !: pure horizontal mixing in ML (see ldfslp) +! LOGICAL , PUBLIC :: ln_botmix_triad !: mixing on bottom (see ldfslp) +! REAL(wp), PUBLIC :: rn_sw_triad !: =1/0 switching triad / all 4 triads used (see ldfslp) +! REAL(wp), PUBLIC :: rn_slpmax !: slope limit (see ldfslp) + ! != Coefficients =! + INTEGER , PUBLIC :: nn_aht_ijk_t !: choice of time & space variations of the lateral eddy diffusivity coef. + ! ! time invariant coefficients: aht_0 = 1/2 Ud*Ld (lap case) + ! ! bht_0 = 1/12 Ud*Ld^3 (blp case) + REAL(wp), PUBLIC :: rn_Ud !: lateral diffusive velocity [m/s] + REAL(wp), PUBLIC :: rn_Ld !: lateral diffusive length [m] + + ! !!* Namelist namtra_eiv : eddy induced velocity param. * + ! != Use/diagnose eiv =! + LOGICAL , PUBLIC :: ln_ldfeiv !: eddy induced velocity flag + LOGICAL , PUBLIC :: ln_ldfeiv_dia !: diagnose & output eiv streamfunction and velocity (IOM) + ! != Coefficients =! + INTEGER , PUBLIC :: nn_aei_ijk_t !: choice of time/space variation of the eiv coeff. + REAL(wp), PUBLIC :: rn_Ue !: lateral diffusive velocity [m/s] + REAL(wp), PUBLIC :: rn_Le !: lateral diffusive length [m] + + ! ! Flag to control the type of lateral diffusive operator + INTEGER, PARAMETER, PUBLIC :: np_ERROR =-10 ! error in specification of lateral diffusion + INTEGER, PARAMETER, PUBLIC :: np_no_ldf = 00 ! without operator (i.e. no lateral diffusive trend) + ! !! laplacian ! bilaplacian ! + INTEGER, PARAMETER, PUBLIC :: np_lap = 10 , np_blp = 20 ! iso-level operator + INTEGER, PARAMETER, PUBLIC :: np_lap_i = 11 , np_blp_i = 21 ! standard iso-neutral or geopotential operator + INTEGER, PARAMETER, PUBLIC :: np_lap_it = 12 , np_blp_it = 22 ! triad iso-neutral or geopotential operator + + INTEGER , PUBLIC :: nldf_tra = 0 !: type of lateral diffusion used defined from ln_traldf_... (namlist logicals) + LOGICAL , PUBLIC :: l_ldftra_time = .FALSE. !: flag for time variation of the lateral eddy diffusivity coef. + LOGICAL , PUBLIC :: l_ldfeiv_time = .FALSE. !: flag for time variation of the eiv coef. + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahtu, ahtv !: eddy diffusivity coef. at U- and V-points [m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aeiu, aeiv !: eddy induced velocity coeff. [m2/s] + + REAL(wp) :: aht0, aei0 ! constant eddy coefficients (deduced from namelist values) [m2/s] + REAL(wp) :: r1_2 = 0.5_wp ! =1/2 + REAL(wp) :: r1_4 = 0.25_wp ! =1/4 + REAL(wp) :: r1_12 = 1._wp / 12._wp ! =1/12 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ldftra.F90 15475 2021-11-05 14:14:45Z cdllod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ldf_tra_init + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_tra_init *** + !! + !! ** Purpose : initializations of the tracer lateral mixing coeff. + !! + !! ** Method : * the eddy diffusivity coef. specification depends on: + !! + !! ln_traldf_lap = T laplacian operator + !! ln_traldf_blp = T bilaplacian operator + !! + !! nn_aht_ijk_t = 0 => = constant + !! ! + !! = 10 => = F(z) : constant with a reduction of 1/4 with depth + !! ! + !! =-20 => = F(i,j) = shape read in 'eddy_diffusivity_2D.nc' file + !! = 20 = F(i,j) = F(e1,e2) or F(e1^3,e2^3) (lap or bilap case) + !! = 21 = F(i,j,t) = F(growth rate of baroclinic instability) + !! ! + !! =-30 => = F(i,j,k) = shape read in 'eddy_diffusivity_3D.nc' file + !! = 30 = F(i,j,k) = 2D (case 20) + decrease with depth (case 10) + !! = 31 = F(i,j,k,t) = F(local velocity) ( 1/2 |u|e laplacian operator + !! or 1/12 |u|e^3 bilaplacian operator ) + !! * initialisation of the eddy induced velocity coefficient by a call to ldf_eiv_init + !! + !! ** action : ahtu, ahtv initialized one for all or l_ldftra_time set to true + !! aeiu, aeiv initialized one for all or l_ldfeiv_time set to true + !!---------------------------------------------------------------------- + INTEGER :: jk ! dummy loop indices + INTEGER :: ioptio, ierr, inum, ios, inn ! local integer + REAL(wp) :: zah_max, zUfac ! - - + CHARACTER(len=5) :: cl_Units ! units (m2/s or m4/s) + !! + NAMELIST/namtra_ldf/ ln_traldf_OFF, ln_traldf_lap , ln_traldf_blp , & ! type of operator + & ln_traldf_lev, ln_traldf_hor , ln_traldf_triad, & ! acting direction of the operator + & ln_traldf_iso, ln_traldf_msc , rn_slpmax , & ! option for iso-neutral operator + & ln_triad_iso , ln_botmix_triad, rn_sw_triad , & ! option for triad operator + & nn_aht_ijk_t , rn_Ud , rn_Ld ! lateral eddy coefficient + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ldf_tra_init : lateral tracer diffusion' + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + + ! + ! Choice of lateral tracer physics + ! ================================= + ! + READ ( numnam_ref, namtra_ldf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_ldf in reference namelist' ) + READ ( numnam_cfg, namtra_ldf, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_ldf in configuration namelist' ) + IF(lwm) WRITE( numond, namtra_ldf ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist : namtra_ldf --- lateral mixing parameters (type, direction, coefficients)' + WRITE(numout,*) ' type :' + WRITE(numout,*) ' no explicit diffusion ln_traldf_OFF = ', ln_traldf_OFF + WRITE(numout,*) ' laplacian operator ln_traldf_lap = ', ln_traldf_lap + WRITE(numout,*) ' bilaplacian operator ln_traldf_blp = ', ln_traldf_blp + WRITE(numout,*) ' direction of action :' + WRITE(numout,*) ' iso-level ln_traldf_lev = ', ln_traldf_lev + WRITE(numout,*) ' horizontal (geopotential) ln_traldf_hor = ', ln_traldf_hor + WRITE(numout,*) ' iso-neutral Madec operator ln_traldf_iso = ', ln_traldf_iso + WRITE(numout,*) ' iso-neutral triad operator ln_traldf_triad = ', ln_traldf_triad + WRITE(numout,*) ' use the Method of Stab. Correction ln_traldf_msc = ', ln_traldf_msc + WRITE(numout,*) ' maximum isoppycnal slope rn_slpmax = ', rn_slpmax + WRITE(numout,*) ' pure lateral mixing in ML ln_triad_iso = ', ln_triad_iso + WRITE(numout,*) ' switching triad or not rn_sw_triad = ', rn_sw_triad + WRITE(numout,*) ' lateral mixing on bottom ln_botmix_triad = ', ln_botmix_triad + WRITE(numout,*) ' coefficients :' + WRITE(numout,*) ' type of time-space variation nn_aht_ijk_t = ', nn_aht_ijk_t + WRITE(numout,*) ' lateral diffusive velocity (if cst) rn_Ud = ', rn_Ud, ' m/s' + WRITE(numout,*) ' lateral diffusive length (if cst) rn_Ld = ', rn_Ld, ' m' + ENDIF + ! + ! + ! Operator and its acting direction (set nldf_tra) + ! ================================= + ! + nldf_tra = np_ERROR + ioptio = 0 + IF( ln_traldf_OFF ) THEN ; nldf_tra = np_no_ldf ; ioptio = ioptio + 1 ; ENDIF + IF( ln_traldf_lap ) THEN ; ioptio = ioptio + 1 ; ENDIF + IF( ln_traldf_blp ) THEN ; ioptio = ioptio + 1 ; ENDIF + IF( ioptio /= 1 ) CALL ctl_stop( 'tra_ldf_init: use ONE of the 3 operator options (NONE/lap/blp)' ) + ! + IF( .NOT.ln_traldf_OFF ) THEN !== direction ==>> type of operator ==! + ioptio = 0 + IF( ln_traldf_lev ) ioptio = ioptio + 1 + IF( ln_traldf_hor ) ioptio = ioptio + 1 + IF( ln_traldf_iso ) ioptio = ioptio + 1 + IF( ln_traldf_triad ) ioptio = ioptio + 1 + IF( ioptio /= 1 ) CALL ctl_stop( 'tra_ldf_init: use ONE direction (level/hor/iso/triad)' ) + ! + ! ! defined the type of lateral diffusion from ln_traldf_... logicals + ierr = 0 + IF ( ln_traldf_lap ) THEN ! laplacian operator + IF ( ln_zco ) THEN ! z-coordinate + IF ( ln_traldf_lev ) nldf_tra = np_lap ! iso-level = horizontal (no rotation) + IF ( ln_traldf_hor ) nldf_tra = np_lap ! iso-level = horizontal (no rotation) + IF ( ln_traldf_iso ) nldf_tra = np_lap_i ! iso-neutral: standard ( rotation) + IF ( ln_traldf_triad ) nldf_tra = np_lap_it ! iso-neutral: triad ( rotation) + ENDIF + IF ( ln_zps ) THEN ! z-coordinate with partial step + IF ( ln_traldf_lev ) ierr = 1 ! iso-level not allowed + IF ( ln_traldf_hor ) nldf_tra = np_lap ! horizontal (no rotation) + IF ( ln_traldf_iso ) nldf_tra = np_lap_i ! iso-neutral: standard (rotation) + IF ( ln_traldf_triad ) nldf_tra = np_lap_it ! iso-neutral: triad (rotation) + ENDIF + IF ( ln_sco ) THEN ! s-coordinate + IF ( ln_traldf_lev ) nldf_tra = np_lap ! iso-level (no rotation) + IF ( ln_traldf_hor ) nldf_tra = np_lap_i ! horizontal ( rotation) + IF ( ln_traldf_iso ) nldf_tra = np_lap_i ! iso-neutral: standard ( rotation) + IF ( ln_traldf_triad ) nldf_tra = np_lap_it ! iso-neutral: triad ( rotation) + ENDIF + ENDIF + ! + IF( ln_traldf_blp ) THEN ! bilaplacian operator + IF ( ln_zco ) THEN ! z-coordinate + IF ( ln_traldf_lev ) nldf_tra = np_blp ! iso-level = horizontal (no rotation) + IF ( ln_traldf_hor ) nldf_tra = np_blp ! iso-level = horizontal (no rotation) + IF ( ln_traldf_iso ) nldf_tra = np_blp_i ! iso-neutral: standard ( rotation) + IF ( ln_traldf_triad ) nldf_tra = np_blp_it ! iso-neutral: triad ( rotation) + ENDIF + IF ( ln_zps ) THEN ! z-coordinate with partial step + IF ( ln_traldf_lev ) ierr = 1 ! iso-level not allowed + IF ( ln_traldf_hor ) nldf_tra = np_blp ! horizontal (no rotation) + IF ( ln_traldf_iso ) nldf_tra = np_blp_i ! iso-neutral: standard ( rotation) + IF ( ln_traldf_triad ) nldf_tra = np_blp_it ! iso-neutral: triad ( rotation) + ENDIF + IF ( ln_sco ) THEN ! s-coordinate + IF ( ln_traldf_lev ) nldf_tra = np_blp ! iso-level (no rotation) + IF ( ln_traldf_hor ) nldf_tra = np_blp_it ! horizontal ( rotation) + IF ( ln_traldf_iso ) nldf_tra = np_blp_i ! iso-neutral: standard ( rotation) + IF ( ln_traldf_triad ) nldf_tra = np_blp_it ! iso-neutral: triad ( rotation) + ENDIF + ENDIF + IF ( ierr == 1 ) CALL ctl_stop( 'iso-level in z-partial step, not allowed' ) + ENDIF + ! + IF( ln_isfcav .AND. ln_traldf_triad ) CALL ctl_stop( ' ice shelf cavity and traldf_triad not tested' ) + ! + IF( nldf_tra == np_lap_i .OR. nldf_tra == np_lap_it .OR. & + & nldf_tra == np_blp_i .OR. nldf_tra == np_blp_it ) l_ldfslp = .TRUE. ! slope of neutral surfaces required + ! + IF( ln_traldf_blp .AND. ( ln_traldf_iso .OR. ln_traldf_triad) ) THEN ! iso-neutral bilaplacian need MSC + IF( .NOT.ln_traldf_msc ) CALL ctl_stop( 'tra_ldf_init: iso-neutral bilaplacian requires ln_traldf_msc=.true.' ) + ENDIF + ! + IF(lwp) THEN + WRITE(numout,*) + SELECT CASE( nldf_tra ) + CASE( np_no_ldf ) ; WRITE(numout,*) ' ==>>> NO lateral diffusion' + CASE( np_lap ) ; WRITE(numout,*) ' ==>>> laplacian iso-level operator' + CASE( np_lap_i ) ; WRITE(numout,*) ' ==>>> Rotated laplacian operator (standard)' + CASE( np_lap_it ) ; WRITE(numout,*) ' ==>>> Rotated laplacian operator (triad)' + CASE( np_blp ) ; WRITE(numout,*) ' ==>>> bilaplacian iso-level operator' + CASE( np_blp_i ) ; WRITE(numout,*) ' ==>>> Rotated bilaplacian operator (standard)' + CASE( np_blp_it ) ; WRITE(numout,*) ' ==>>> Rotated bilaplacian operator (triad)' + END SELECT + WRITE(numout,*) + ENDIF + + ! + ! Space/time variation of eddy coefficients + ! =========================================== + ! + l_ldftra_time = .FALSE. ! no time variation except in case defined below + ! + IF( ln_traldf_OFF ) THEN !== no explicit diffusive operator ==! + ! + IF(lwp) WRITE(numout,*) ' ==>>> No diffusive operator selected. ahtu and ahtv are not allocated' + RETURN + ! + ELSE !== a lateral diffusion operator is used ==! + ! + ! ! allocate the aht arrays + ALLOCATE( ahtu(jpi,jpj,jpk) , ahtv(jpi,jpj,jpk) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'ldf_tra_init: failed to allocate arrays') + ! + ahtu(:,:,jpk) = 0._wp ! last level always 0 + ahtv(:,:,jpk) = 0._wp + !. + ! ! value of lap/blp eddy mixing coef. + IF( ln_traldf_lap ) THEN ; zUfac = r1_2 *rn_Ud ; inn = 1 ; cl_Units = ' m2/s' ! laplacian + ELSEIF( ln_traldf_blp ) THEN ; zUfac = r1_12*rn_Ud ; inn = 3 ; cl_Units = ' m4/s' ! bilaplacian + ENDIF + aht0 = zUfac * rn_Ld**inn ! mixing coefficient + zah_max = zUfac * (ra*rad)**inn ! maximum reachable coefficient (value at the Equator for e1=1 degree) + ! + ! + SELECT CASE( nn_aht_ijk_t ) !* Specification of space-time variations of ahtu, ahtv + ! + CASE( 0 ) !== constant ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = constant = ', aht0, cl_Units + ahtu(:,:,1:jpkm1) = aht0 + ahtv(:,:,1:jpkm1) = aht0 + ! + CASE( 10 ) !== fixed profile ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F( depth )' + IF(lwp) WRITE(numout,*) ' surface eddy diffusivity = constant = ', aht0, cl_Units + ahtu(:,:,1) = aht0 ! constant surface value + ahtv(:,:,1) = aht0 + CALL ldf_c1d( 'TRA', ahtu(:,:,1), ahtv(:,:,1), ahtu, ahtv ) + ! + CASE ( -20 ) !== fixed horizontal shape and magnitude read in file ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F(i,j) read in eddy_diffusivity.nc file' + CALL iom_open( 'eddy_diffusivity_2D.nc', inum ) + CALL iom_get ( inum, jpdom_global, 'ahtu_2D', ahtu(:,:,1), cd_type = 'U', psgn = 1._dp ) + CALL iom_get ( inum, jpdom_global, 'ahtv_2D', ahtv(:,:,1), cd_type = 'V', psgn = 1._dp ) + CALL iom_close( inum ) + DO jk = 2, jpkm1 + ahtu(:,:,jk) = ahtu(:,:,1) + ahtv(:,:,jk) = ahtv(:,:,1) + END DO + ! + CASE( 20 ) !== fixed horizontal shape ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F( e1, e2 ) or F( e1^3, e2^3 ) (lap or blp case)' + IF(lwp) WRITE(numout,*) ' using a fixed diffusive velocity = ', rn_Ud,' m/s and Ld = Max(e1,e2)' + IF(lwp) WRITE(numout,*) ' maximum reachable coefficient (at the Equator) = ', zah_max, cl_Units, ' for e1=1°)' + CALL ldf_c2d( 'TRA', zUfac , inn , ahtu, ahtv ) ! value proportional to scale factor^inn + ! + CASE( 21 ) !== time varying 2D field ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F( latitude, longitude, time )' + IF(lwp) WRITE(numout,*) ' = F( growth rate of baroclinic instability )' + IF(lwp) WRITE(numout,*) ' min value = 0.2 * aht0 (with aht0= 1/2 rn_Ud*rn_Ld)' + IF(lwp) WRITE(numout,*) ' max value = aei0 (with aei0=1/2 rn_Ue*Le increased to aht0 within 20N-20S' + ! + l_ldftra_time = .TRUE. ! will be calculated by call to ldf_tra routine in step.F90 + ! + IF( ln_traldf_blp ) CALL ctl_stop( 'ldf_tra_init: aht=F( growth rate of baroc. insta .)', & + & ' incompatible with bilaplacian operator' ) + ! + CASE( -30 ) !== fixed 3D shape read in file ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F(i,j,k) read in eddy_diffusivity.nc file' + CALL iom_open( 'eddy_diffusivity_3D.nc', inum ) + CALL iom_get ( inum, jpdom_global, 'ahtu_3D', ahtu, cd_type = 'U', psgn = 1._dp ) + CALL iom_get ( inum, jpdom_global, 'ahtv_3D', ahtv, cd_type = 'V', psgn = 1._dp ) + CALL iom_close( inum ) + ! + CASE( 30 ) !== fixed 3D shape ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F( latitude, longitude, depth )' + IF(lwp) WRITE(numout,*) ' using a fixed diffusive velocity = ', rn_Ud,' m/s and Ld = Max(e1,e2)' + IF(lwp) WRITE(numout,*) ' maximum reachable coefficient (at the Equator) = ', zah_max, cl_Units, ' for e1=1°)' + CALL ldf_c2d( 'TRA', zUfac , inn , ahtu, ahtv ) ! surface value proportional to scale factor^inn + CALL ldf_c1d( 'TRA', ahtu(:,:,1), ahtv(:,:,1), ahtu, ahtv ) ! reduction with depth + ! + CASE( 31 ) !== time varying 3D field ==! + IF(lwp) WRITE(numout,*) ' ==>>> eddy diffusivity = F( latitude, longitude, depth , time )' + IF(lwp) WRITE(numout,*) ' proportional to the velocity : 1/2 |u|e or 1/12 |u|e^3' + ! + l_ldftra_time = .TRUE. ! will be calculated by call to ldf_tra routine in step.F90 + ! + CASE DEFAULT + CALL ctl_stop('ldf_tra_init: wrong choice for nn_aht_ijk_t, the type of space-time variation of aht') + END SELECT + ! + IF( .NOT.l_ldftra_time ) THEN !* No time variation + IF( ln_traldf_lap ) THEN ! laplacian operator (mask only) + ahtu(:,:,1:jpkm1) = ahtu(:,:,1:jpkm1) * umask(:,:,1:jpkm1) + ahtv(:,:,1:jpkm1) = ahtv(:,:,1:jpkm1) * vmask(:,:,1:jpkm1) + ELSEIF( ln_traldf_blp ) THEN ! bilaplacian operator (square root + mask) + ahtu(:,:,1:jpkm1) = SQRT( ahtu(:,:,1:jpkm1) ) * umask(:,:,1:jpkm1) + ahtv(:,:,1:jpkm1) = SQRT( ahtv(:,:,1:jpkm1) ) * vmask(:,:,1:jpkm1) + ENDIF + ENDIF + ! + ENDIF + ! + END SUBROUTINE ldf_tra_init + + + SUBROUTINE ldf_tra( kt, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_tra *** + !! + !! ** Purpose : update at kt the tracer lateral mixing coeff. (aht and aeiv) + !! + !! ** Method : * time varying eddy diffusivity coefficients: + !! + !! nn_aei_ijk_t = 21 aeiu, aeiv = F(i,j, t) = F(growth rate of baroclinic instability) + !! with a reduction to 0 in vicinity of the Equator + !! nn_aht_ijk_t = 21 ahtu, ahtv = F(i,j, t) = F(growth rate of baroclinic instability) + !! + !! = 31 ahtu, ahtv = F(i,j,k,t) = F(local velocity) ( |u|e /12 laplacian operator + !! or |u|e^3/12 bilaplacian operator ) + !! + !! * time varying EIV coefficients: call to ldf_eiv routine + !! + !! ** action : ahtu, ahtv update at each time step + !! aeiu, aeiv - - - - (if ln_ldfeiv=T) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zaht, zahf, zaht_min, zDaht, z1_f20 ! local scalar + !!---------------------------------------------------------------------- + ! + IF( ln_ldfeiv .AND. nn_aei_ijk_t == 21 ) THEN ! eddy induced velocity coefficients + ! ! =F(growth rate of baroclinic instability) + ! ! max value aeiv_0 ; decreased to 0 within 20N-20S + CALL ldf_eiv( kt, aei0, aeiu, aeiv, Kmm ) + ENDIF + ! + SELECT CASE( nn_aht_ijk_t ) ! Eddy diffusivity coefficients + ! + CASE( 21 ) !== time varying 2D field ==! = F( growth rate of baroclinic instability ) + ! ! min value 0.2*aht0 + ! ! max value aht0 (aei0 if nn_aei_ijk_t=21) + ! ! increase to aht0 within 20N-20S + IF( ln_ldfeiv .AND. nn_aei_ijk_t == 21 ) THEN ! use the already computed aei. + ahtu(:,:,1) = aeiu(:,:,1) + ahtv(:,:,1) = aeiv(:,:,1) + ELSE ! compute aht. + CALL ldf_eiv( kt, aht0, ahtu, ahtv, Kmm ) + ENDIF + ! + z1_f20 = 1._wp / ( 2._wp * omega * SIN( rad * 20._wp ) ) ! 1 / ff(20 degrees) + zaht_min = 0.2_wp * aht0 ! minimum value for aht + zDaht = aht0 - zaht_min + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + !!gm CAUTION : here we assume lat/lon grid in 20deg N/S band (like all ORCA cfg) + !! ==>>> The Coriolis value is identical for t- & u_points, and for v- and f-points + zaht = ( 1._wp - MIN( 1._wp , ABS( ff_t(ji,jj) * z1_f20 ) ) ) * zDaht + zahf = ( 1._wp - MIN( 1._wp , ABS( ff_f(ji,jj) * z1_f20 ) ) ) * zDaht + ahtu(ji,jj,1) = ( MAX( zaht_min, ahtu(ji,jj,1) ) + zaht ) ! min value zaht_min + ahtv(ji,jj,1) = ( MAX( zaht_min, ahtv(ji,jj,1) ) + zahf ) ! increase within 20S-20N + END_2D + DO jk = 1, jpkm1 ! deeper value = surface value + mask for all levels + ahtu(:,:,jk) = ahtu(:,:,1) * umask(:,:,jk) + ahtv(:,:,jk) = ahtv(:,:,1) * vmask(:,:,jk) + END DO + ! + CASE( 31 ) !== time varying 3D field ==! = F( local velocity ) + IF( ln_traldf_lap ) THEN ! laplacian operator |u| e /12 + DO jk = 1, jpkm1 + ahtu(:,:,jk) = ABS( uu(:,:,jk,Kbb) ) * e1u(:,:) * r1_12 ! n.b. uu,vv are masked + ahtv(:,:,jk) = ABS( vv(:,:,jk,Kbb) ) * e2v(:,:) * r1_12 + END DO + ELSEIF( ln_traldf_blp ) THEN ! bilaplacian operator sqrt( |u| e^3 /12 ) = sqrt( |u| e /12 ) * e + DO jk = 1, jpkm1 + ahtu(:,:,jk) = SQRT( ABS( uu(:,:,jk,Kbb) ) * e1u(:,:) * r1_12 ) * e1u(:,:) + ahtv(:,:,jk) = SQRT( ABS( vv(:,:,jk,Kbb) ) * e2v(:,:) * r1_12 ) * e2v(:,:) + END DO + ENDIF + ! + END SELECT + ! + CALL iom_put( "ahtu_2d", ahtu(:,:,1) ) ! surface u-eddy diffusivity coeff. + CALL iom_put( "ahtv_2d", ahtv(:,:,1) ) ! surface v-eddy diffusivity coeff. + CALL iom_put( "ahtu_3d", ahtu(:,:,:) ) ! 3D u-eddy diffusivity coeff. + CALL iom_put( "ahtv_3d", ahtv(:,:,:) ) ! 3D v-eddy diffusivity coeff. + ! + IF( ln_ldfeiv ) THEN + CALL iom_put( "aeiu_2d", aeiu(:,:,1) ) ! surface u-EIV coeff. + CALL iom_put( "aeiv_2d", aeiv(:,:,1) ) ! surface v-EIV coeff. + CALL iom_put( "aeiu_3d", aeiu(:,:,:) ) ! 3D u-EIV coeff. + CALL iom_put( "aeiv_3d", aeiv(:,:,:) ) ! 3D v-EIV coeff. + ENDIF + ! + END SUBROUTINE ldf_tra + + + SUBROUTINE ldf_eiv_init + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_eiv_init *** + !! + !! ** Purpose : initialization of the eiv coeff. from namelist choices. + !! + !! ** Method : the eiv diffusivity coef. specification depends on: + !! nn_aei_ijk_t = 0 => = constant + !! ! + !! = 10 => = F(z) : constant with a reduction of 1/4 with depth + !! ! + !! =-20 => = F(i,j) = shape read in 'eddy_induced_velocity_2D.nc' file + !! = 20 = F(i,j) = F(e1,e2) or F(e1^3,e2^3) (lap or bilap case) + !! = 21 = F(i,j,t) = F(growth rate of baroclinic instability) + !! ! + !! =-30 => = F(i,j,k) = shape read in 'eddy_induced_velocity_3D.nc' file + !! = 30 = F(i,j,k) = 2D (case 20) + decrease with depth (case 10) + !! + !! ** Action : aeiu , aeiv : initialized one for all or l_ldftra_time set to true + !! l_ldfeiv_time : =T if EIV coefficients vary with time + !!---------------------------------------------------------------------- + INTEGER :: jk ! dummy loop indices + INTEGER :: ierr, inum, ios, inn ! local integer + REAL(wp) :: zah_max, zUfac ! - scalar + !! + NAMELIST/namtra_eiv/ ln_ldfeiv , ln_ldfeiv_dia, & ! eddy induced velocity (eiv) + & nn_aei_ijk_t, rn_Ue, rn_Le ! eiv coefficient + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'ldf_eiv_init : eddy induced velocity parametrization' + WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + ! + READ ( numnam_ref, namtra_eiv, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_eiv in reference namelist' ) + ! + READ ( numnam_cfg, namtra_eiv, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_eiv in configuration namelist' ) + IF(lwm) WRITE ( numond, namtra_eiv ) + + IF(lwp) THEN ! control print + WRITE(numout,*) ' Namelist namtra_eiv : ' + WRITE(numout,*) ' Eddy Induced Velocity (eiv) param. ln_ldfeiv = ', ln_ldfeiv + WRITE(numout,*) ' eiv streamfunction & velocity diag. ln_ldfeiv_dia = ', ln_ldfeiv_dia + WRITE(numout,*) ' coefficients :' + WRITE(numout,*) ' type of time-space variation nn_aei_ijk_t = ', nn_aei_ijk_t + WRITE(numout,*) ' lateral diffusive velocity (if cst) rn_Ue = ', rn_Ue, ' m/s' + WRITE(numout,*) ' lateral diffusive length (if cst) rn_Le = ', rn_Le, ' m' + WRITE(numout,*) + ENDIF + ! + l_ldfeiv_time = .FALSE. ! no time variation except in case defined below + ! + ! + IF( .NOT.ln_ldfeiv ) THEN !== Parametrization not used ==! + ! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity param is NOT used' + ln_ldfeiv_dia = .FALSE. + ! + ELSE !== use the parametrization ==! + ! + IF(lwp) WRITE(numout,*) ' ==>>> use eddy induced velocity parametrization' + IF(lwp) WRITE(numout,*) + ! + IF( ln_traldf_blp ) CALL ctl_stop( 'ldf_eiv_init: eddy induced velocity ONLY with laplacian diffusivity' ) + ! + IF( .NOT.( ln_traldf_iso .OR. ln_traldf_triad ) ) & + & CALL ctl_stop( 'ln_ldfeiv=T requires iso-neutral laplacian diffusion' ) + ! != allocate the aei arrays + ALLOCATE( aeiu(jpi,jpj,jpk), aeiv(jpi,jpj,jpk), STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop('STOP', 'ldf_eiv: failed to allocate arrays') + ! + ! != Specification of space-time variations of eaiu, aeiv + ! + aeiu(:,:,jpk) = 0._wp ! last level always 0 + aeiv(:,:,jpk) = 0._wp + ! ! value of EIV coef. (laplacian operator) + zUfac = r1_2 *rn_Ue ! velocity factor + inn = 1 ! L-exponent + aei0 = zUfac * rn_Le**inn ! mixing coefficient + zah_max = zUfac * (ra*rad)**inn ! maximum reachable coefficient (value at the Equator) + + SELECT CASE( nn_aei_ijk_t ) !* Specification of space-time variations + ! + CASE( 0 ) !-- constant --! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = constant = ', aei0, ' m2/s' + aeiu(:,:,1:jpkm1) = aei0 + aeiv(:,:,1:jpkm1) = aei0 + ! + CASE( 10 ) !-- fixed profile --! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F( depth )' + IF(lwp) WRITE(numout,*) ' surface eddy diffusivity = constant = ', aht0, ' m2/s' + aeiu(:,:,1) = aei0 ! constant surface value + aeiv(:,:,1) = aei0 + CALL ldf_c1d( 'TRA', aeiu(:,:,1), aeiv(:,:,1), aeiu, aeiv ) + ! + CASE ( -20 ) !-- fixed horizontal shape read in file --! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F(i,j) read in eddy_diffusivity_2D.nc file' + CALL iom_open ( 'eddy_induced_velocity_2D.nc', inum ) + CALL iom_get ( inum, jpdom_global, 'aeiu', aeiu(:,:,1), cd_type = 'U', psgn = 1._dp ) + CALL iom_get ( inum, jpdom_global, 'aeiv', aeiv(:,:,1), cd_type = 'V', psgn = 1._dp ) + CALL iom_close( inum ) + DO jk = 2, jpkm1 + aeiu(:,:,jk) = aeiu(:,:,1) + aeiv(:,:,jk) = aeiv(:,:,1) + END DO + ! + CASE( 20 ) !-- fixed horizontal shape --! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F( e1, e2 )' + IF(lwp) WRITE(numout,*) ' using a fixed diffusive velocity = ', rn_Ue, ' m/s and Le = Max(e1,e2)' + IF(lwp) WRITE(numout,*) ' maximum reachable coefficient (at the Equator) = ', zah_max, ' m2/s for e1=1°)' + CALL ldf_c2d( 'TRA', zUfac , inn , aeiu, aeiv ) ! value proportional to scale factor^inn + ! + CASE( 21 ) !-- time varying 2D field --! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F( latitude, longitude, time )' + IF(lwp) WRITE(numout,*) ' = F( growth rate of baroclinic instability )' + IF(lwp) WRITE(numout,*) ' maximum allowed value: aei0 = ', aei0, ' m2/s' + ! + l_ldfeiv_time = .TRUE. ! will be calculated by call to ldf_tra routine in step.F90 + ! + CASE( -30 ) !-- fixed 3D shape read in file --! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F(i,j,k) read in eddy_diffusivity_3D.nc file' + CALL iom_open ( 'eddy_induced_velocity_3D.nc', inum ) + CALL iom_get ( inum, jpdom_global, 'aeiu', aeiu, cd_type = 'U', psgn = 1._dp ) + CALL iom_get ( inum, jpdom_global, 'aeiv', aeiv, cd_type = 'V', psgn = 1._dp ) + CALL iom_close( inum ) + ! + CASE( 30 ) !-- fixed 3D shape --! + IF(lwp) WRITE(numout,*) ' ==>>> eddy induced velocity coef. = F( latitude, longitude, depth )' + CALL ldf_c2d( 'TRA', zUfac , inn , aeiu, aeiv ) ! surface value proportional to scale factor^inn + CALL ldf_c1d( 'TRA', aeiu(:,:,1), aeiv(:,:,1), aeiu, aeiv ) ! reduction with depth + ! + CASE DEFAULT + CALL ctl_stop('ldf_tra_init: wrong choice for nn_aei_ijk_t, the type of space-time variation of aei') + END SELECT + ! + IF( .NOT.l_ldfeiv_time ) THEN !* mask if No time variation + DO jk = 1, jpkm1 + aeiu(:,:,jk) = aeiu(:,:,jk) * umask(:,:,jk) + aeiv(:,:,jk) = aeiv(:,:,jk) * vmask(:,:,jk) + END DO + ENDIF + ! + ENDIF + ! + END SUBROUTINE ldf_eiv_init + + + SUBROUTINE ldf_eiv( kt, paei0, paeiu, paeiv, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_eiv *** + !! + !! ** Purpose : Compute the eddy induced velocity coefficient from the + !! growth rate of baroclinic instability. + !! + !! ** Method : coefficient function of the growth rate of baroclinic instability + !! + !! Reference : Treguier et al. JPO 1997 ; Held and Larichev JAS 1996 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level indices + REAL(wp) , INTENT(in ) :: paei0 ! max value [m2/s] + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: paeiu, paeiv ! eiv coefficient [m2/s] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zfw, ze3w, zn2, z1_f20, zzaei ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zn, zah, zhw, zRo, zaeiw ! 2D workspace + !!---------------------------------------------------------------------- + ! + zn (:,:) = 0._wp ! Local initialization + zhw(:,:) = 5._wp + zah(:,:) = 0._wp + zRo(:,:) = 0._wp + ! ! Compute lateral diffusive coefficient at T-point + IF( ln_traldf_triad ) THEN + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + ! Take the max of N^2 and zero then take the vertical sum + ! of the square root of the resulting N^2 ( required to compute + ! internal Rossby radius Ro = .5 * sum_jpk(N) / f + zn2 = MAX( rn2b(ji,jj,jk), 0._wp ) + zn(ji,jj) = zn(ji,jj) + SQRT( zn2 ) * e3w(ji,jj,jk,Kmm) + ! Compute elements required for the inverse time scale of baroclinic + ! eddies using the isopycnal slopes calculated in ldfslp.F : + ! T^-1 = sqrt(m_jpk(N^2*(r1^2+r2^2)*e3w)) + ze3w = e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) + zah(ji,jj) = zah(ji,jj) + zn2 * wslp2(ji,jj,jk) * ze3w + zhw(ji,jj) = zhw(ji,jj) + ze3w + END_3D + ELSE + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + ! Take the max of N^2 and zero then take the vertical sum + ! of the square root of the resulting N^2 ( required to compute + ! internal Rossby radius Ro = .5 * sum_jpk(N) / f + zn2 = MAX( rn2b(ji,jj,jk), 0._wp ) + zn(ji,jj) = zn(ji,jj) + SQRT( zn2 ) * e3w(ji,jj,jk,Kmm) + ! Compute elements required for the inverse time scale of baroclinic + ! eddies using the isopycnal slopes calculated in ldfslp.F : + ! T^-1 = sqrt(m_jpk(N^2*(r1^2+r2^2)*e3w)) + ze3w = e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) + zah(ji,jj) = zah(ji,jj) + zn2 * ( wslpi(ji,jj,jk) * wslpi(ji,jj,jk) & + & + wslpj(ji,jj,jk) * wslpj(ji,jj,jk) ) * ze3w + zhw(ji,jj) = zhw(ji,jj) + ze3w + END_3D + ENDIF + + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zfw = MAX( ABS( 2. * omega * SIN( rad * gphit(ji,jj) ) ) , 1.e-10 ) + ! Rossby radius at w-point taken betwenn 2 km and 40km + zRo(ji,jj) = MAX( 2.e3 , MIN( .4 * zn(ji,jj) / zfw, 40.e3 ) ) + ! Compute aeiw by multiplying Ro^2 and T^-1 + zaeiw(ji,jj) = zRo(ji,jj) * zRo(ji,jj) * SQRT( zah(ji,jj) / zhw(ji,jj) ) * tmask(ji,jj,1) + END_2D + + ! !== Bound on eiv coeff. ==! + z1_f20 = 1._wp / ( 2._wp * omega * sin( rad * 20._wp ) ) + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zzaei = MIN( 1._wp, ABS( ff_t(ji,jj) * z1_f20 ) ) * zaeiw(ji,jj) ! tropical decrease + zaeiw(ji,jj) = MIN( zzaei , paei0 ) ! Max value = paei0 + END_2D + IF( nn_hls == 1 ) CALL lbc_lnk( 'ldftra', zaeiw(:,:), 'W', 1.0_wp ) ! lateral boundary condition + ! + DO_2D( 0, 0, 0, 0 ) + paeiu(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji+1,jj ) ) * umask(ji,jj,1) + paeiv(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji ,jj+1) ) * vmask(ji,jj,1) + END_2D + CALL lbc_lnk( 'ldftra', paeiu(:,:,1), 'U', 1.0_wp , paeiv(:,:,1), 'V', 1.0_wp ) ! lateral boundary condition + + DO jk = 2, jpkm1 !== deeper values equal the surface one ==! + paeiu(:,:,jk) = paeiu(:,:,1) * umask(:,:,jk) + paeiv(:,:,jk) = paeiv(:,:,1) * vmask(:,:,jk) + END DO + ! + END SUBROUTINE ldf_eiv + + + SUBROUTINE ldf_eiv_trp( kt, kit000, pu, pv, pw, cdtype, Kmm, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_eiv_trp *** + !! + !! ** Purpose : add to the input ocean transport the contribution of + !! the eddy induced velocity parametrization. + !! + !! ** Method : The eddy induced transport is computed from a flux stream- + !! function which depends on the slope of iso-neutral surfaces + !! (see ldf_slp). For example, in the i-k plan : + !! psi_uw = mk(aeiu) e2u mi(wslpi) [in m3/s] + !! Utr_eiv = - dk[psi_uw] + !! Vtr_eiv = + di[psi_uw] + !! ln_ldfeiv_dia = T : output the associated streamfunction, + !! velocity and heat transport (call ldf_eiv_dia) + !! + !! ** Action : pu, pv increased by the eiv transport + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + ! TEMP: [tiling] Can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu ! in : 3 ocean transport components [m3/s] + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pv ! out: 3 ocean transport components [m3/s] + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the eiv [m3/s] + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zuwk, zuwk1, zuwi, zuwi1 ! local scalars + REAL(wp) :: zvwk, zvwk1, zvwj, zvwj1 ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ldf_eiv_trp : eddy induced advection on ', cdtype,' :' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ add to velocity fields the eiv component' + ENDIF + ENDIF + + + zpsi_uw(:,:, 1 ) = 0._wp ; zpsi_vw(:,:, 1 ) = 0._wp + zpsi_uw(:,:,jpk) = 0._wp ; zpsi_vw(:,:,jpk) = 0._wp + ! + DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 2, jpkm1 ) + zpsi_uw(ji,jj,jk) = - r1_4 * e2u(ji,jj) * ( wslpi(ji,jj,jk ) + wslpi(ji+1,jj,jk) ) & + & * ( aeiu (ji,jj,jk-1) + aeiu (ji ,jj,jk) ) * wumask(ji,jj,jk) + zpsi_vw(ji,jj,jk) = - r1_4 * e1v(ji,jj) * ( wslpj(ji,jj,jk ) + wslpj(ji,jj+1,jk) ) & + & * ( aeiv (ji,jj,jk-1) + aeiv (ji,jj ,jk) ) * wvmask(ji,jj,jk) + END_3D + ! + DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) + pu(ji,jj,jk) = pu(ji,jj,jk) - ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) ) + pv(ji,jj,jk) = pv(ji,jj,jk) - ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) ) + END_3D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + pw(ji,jj,jk) = pw(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji-1,jj ,jk) & + & + zpsi_vw(ji,jj,jk) - zpsi_vw(ji ,jj-1,jk) ) + END_3D + ! + ! ! diagnose the eddy induced velocity and associated heat transport + IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' ) CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) + ! + END SUBROUTINE ldf_eiv_trp + + + SUBROUTINE ldf_eiv_dia( psi_uw, psi_vw, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_eiv_dia *** + !! + !! ** Purpose : diagnose the eddy induced velocity and its associated + !! vertically integrated heat transport. + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in) :: psi_uw, psi_vw ! streamfunction [m3/s] + INTEGER , INTENT(in) :: Kmm ! ocean time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zztmp ! local scalar + REAL(wp), DIMENSION(A2D(nn_hls)) :: zw2d ! 2D workspace + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zw3d ! 3D workspace + !!---------------------------------------------------------------------- + ! +!!gm I don't like this routine.... Crazy way of doing things, not optimal at all... +!!gm to be redesigned.... + ! !== eiv stream function: output ==! +!!gm CALL iom_put( "psi_eiv_uw", psi_uw ) ! output +!!gm CALL iom_put( "psi_eiv_vw", psi_vw ) + ! + ! !== eiv velocities: calculate and output ==! + ! + zw3d(:,:,jpk) = 0._wp ! bottom value always 0 + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e2u e3u u_eiv = -dk[psi_uw] + zw3d(ji,jj,jk) = ( psi_uw(ji,jj,jk+1) - psi_uw(ji,jj,jk) ) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm) ) + END_3D + CALL iom_put( "uoce_eiv", zw3d ) + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e1v e3v v_eiv = -dk[psi_vw] + zw3d(ji,jj,jk) = ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj,jk) ) / ( e1v(ji,jj) * e3v(ji,jj,jk,Kmm) ) + END_3D + CALL iom_put( "voce_eiv", zw3d ) + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e1 e2 w_eiv = dk[psix] + dk[psix] + zw3d(ji,jj,jk) = ( psi_vw(ji,jj,jk) - psi_vw(ji ,jj-1,jk) & + & + psi_uw(ji,jj,jk) - psi_uw(ji-1,jj ,jk) ) / e1e2t(ji,jj) + END_3D + CALL iom_put( "woce_eiv", zw3d ) + ! + IF( iom_use('weiv_masstr') ) THEN ! vertical mass transport & its square value + DO_2D( 0, 0, 0, 0 ) + zw2d(ji,jj) = rho0 * e1e2t(ji,jj) + END_2D + DO jk = 1, jpk + zw3d(:,:,jk) = zw3d(:,:,jk) * zw2d(:,:) + END DO + CALL iom_put( "weiv_masstr" , zw3d ) + ENDIF + ! + IF( iom_use('ueiv_masstr') ) THEN + zw3d(:,:,:) = 0.e0 + DO jk = 1, jpkm1 + zw3d(:,:,jk) = rho0 * ( psi_uw(:,:,jk+1) - psi_uw(:,:,jk) ) + END DO + CALL iom_put( "ueiv_masstr", zw3d ) ! mass transport in i-direction + ENDIF + ! + zztmp = 0.5_wp * rho0 * rcp + IF( iom_use('ueiv_heattr') .OR. iom_use('ueiv_heattr3d') ) THEN + zw2d(:,:) = 0._wp + zw3d(:,:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_uw(ji,jj,jk+1) - psi_uw(ji ,jj,jk) ) & + & * ( ts (ji,jj,jk,jp_tem,Kmm) + ts (ji+1,jj,jk,jp_tem,Kmm) ) + zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) + END_3D + CALL iom_put( "ueiv_heattr" , zztmp * zw2d ) ! heat transport in i-direction + CALL iom_put( "ueiv_heattr3d", zztmp * zw3d ) ! heat transport in i-direction + ENDIF + ! + IF( iom_use('veiv_masstr') ) THEN + zw3d(:,:,:) = 0.e0 + DO jk = 1, jpkm1 + zw3d(:,:,jk) = rho0 * ( psi_vw(:,:,jk+1) - psi_vw(:,:,jk) ) + END DO + CALL iom_put( "veiv_masstr", zw3d ) ! mass transport in i-direction + ENDIF + ! + zw2d(:,:) = 0._wp + zw3d(:,:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj ,jk) ) & + & * ( ts (ji,jj,jk,jp_tem,Kmm) + ts (ji,jj+1,jk,jp_tem,Kmm) ) + zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) + END_3D + CALL iom_put( "veiv_heattr" , zztmp * zw2d ) ! heat transport in j-direction + CALL iom_put( "veiv_heattr3d", zztmp * zw3d ) ! heat transport in j-direction + ! + IF( iom_use( 'sophteiv' ) ) CALL dia_ptr_hst( jp_tem, 'eiv', 0.5_wp * zw3d ) + ! + zztmp = 0.5_wp * 0.5 + IF( iom_use('ueiv_salttr') .OR. iom_use('ueiv_salttr3d')) THEN + zw2d(:,:) = 0._wp + zw3d(:,:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zw3d(ji,jj,jk) = zw3d(ji,jj,jk) * ( psi_uw(ji,jj,jk+1) - psi_uw(ji ,jj,jk) ) & + & * ( ts (ji,jj,jk,jp_sal,Kmm) + ts (ji+1,jj,jk,jp_sal,Kmm) ) + zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) + END_3D + CALL iom_put( "ueiv_salttr", zztmp * zw2d ) ! salt transport in i-direction + CALL iom_put( "ueiv_salttr3d", zztmp * zw3d ) ! salt transport in i-direction + ENDIF + zw2d(:,:) = 0._wp + zw3d(:,:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj ,jk) ) & + & * ( ts (ji,jj,jk,jp_sal,Kmm) + ts (ji,jj+1,jk,jp_sal,Kmm) ) + zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) + END_3D + CALL iom_put( "veiv_salttr" , zztmp * zw2d ) ! salt transport in j-direction + CALL iom_put( "veiv_salttr3d", zztmp * zw3d ) ! salt transport in j-direction + ! + IF( iom_use( 'sopsteiv' ) ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5_wp * zw3d ) + ! + ! + END SUBROUTINE ldf_eiv_dia + + !!====================================================================== +END MODULE ldftra diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/ddatetoymdhms.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/ddatetoymdhms.h90 new file mode 100644 index 0000000..91a0b6e --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/ddatetoymdhms.h90 @@ -0,0 +1,43 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ddatetoymdhms.h90 13226 2020-07-02 14:24:31Z orioltp $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE ddatetoymdhms( ddate, kyea, kmon, kday, khou, kmin, ksec ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE ddatetoymdhms *** + !! + !! ** Purpose : Convert YYYYMMDD.hhmmss to components + !! + !! ** Method : + !! + !! ** Action : + !! + !! History + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + real(wp), INTENT(IN) :: ddate + INTEGER, INTENT(OUT) :: kyea + INTEGER, INTENT(OUT) :: kmon + INTEGER, INTENT(OUT) :: kday + INTEGER, INTENT(OUT) :: khou + INTEGER, INTENT(OUT) :: kmin + INTEGER, INTENT(OUT) :: ksec + !! * Local declarations + INTEGER :: iyymmdd + INTEGER :: ihhmmss + + iyymmdd = INT( ddate ) + ihhmmss = INT( ( ddate - iyymmdd ) * 1000000 ) + kyea = iyymmdd/10000 + kmon = iyymmdd / 100 - 100 * kyea + kday = MOD( iyymmdd, 100 ) + khou = ihhmmss/10000 + kmin = ihhmmss / 100 - 100 * khou + ksec = MOD( ihhmmss, 100 ) + + END SUBROUTINE ddatetoymdhms \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/diaobs.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/diaobs.F90 new file mode 100644 index 0000000..38e54a7 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/diaobs.F90 @@ -0,0 +1,1137 @@ +MODULE diaobs + !!====================================================================== + !! *** MODULE diaobs *** + !! Observation diagnostics: Computation of the misfit between data and + !! their model equivalent + !!====================================================================== + !! History : 1.0 ! 2006-03 (K. Mogensen) Original code + !! - ! 2006-05 (K. Mogensen, A. Weaver) Reformatted + !! - ! 2006-10 (A. Weaver) Cleaning and add controls + !! - ! 2007-03 (K. Mogensen) General handling of profiles + !! - ! 2007-04 (G. Smith) Generalized surface operators + !! 2.0 ! 2008-10 (M. Valdivieso) obs operator for velocity profiles + !! 3.4 ! 2014-08 (J. While) observation operator for profiles in all vertical coordinates + !! - ! Incorporated SST bias correction + !! 3.6 ! 2015-02 (M. Martin) Simplification of namelist and code + !! - ! 2015-08 (M. Martin) Combined surface/profile routines. + !! 4.0 ! 2017-11 (G. Madec) style only + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dia_obs_init : Reading and prepare observations + !! dia_obs : Compute model equivalent to observations + !! dia_obs_wri : Write observational diagnostics + !! calc_date : Compute the date of timestep in YYYYMMDD.HHMMSS format + !! ini_date : Compute the initial date YYYYMMDD.HHMMSS + !! fin_date : Compute the final date YYYYMMDD.HHMMSS + !!---------------------------------------------------------------------- + USE par_kind ! Precision variables + USE in_out_manager ! I/O manager + USE par_oce ! ocean parameter + USE dom_oce ! Ocean space and time domain variables + USE sbc_oce ! Sea-ice fraction + ! + USE obs_read_prof ! Reading and allocation of profile obs + USE obs_read_surf ! Reading and allocation of surface obs + USE obs_sstbias ! Bias correction routine for SST + USE obs_readmdt ! Reading and allocation of MDT for SLA. + USE obs_prep ! Preparation of obs. (grid search etc). + USE obs_oper ! Observation operators + USE obs_write ! Writing of observation related diagnostics + USE obs_grid ! Grid searching + USE obs_read_altbias ! Bias treatment for altimeter + USE obs_profiles_def ! Profile data definitions + USE obs_surf_def ! Surface data definitions + USE obs_types ! Definitions for observation types + ! + USE mpp_map ! MPP mapping + USE lib_mpp ! For ctl_warn/stop + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_obs_init ! Initialize and read observations + PUBLIC dia_obs ! Compute model equivalent to observations + PUBLIC dia_obs_wri ! Write model equivalent to observations + PUBLIC dia_obs_dealloc ! Deallocate dia_obs data + PUBLIC calc_date ! Compute the date of a timestep + + LOGICAL, PUBLIC :: ln_diaobs !: Logical switch for the obs operator + LOGICAL :: ln_sstnight ! Logical switch for night mean SST obs + LOGICAL :: ln_default_fp_indegs ! T=> Default obs footprint size specified in degrees, F=> in metres + LOGICAL :: ln_sla_fp_indegs ! T=> SLA obs footprint size specified in degrees, F=> in metres + LOGICAL :: ln_sst_fp_indegs ! T=> SST obs footprint size specified in degrees, F=> in metres + LOGICAL :: ln_sss_fp_indegs ! T=> SSS obs footprint size specified in degrees, F=> in metres + LOGICAL :: ln_sic_fp_indegs ! T=> sea-ice obs footprint size specified in degrees, F=> in metres + + REAL(wp) :: rn_default_avglamscl ! E/W diameter of SLA observation footprint (metres) + REAL(wp) :: rn_default_avgphiscl ! N/S diameter of SLA observation footprint (metre + REAL(wp) :: rn_sla_avglamscl ! E/W diameter of SLA observation footprint (metres) + REAL(wp) :: rn_sla_avgphiscl ! N/S diameter of SLA observation footprint (metres) + REAL(wp) :: rn_sst_avglamscl ! E/W diameter of SST observation footprint (metres) + REAL(wp) :: rn_sst_avgphiscl ! N/S diameter of SST observation footprint (metres) + REAL(wp) :: rn_sss_avglamscl ! E/W diameter of SSS observation footprint (metres) + REAL(wp) :: rn_sss_avgphiscl ! N/S diameter of SSS observation footprint (metres) + REAL(wp) :: rn_sic_avglamscl ! E/W diameter of sea-ice observation footprint (metres) + REAL(wp) :: rn_sic_avgphiscl ! N/S diameter of sea-ice observation footprint (metres) + + INTEGER :: nn_1dint ! Vertical interpolation method + INTEGER :: nn_2dint_default ! Default horizontal interpolation method + INTEGER :: nn_2dint_sla ! SLA horizontal interpolation method + INTEGER :: nn_2dint_sst ! SST horizontal interpolation method + INTEGER :: nn_2dint_sss ! SSS horizontal interpolation method + INTEGER :: nn_2dint_sic ! Seaice horizontal interpolation method + INTEGER, DIMENSION(imaxavtypes) :: nn_profdavtypes ! Profile data types representing a daily average + INTEGER :: nproftypes ! Number of profile obs types + INTEGER :: nsurftypes ! Number of surface obs types + INTEGER , DIMENSION(:), ALLOCATABLE :: nvarsprof, nvarssurf ! Number of profile & surface variables + INTEGER , DIMENSION(:), ALLOCATABLE :: nextrprof, nextrsurf ! Number of profile & surface extra variables + INTEGER , DIMENSION(:), ALLOCATABLE :: n2dintsurf ! Interpolation option for surface variables + REAL(wp), DIMENSION(:), ALLOCATABLE :: zavglamscl, zavgphiscl ! E/W & N/S diameter of averaging footprint for surface variables + LOGICAL , DIMENSION(:), ALLOCATABLE :: lfpindegs ! T=> surface obs footprint size specified in degrees, F=> in metres + LOGICAL , DIMENSION(:), ALLOCATABLE :: llnightav ! Logical for calculating night-time averages + + TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: surfdata !: Initial surface data + TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: surfdataqc !: Surface data after quality control + TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdata !: Initial profile data + TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdataqc !: Profile data after quality control + + CHARACTER(len=lca), PUBLIC, DIMENSION(:), ALLOCATABLE :: cobstypesprof, cobstypessurf !: Profile & surface obs types + +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: diaobs.F90 15077 2021-07-03 10:16:35Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_obs_init( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_obs_init *** + !! + !! ** Purpose : Initialize and read observations + !! + !! ** Method : Read the namelist and call reading routines + !! + !! ** Action : Read the namelist and call reading routines + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level indices + INTEGER, PARAMETER :: jpmaxnfiles = 1000 ! Maximum number of files for each obs type + INTEGER, DIMENSION(:), ALLOCATABLE :: ifilesprof, ifilessurf ! Number of profile & surface files + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: jtype ! Counter for obs types + INTEGER :: jvar ! Counter for variables + INTEGER :: jfile ! Counter for files + INTEGER :: jnumsstbias ! Number of SST bias files to read and apply + INTEGER :: n2dint_type ! Local version of nn_2dint* + ! + CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: & + & cn_profbfiles, & ! T/S profile input filenames + & cn_sstfbfiles, & ! Sea surface temperature input filenames + & cn_sssfbfiles, & ! Sea surface salinity input filenames + & cn_slafbfiles, & ! Sea level anomaly input filenames + & cn_sicfbfiles, & ! Seaice concentration input filenames + & cn_velfbfiles, & ! Velocity profile input filenames + & cn_sstbiasfiles ! SST bias input filenames + CHARACTER(LEN=128) :: & + & cn_altbiasfile ! Altimeter bias input filename + CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: & + & clproffiles, & ! Profile filenames + & clsurffiles ! Surface filenames + CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: & + & clvars ! Expected variable names + ! + LOGICAL :: ln_t3d ! Logical switch for temperature profiles + LOGICAL :: ln_s3d ! Logical switch for salinity profiles + LOGICAL :: ln_sla ! Logical switch for sea level anomalies + LOGICAL :: ln_sst ! Logical switch for sea surface temperature + LOGICAL :: ln_sss ! Logical switch for sea surface salinity + LOGICAL :: ln_sic ! Logical switch for sea ice concentration + LOGICAL :: ln_vel3d ! Logical switch for velocity (u,v) obs + LOGICAL :: ln_nea ! Logical switch to remove obs near land + LOGICAL :: ln_altbias ! Logical switch for altimeter bias + LOGICAL :: ln_sstbias ! Logical switch for bias corection of SST + LOGICAL :: ln_ignmis ! Logical switch for ignoring missing files + LOGICAL :: ln_s_at_t ! Logical switch to compute model S at T obs + LOGICAL :: ln_bound_reject ! Logical to remove obs near boundaries in LAMs. + LOGICAL :: ltype_fp_indegs ! Local version of ln_*_fp_indegs + LOGICAL :: ltype_night ! Local version of ln_sstnight (false for other variables) + LOGICAL, DIMENSION(:), ALLOCATABLE :: llvar ! Logical for profile variable read + LOGICAL, DIMENSION(jpmaxnfiles) :: lmask ! Used for finding number of sstbias files + ! + REAL(wp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS + REAL(wp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS + REAL(wp) :: ztype_avglamscl ! Local version of rn_*_avglamscl + REAL(wp) :: ztype_avgphiscl ! Local version of rn_*_avgphiscl + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zglam ! Model longitudes for profile variables + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zgphi ! Model latitudes for profile variables + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zmask ! Model land/sea mask associated with variables + !! + NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla, & + & ln_sst, ln_sic, ln_sss, ln_vel3d, & + & ln_altbias, ln_sstbias, ln_nea, & + & ln_grid_global, ln_grid_search_lookup, & + & ln_ignmis, ln_s_at_t, ln_bound_reject, & + & ln_sstnight, ln_default_fp_indegs, & + & ln_sla_fp_indegs, ln_sst_fp_indegs, & + & ln_sss_fp_indegs, ln_sic_fp_indegs, & + & cn_profbfiles, cn_slafbfiles, & + & cn_sstfbfiles, cn_sicfbfiles, & + & cn_velfbfiles, cn_sssfbfiles, & + & cn_sstbiasfiles, cn_altbiasfile, & + & cn_gridsearchfile, rn_gridsearchres, & + & rn_dobsini, rn_dobsend, & + & rn_default_avglamscl, rn_default_avgphiscl, & + & rn_sla_avglamscl, rn_sla_avgphiscl, & + & rn_sst_avglamscl, rn_sst_avgphiscl, & + & rn_sss_avglamscl, rn_sss_avgphiscl, & + & rn_sic_avglamscl, rn_sic_avgphiscl, & + & nn_1dint, nn_2dint_default, & + & nn_2dint_sla, nn_2dint_sst, & + & nn_2dint_sss, nn_2dint_sic, & + & nn_msshc, rn_mdtcorr, rn_mdtcutoff, & + & nn_profdavtypes + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! Read namelist parameters + !----------------------------------------------------------------------- + ! Some namelist arrays need initialising + cn_profbfiles (:) = '' + cn_slafbfiles (:) = '' + cn_sstfbfiles (:) = '' + cn_sicfbfiles (:) = '' + cn_velfbfiles (:) = '' + cn_sssfbfiles (:) = '' + cn_sstbiasfiles(:) = '' + nn_profdavtypes(:) = -1 + + CALL ini_date( rn_dobsini ) + CALL fin_date( rn_dobsend ) + + ! Read namelist namobs : control observation diagnostics + READ ( numnam_ref, namobs, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in reference namelist' ) + READ ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namobs in configuration namelist' ) + IF(lwm) WRITE ( numond, namobs ) + + IF( .NOT.ln_diaobs ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dia_obs_init : NO Observation diagnostic used' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + RETURN + ENDIF + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dia_obs_init : Observation diagnostic initialization' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namobs : set observation diagnostic parameters' + WRITE(numout,*) ' Logical switch for T profile observations ln_t3d = ', ln_t3d + WRITE(numout,*) ' Logical switch for S profile observations ln_s3d = ', ln_s3d + WRITE(numout,*) ' Logical switch for SLA observations ln_sla = ', ln_sla + WRITE(numout,*) ' Logical switch for SST observations ln_sst = ', ln_sst + WRITE(numout,*) ' Logical switch for Sea Ice observations ln_sic = ', ln_sic + WRITE(numout,*) ' Logical switch for velocity observations ln_vel3d = ', ln_vel3d + WRITE(numout,*) ' Logical switch for SSS observations ln_sss = ', ln_sss + WRITE(numout,*) ' Global distribution of observations ln_grid_global = ', ln_grid_global + WRITE(numout,*) ' Logical switch for obs grid search lookup ln_grid_search_lookup = ', ln_grid_search_lookup + IF (ln_grid_search_lookup) & + WRITE(numout,*) ' Grid search lookup file header cn_gridsearchfile = ', cn_gridsearchfile + WRITE(numout,*) ' Initial date in window YYYYMMDD.HHMMSS rn_dobsini = ', rn_dobsini + WRITE(numout,*) ' Final date in window YYYYMMDD.HHMMSS rn_dobsend = ', rn_dobsend + WRITE(numout,*) ' Type of vertical interpolation method nn_1dint = ', nn_1dint + WRITE(numout,*) ' Default horizontal interpolation method nn_2dint_default = ', nn_2dint_default + WRITE(numout,*) ' Type of horizontal interpolation method for SLA nn_2dint_sla = ', nn_2dint_sla + WRITE(numout,*) ' Type of horizontal interpolation method for SST nn_2dint_sst = ', nn_2dint_sst + WRITE(numout,*) ' Type of horizontal interpolation method for SSS nn_2dint_sss = ', nn_2dint_sss + WRITE(numout,*) ' Type of horizontal interpolation method for SIC nn_2dint_sic = ', nn_2dint_sic + WRITE(numout,*) ' Default E/W diameter of obs footprint rn_default_avglamscl = ', rn_default_avglamscl + WRITE(numout,*) ' Default N/S diameter of obs footprint rn_default_avgphiscl = ', rn_default_avgphiscl + WRITE(numout,*) ' Default obs footprint in deg [T] or m [F] ln_default_fp_indegs = ', ln_default_fp_indegs + WRITE(numout,*) ' SLA E/W diameter of obs footprint rn_sla_avglamscl = ', rn_sla_avglamscl + WRITE(numout,*) ' SLA N/S diameter of obs footprint rn_sla_avgphiscl = ', rn_sla_avgphiscl + WRITE(numout,*) ' SLA obs footprint in deg [T] or m [F] ln_sla_fp_indegs = ', ln_sla_fp_indegs + WRITE(numout,*) ' SST E/W diameter of obs footprint rn_sst_avglamscl = ', rn_sst_avglamscl + WRITE(numout,*) ' SST N/S diameter of obs footprint rn_sst_avgphiscl = ', rn_sst_avgphiscl + WRITE(numout,*) ' SST obs footprint in deg [T] or m [F] ln_sst_fp_indegs = ', ln_sst_fp_indegs + WRITE(numout,*) ' SIC E/W diameter of obs footprint rn_sic_avglamscl = ', rn_sic_avglamscl + WRITE(numout,*) ' SIC N/S diameter of obs footprint rn_sic_avgphiscl = ', rn_sic_avgphiscl + WRITE(numout,*) ' SIC obs footprint in deg [T] or m [F] ln_sic_fp_indegs = ', ln_sic_fp_indegs + WRITE(numout,*) ' Rejection of observations near land switch ln_nea = ', ln_nea + WRITE(numout,*) ' Rejection of obs near open bdys ln_bound_reject = ', ln_bound_reject + WRITE(numout,*) ' MSSH correction scheme nn_msshc = ', nn_msshc + WRITE(numout,*) ' MDT correction rn_mdtcorr = ', rn_mdtcorr + WRITE(numout,*) ' MDT cutoff for computed correction rn_mdtcutoff = ', rn_mdtcutoff + WRITE(numout,*) ' Logical switch for alt bias ln_altbias = ', ln_altbias + WRITE(numout,*) ' Logical switch for sst bias ln_sstbias = ', ln_sstbias + WRITE(numout,*) ' Logical switch for ignoring missing files ln_ignmis = ', ln_ignmis + WRITE(numout,*) ' Daily average types nn_profdavtypes = ', nn_profdavtypes + WRITE(numout,*) ' Logical switch for night-time SST obs ln_sstnight = ', ln_sstnight + ENDIF + !----------------------------------------------------------------------- + ! Set up list of observation types to be used + ! and the files associated with each type + !----------------------------------------------------------------------- + + nproftypes = COUNT( (/ln_t3d .OR. ln_s3d, ln_vel3d /) ) + nsurftypes = COUNT( (/ln_sla, ln_sst, ln_sic, ln_sss /) ) + + IF( ln_sstbias ) THEN + lmask(:) = .FALSE. + WHERE( cn_sstbiasfiles(:) /= '' ) lmask(:) = .TRUE. + jnumsstbias = COUNT(lmask) + lmask(:) = .FALSE. + ENDIF + + IF( nproftypes == 0 .AND. nsurftypes == 0 ) THEN + CALL ctl_warn( 'dia_obs_init: ln_diaobs is set to true, but all obs operator logical flags', & + & ' (ln_t3d, ln_s3d, ln_sla, ln_sst, ln_sic, ln_vel3d)', & + & ' are set to .FALSE. so turning off calls to dia_obs' ) + ln_diaobs = .FALSE. + RETURN + ENDIF + + IF( nproftypes > 0 ) THEN + ! + ALLOCATE( cobstypesprof(nproftypes) ) + ALLOCATE( ifilesprof (nproftypes) ) + ALLOCATE( clproffiles (nproftypes,jpmaxnfiles) ) + ! + jtype = 0 + IF( ln_t3d .OR. ln_s3d ) THEN + jtype = jtype + 1 + cobstypesprof(jtype) = 'prof' + clproffiles(jtype,:) = cn_profbfiles + ENDIF + IF( ln_vel3d ) THEN + jtype = jtype + 1 + cobstypesprof(jtype) = 'vel' + clproffiles(jtype,:) = cn_velfbfiles + ENDIF + ! + CALL obs_settypefiles( nproftypes, jpmaxnfiles, ifilesprof, cobstypesprof, clproffiles ) + ! + ENDIF + + IF( nsurftypes > 0 ) THEN + ! + ALLOCATE( cobstypessurf(nsurftypes) ) + ALLOCATE( ifilessurf (nsurftypes) ) + ALLOCATE( clsurffiles (nsurftypes,jpmaxnfiles) ) + ALLOCATE( n2dintsurf (nsurftypes) ) + ALLOCATE( zavglamscl (nsurftypes) ) + ALLOCATE( zavgphiscl (nsurftypes) ) + ALLOCATE( lfpindegs (nsurftypes) ) + ALLOCATE( llnightav (nsurftypes) ) + ! + jtype = 0 + IF( ln_sla ) THEN + jtype = jtype + 1 + cobstypessurf(jtype) = 'sla' + clsurffiles(jtype,:) = cn_slafbfiles + ENDIF + IF( ln_sst ) THEN + jtype = jtype + 1 + cobstypessurf(jtype) = 'sst' + clsurffiles(jtype,:) = cn_sstfbfiles + ENDIF +#if defined key_si3 || defined key_cice + IF( ln_sic ) THEN + jtype = jtype + 1 + cobstypessurf(jtype) = 'sic' + clsurffiles(jtype,:) = cn_sicfbfiles + ENDIF +#endif + IF( ln_sss ) THEN + jtype = jtype + 1 + cobstypessurf(jtype) = 'sss' + clsurffiles(jtype,:) = cn_sssfbfiles + ENDIF + ! + CALL obs_settypefiles( nsurftypes, jpmaxnfiles, ifilessurf, cobstypessurf, clsurffiles ) + + DO jtype = 1, nsurftypes + + IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN + IF ( nn_2dint_sla == -1 ) THEN + n2dint_type = nn_2dint_default + ELSE + n2dint_type = nn_2dint_sla + ENDIF + ztype_avglamscl = rn_sla_avglamscl + ztype_avgphiscl = rn_sla_avgphiscl + ltype_fp_indegs = ln_sla_fp_indegs + ltype_night = .FALSE. + ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN + IF ( nn_2dint_sst == -1 ) THEN + n2dint_type = nn_2dint_default + ELSE + n2dint_type = nn_2dint_sst + ENDIF + ztype_avglamscl = rn_sst_avglamscl + ztype_avgphiscl = rn_sst_avgphiscl + ltype_fp_indegs = ln_sst_fp_indegs + ltype_night = ln_sstnight + ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN + IF ( nn_2dint_sic == -1 ) THEN + n2dint_type = nn_2dint_default + ELSE + n2dint_type = nn_2dint_sic + ENDIF + ztype_avglamscl = rn_sic_avglamscl + ztype_avgphiscl = rn_sic_avgphiscl + ltype_fp_indegs = ln_sic_fp_indegs + ltype_night = .FALSE. + ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN + IF ( nn_2dint_sss == -1 ) THEN + n2dint_type = nn_2dint_default + ELSE + n2dint_type = nn_2dint_sss + ENDIF + ztype_avglamscl = rn_sss_avglamscl + ztype_avgphiscl = rn_sss_avgphiscl + ltype_fp_indegs = ln_sss_fp_indegs + ltype_night = .FALSE. + ELSE + n2dint_type = nn_2dint_default + ztype_avglamscl = rn_default_avglamscl + ztype_avgphiscl = rn_default_avgphiscl + ltype_fp_indegs = ln_default_fp_indegs + ltype_night = .FALSE. + ENDIF + + CALL obs_setinterpopts( nsurftypes, jtype, TRIM(cobstypessurf(jtype)), & + & nn_2dint_default, n2dint_type, & + & ztype_avglamscl, ztype_avgphiscl, & + & ltype_fp_indegs, ltype_night, & + & n2dintsurf, zavglamscl, zavgphiscl, & + & lfpindegs, llnightav ) + + END DO + ! + ENDIF + + + !----------------------------------------------------------------------- + ! Obs operator parameter checking and initialisations + !----------------------------------------------------------------------- + ! + IF( ln_vel3d .AND. .NOT.ln_grid_global ) THEN + CALL ctl_stop( 'Velocity data only works with ln_grid_global=.true.' ) + RETURN + ENDIF + ! + IF( ln_grid_global ) THEN + CALL ctl_warn( 'dia_obs_init: ln_grid_global=T may cause memory issues when used with a large number of processors' ) + ENDIF + ! + IF( nn_1dint < 0 .OR. nn_1dint > 1 ) THEN + CALL ctl_stop('dia_obs_init: Choice of vertical (1D) interpolation method is not available') + ENDIF + ! + IF( nn_2dint_default < 0 .OR. nn_2dint_default > 6 ) THEN + CALL ctl_stop('dia_obs_init: Choice of default horizontal (2D) interpolation method is not available') + ENDIF + ! + CALL obs_typ_init + IF( ln_grid_global ) CALL mppmap_init + ! + CALL obs_grid_setup( ) + + !----------------------------------------------------------------------- + ! Depending on switches read the various observation types + !----------------------------------------------------------------------- + ! + IF( nproftypes > 0 ) THEN + ! + ALLOCATE( profdata (nproftypes) , nvarsprof (nproftypes) ) + ALLOCATE( profdataqc(nproftypes) , nextrprof (nproftypes) ) + ! + DO jtype = 1, nproftypes + ! + IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN + nvarsprof(jtype) = 2 + nextrprof(jtype) = 1 + ALLOCATE( llvar (nvarsprof(jtype)) ) + ALLOCATE( clvars(nvarsprof(jtype)) ) + ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) + ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) + ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) + llvar(1) = ln_t3d + llvar(2) = ln_s3d + clvars(1) = 'POTM' + clvars(2) = 'PSAL' + zglam(:,:,1) = glamt(:,:) + zglam(:,:,2) = glamt(:,:) + zgphi(:,:,1) = gphit(:,:) + zgphi(:,:,2) = gphit(:,:) + zmask(:,:,:,1) = tmask(:,:,:) + zmask(:,:,:,2) = tmask(:,:,:) + ELSE IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN + nvarsprof(jtype) = 2 + nextrprof(jtype) = 2 + ALLOCATE( llvar (nvarsprof(jtype)) ) + ALLOCATE( clvars(nvarsprof(jtype)) ) + ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) + ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) + ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) + llvar(1) = ln_vel3d + llvar(2) = ln_vel3d + clvars(1) = 'UVEL' + clvars(2) = 'VVEL' + zglam(:,:,1) = glamu(:,:) + zglam(:,:,2) = glamv(:,:) + zgphi(:,:,1) = gphiu(:,:) + zgphi(:,:,2) = gphiv(:,:) + zmask(:,:,:,1) = umask(:,:,:) + zmask(:,:,:,2) = vmask(:,:,:) + ELSE + nvarsprof(jtype) = 1 + nextrprof(jtype) = 0 + ALLOCATE( llvar (nvarsprof(jtype)) ) + ALLOCATE( clvars(nvarsprof(jtype)) ) + ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) + ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) + ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) + llvar(1) = .TRUE. + zglam(:,:,1) = glamt(:,:) + zgphi(:,:,1) = gphit(:,:) + zmask(:,:,:,1) = tmask(:,:,:) + ENDIF + ! + ! Read in profile or profile obs types + CALL obs_rea_prof( profdata(jtype), ifilesprof(jtype), & + & clproffiles(jtype,1:ifilesprof(jtype)), & + & nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & + & rn_dobsini, rn_dobsend, llvar, & + & ln_ignmis, ln_s_at_t, .FALSE., clvars, & + & kdailyavtypes = nn_profdavtypes ) + ! + DO jvar = 1, nvarsprof(jtype) + CALL obs_prof_staend( profdata(jtype), jvar ) + END DO + ! + CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & + & llvar, & + & jpi, jpj, jpk, & + & zmask, zglam, zgphi, & + & ln_nea, ln_bound_reject, Kmm, & + & kdailyavtypes = nn_profdavtypes ) + ! + DEALLOCATE( llvar, clvars, zglam, zgphi, zmask ) + ! + END DO + ! + DEALLOCATE( ifilesprof, clproffiles ) + ! + ENDIF + ! + IF( nsurftypes > 0 ) THEN + ! + ALLOCATE( surfdata (nsurftypes) , nvarssurf(nsurftypes) ) + ALLOCATE( surfdataqc(nsurftypes) , nextrsurf(nsurftypes) ) + ! + DO jtype = 1, nsurftypes + ! + nvarssurf(jtype) = 1 + nextrsurf(jtype) = 0 + llnightav(jtype) = .FALSE. + IF( TRIM(cobstypessurf(jtype)) == 'sla' ) nextrsurf(jtype) = 2 + IF( TRIM(cobstypessurf(jtype)) == 'sst' ) llnightav(jtype) = ln_sstnight + ! + ALLOCATE( clvars( nvarssurf(jtype) ) ) + IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN + clvars(1) = 'SLA' + ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN + clvars(1) = 'SST' + ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN + clvars(1) = 'ICECONC' + ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN + clvars(1) = 'SSS' + ENDIF + ! + ! Read in surface obs types + CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), & + & clsurffiles(jtype,1:ifilessurf(jtype)), & + & nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, & + & rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype), & + & clvars ) + ! + CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea, ln_bound_reject ) + ! + IF( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN + CALL obs_rea_mdt( surfdataqc(jtype), n2dintsurf(jtype), Kmm ) + IF( ln_altbias ) & + & CALL obs_rea_altbias ( surfdataqc(jtype), n2dintsurf(jtype), cn_altbiasfile ) + ENDIF + ! + IF( TRIM(cobstypessurf(jtype)) == 'sst' .AND. ln_sstbias ) THEN + jnumsstbias = 0 + DO jfile = 1, jpmaxnfiles + IF( TRIM(cn_sstbiasfiles(jfile)) /= '' ) jnumsstbias = jnumsstbias + 1 + END DO + IF( jnumsstbias == 0 ) CALL ctl_stop("ln_sstbias set but no bias files to read in") + ! + CALL obs_app_sstbias( surfdataqc(jtype), n2dintsurf(jtype) , & + & jnumsstbias , cn_sstbiasfiles(1:jnumsstbias) ) + ENDIF + ! + DEALLOCATE( clvars ) + END DO + ! + DEALLOCATE( ifilessurf, clsurffiles ) + ! + ENDIF + ! + END SUBROUTINE dia_obs_init + + + SUBROUTINE dia_obs( kstp, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_obs *** + !! + !! ** Purpose : Call the observation operators on each time step + !! + !! ** Method : Call the observation operators on each time step to + !! compute the model equivalent of the following data: + !! - Profile data, currently T/S or U/V + !! - Surface data, currently SST, SLA or sea-ice concentration. + !! + !! ** Action : + !!---------------------------------------------------------------------- + USE phycst , ONLY : rday ! Physical constants + USE oce , ONLY : ts, uu, vv, ssh ! Ocean dynamics and tracers variables (Kmm time-level only) + USE phycst , ONLY : rday ! Physical constants +#if defined key_si3 + USE ice , ONLY : at_i ! SI3 Ice model variables +#endif +#if defined key_cice + USE sbc_oce, ONLY : fr_i ! ice fraction +#endif + + IMPLICIT NONE + + !! * Arguments + INTEGER, INTENT(IN) :: kstp ! Current timestep + INTEGER, INTENT(in) :: Kmm ! ocean time level indices + !! * Local declarations + INTEGER :: idaystp ! Number of timesteps per day + INTEGER :: jtype ! Data loop variable + INTEGER :: jvar ! Variable number + INTEGER :: ji, jj, jk ! Loop counters + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & + & zprofvar ! Model values for variables in a prof ob + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & + & zprofmask ! Mask associated with zprofvar + REAL(wp), DIMENSION(jpi,jpj) :: & + & zsurfvar, & ! Model values equivalent to surface ob. + & zsurfmask ! Mask associated with surface variable + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zglam, & ! Model longitudes for prof variables + & zgphi ! Model latitudes for prof variables + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zdept, zdepw + + !----------------------------------------------------------------------- + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dia_obs : Call the observation operators', kstp + WRITE(numout,*) '~~~~~~~' + ENDIF + + idaystp = NINT( rday / rn_Dt ) + + !----------------------------------------------------------------------- + ! Call the profile and surface observation operators + !----------------------------------------------------------------------- + + IF ( nproftypes > 0 ) THEN + + ALLOCATE( zdept(jpi,jpj,jpk), zdepw(jpi,jpj,jpk) ) + DO jk = 1, jpk + zdept(:,:,jk) = gdept(:,:,jk,Kmm) + zdepw(:,:,jk) = gdepw(:,:,jk,Kmm) + END DO + + DO jtype = 1, nproftypes + + ! Allocate local work arrays + ALLOCATE( zprofvar (jpi, jpj, jpk, profdataqc(jtype)%nvar) ) + ALLOCATE( zprofmask(jpi, jpj, jpk, profdataqc(jtype)%nvar) ) + ALLOCATE( zglam (jpi, jpj, profdataqc(jtype)%nvar) ) + ALLOCATE( zgphi (jpi, jpj, profdataqc(jtype)%nvar) ) + + ! Defaults which might change + DO jvar = 1, profdataqc(jtype)%nvar + zprofmask(:,:,:,jvar) = tmask(:,:,:) + zglam(:,:,jvar) = glamt(:,:) + zgphi(:,:,jvar) = gphit(:,:) + END DO + + SELECT CASE ( TRIM(cobstypesprof(jtype)) ) + CASE('prof') + zprofvar(:,:,:,1) = ts(:,:,:,jp_tem,Kmm) + zprofvar(:,:,:,2) = ts(:,:,:,jp_sal,Kmm) + CASE('vel') + zprofvar(:,:,:,1) = uu(:,:,:,Kmm) + zprofvar(:,:,:,2) = vv(:,:,:,Kmm) + zprofmask(:,:,:,1) = umask(:,:,:) + zprofmask(:,:,:,2) = vmask(:,:,:) + zglam(:,:,1) = glamu(:,:) + zglam(:,:,2) = glamv(:,:) + zgphi(:,:,1) = gphiu(:,:) + zgphi(:,:,2) = gphiv(:,:) + CASE DEFAULT + CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' ) + END SELECT + + DO jvar = 1, profdataqc(jtype)%nvar + CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk, & + & nit000, idaystp, jvar, & + & zprofvar(:,:,:,jvar), & + & zdept(:,:,:), zdepw(:,:,:), & + & zprofmask(:,:,:,jvar), & + & zglam(:,:,jvar), zgphi(:,:,jvar), & + & nn_1dint, nn_2dint_default, & + & kdailyavtypes = nn_profdavtypes ) + END DO + + DEALLOCATE( zprofvar, zprofmask, zglam, zgphi ) + + END DO + + DEALLOCATE( zdept, zdepw ) + + ENDIF + + IF ( nsurftypes > 0 ) THEN + + DO jtype = 1, nsurftypes + + !Defaults which might be changed + zsurfmask(:,:) = tmask(:,:,1) + + SELECT CASE ( TRIM(cobstypessurf(jtype)) ) + CASE('sst') + zsurfvar(:,:) = ts(:,:,1,jp_tem,Kmm) + CASE('sla') + zsurfvar(:,:) = ssh(:,:,Kmm) + CASE('sss') + zsurfvar(:,:) = ts(:,:,1,jp_sal,Kmm) + CASE('sic') + IF ( kstp == 0 ) THEN + IF ( lwp .AND. surfdataqc(jtype)%nsstpmpp(1) > 0 ) THEN + CALL ctl_warn( 'Sea-ice not initialised on zeroth '// & + & 'time-step but some obs are valid then.' ) + WRITE(numout,*)surfdataqc(jtype)%nsstpmpp(1), & + & ' sea-ice obs will be missed' + ENDIF + surfdataqc(jtype)%nsurfup = surfdataqc(jtype)%nsurfup + & + & surfdataqc(jtype)%nsstp(1) + CYCLE + ELSE +#if defined key_cice || defined key_si3 + zsurfvar(:,:) = fr_i(:,:) +#else + CALL ctl_stop( ' Trying to run sea-ice observation operator', & + & ' but no sea-ice model appears to have been defined' ) +#endif + ENDIF + + END SELECT + + CALL obs_surf_opt( surfdataqc(jtype), kstp, jpi, jpj, & + & nit000, idaystp, zsurfvar, zsurfmask, & + & n2dintsurf(jtype), llnightav(jtype), & + & zavglamscl(jtype), zavgphiscl(jtype), & + & lfpindegs(jtype) ) + + END DO + + ENDIF + + END SUBROUTINE dia_obs + + SUBROUTINE dia_obs_wri + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_obs_wri *** + !! + !! ** Purpose : Call observation diagnostic output routines + !! + !! ** Method : Call observation diagnostic output routines + !! + !! ** Action : + !! + !! History : + !! ! 06-03 (K. Mogensen) Original code + !! ! 06-05 (K. Mogensen) Reformatted + !! ! 06-10 (A. Weaver) Cleaning + !! ! 07-03 (K. Mogensen) General handling of profiles + !! ! 08-09 (M. Valdivieso) Velocity component (U,V) profiles + !! ! 15-08 (M. Martin) Combined writing for prof and surf types + !!---------------------------------------------------------------------- + !! * Modules used + USE obs_rot_vel ! Rotation of velocities + + IMPLICIT NONE + + !! * Local declarations + INTEGER :: jtype ! Data set loop variable + INTEGER :: jo, jvar, jk + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zu, & + & zv + + !----------------------------------------------------------------------- + ! Depending on switches call various observation output routines + !----------------------------------------------------------------------- + + IF ( nproftypes > 0 ) THEN + + DO jtype = 1, nproftypes + + IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN + + ! For velocity data, rotate the model velocities to N/S, E/W + ! using the compressed data structure. + ALLOCATE( & + & zu(profdataqc(jtype)%nvprot(1)), & + & zv(profdataqc(jtype)%nvprot(2)) & + & ) + + CALL obs_rotvel( profdataqc(jtype), nn_2dint_default, zu, zv ) + + DO jo = 1, profdataqc(jtype)%nprof + DO jvar = 1, 2 + DO jk = profdataqc(jtype)%npvsta(jo,jvar), profdataqc(jtype)%npvend(jo,jvar) + + IF ( jvar == 1 ) THEN + profdataqc(jtype)%var(jvar)%vmod(jk) = zu(jk) + ELSE + profdataqc(jtype)%var(jvar)%vmod(jk) = zv(jk) + ENDIF + + END DO + END DO + END DO + + DEALLOCATE( zu ) + DEALLOCATE( zv ) + + END IF + + CALL obs_prof_decompress( profdataqc(jtype), & + & profdata(jtype), .TRUE., numout ) + + CALL obs_wri_prof( profdata(jtype) ) + + END DO + + ENDIF + + IF ( nsurftypes > 0 ) THEN + + DO jtype = 1, nsurftypes + + CALL obs_surf_decompress( surfdataqc(jtype), & + & surfdata(jtype), .TRUE., numout ) + + CALL obs_wri_surf( surfdata(jtype) ) + + END DO + + ENDIF + + END SUBROUTINE dia_obs_wri + + SUBROUTINE dia_obs_dealloc + IMPLICIT NONE + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_obs_dealloc *** + !! + !! ** Purpose : To deallocate data to enable the obs_oper online loop. + !! Specifically: dia_obs_init --> dia_obs --> dia_obs_wri + !! + !! ** Method : Clean up various arrays left behind by the obs_oper. + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + ! obs_grid deallocation + CALL obs_grid_deallocate + + ! diaobs deallocation + IF ( nproftypes > 0 ) & + & DEALLOCATE( cobstypesprof, profdata, profdataqc, nvarsprof, nextrprof ) + + IF ( nsurftypes > 0 ) & + & DEALLOCATE( cobstypessurf, surfdata, surfdataqc, nvarssurf, nextrsurf, & + & n2dintsurf, zavglamscl, zavgphiscl, lfpindegs, llnightav ) + + END SUBROUTINE dia_obs_dealloc + + SUBROUTINE calc_date( kstp, ddobs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE calc_date *** + !! + !! ** Purpose : Get date in double precision YYYYMMDD.HHMMSS format + !! + !! ** Method : Get date in double precision YYYYMMDD.HHMMSS format + !! + !! ** Action : Get date in double precision YYYYMMDD.HHMMSS format + !! + !! ** Action : Get initial date in double precision YYYYMMDD.HHMMSS format + !! + !! History : + !! ! 06-03 (K. Mogensen) Original code + !! ! 06-05 (K. Mogensen) Reformatted + !! ! 06-10 (A. Weaver) Cleaning + !! ! 06-10 (G. Smith) Calculates initial date the same as method for final date + !! ! 10-05 (D. Lea) Update to month length calculation for NEMO vn3.2 + !! ! 2014-09 (D. Lea) New generic routine now deals with arbitrary initial time of day + !!---------------------------------------------------------------------- + USE phycst, ONLY : & ! Physical constants + & rday + USE dom_oce, ONLY : & ! Ocean space and time domain variables + & rn_Dt + + IMPLICIT NONE + + !! * Arguments + REAL(KIND=wp), INTENT(OUT) :: ddobs ! Date in YYYYMMDD.HHMMSS + INTEGER, INTENT(IN) :: kstp + + !! * Local declarations + INTEGER :: iyea ! date - (year, month, day, hour, minute) + INTEGER :: imon + INTEGER :: iday + INTEGER :: ihou + INTEGER :: imin + INTEGER :: imday ! Number of days in month. + REAL(wp) :: zdayfrc ! Fraction of day + + INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year + + !!---------------------------------------------------------------------- + !! Initial date initialization (year, month, day, hour, minute) + !!---------------------------------------------------------------------- + iyea = ndate0 / 10000 + imon = ( ndate0 - iyea * 10000 ) / 100 + iday = ndate0 - iyea * 10000 - imon * 100 + ihou = nn_time0 / 100 + imin = ( nn_time0 - ihou * 100 ) + + !!---------------------------------------------------------------------- + !! Compute number of days + number of hours + min since initial time + !!---------------------------------------------------------------------- + zdayfrc = kstp * rn_Dt / rday + zdayfrc = zdayfrc - aint(zdayfrc) + imin = imin + int( zdayfrc * 24 * 60 ) + DO WHILE (imin >= 60) + imin=imin-60 + ihou=ihou+1 + END DO + DO WHILE (ihou >= 24) + ihou=ihou-24 + iday=iday+1 + END DO + iday = iday + kstp * rn_Dt / rday + + !----------------------------------------------------------------------- + ! Convert number of days (iday) into a real date + !---------------------------------------------------------------------- + + CALL calc_month_len( iyea, imonth_len ) + + DO WHILE ( iday > imonth_len(imon) ) + iday = iday - imonth_len(imon) + imon = imon + 1 + IF ( imon > 12 ) THEN + imon = 1 + iyea = iyea + 1 + CALL calc_month_len( iyea, imonth_len ) ! update month lengths + ENDIF + END DO + + !---------------------------------------------------------------------- + ! Convert it into YYYYMMDD.HHMMSS format. + !---------------------------------------------------------------------- + ddobs = iyea * 10000_dp + imon * 100_dp + & + & iday + ihou * 0.01_dp + imin * 0.0001_dp + + END SUBROUTINE calc_date + + SUBROUTINE ini_date( ddobsini ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ini_date *** + !! + !! ** Purpose : Get initial date in double precision YYYYMMDD.HHMMSS format + !! + !! ** Method : + !! + !! ** Action : + !! + !! History : + !! ! 06-03 (K. Mogensen) Original code + !! ! 06-05 (K. Mogensen) Reformatted + !! ! 06-10 (A. Weaver) Cleaning + !! ! 10-05 (D. Lea) Update to month length calculation for NEMO vn3.2 + !! ! 2014-09 (D. Lea) Change to call generic routine calc_date + !!---------------------------------------------------------------------- + + IMPLICIT NONE + + !! * Arguments + REAL(KIND=wp), INTENT(OUT) :: ddobsini ! Initial date in YYYYMMDD.HHMMSS + + CALL calc_date( nit000 - 1, ddobsini ) + + END SUBROUTINE ini_date + + SUBROUTINE fin_date( ddobsfin ) + !!---------------------------------------------------------------------- + !! *** ROUTINE fin_date *** + !! + !! ** Purpose : Get final date in double precision YYYYMMDD.HHMMSS format + !! + !! ** Method : + !! + !! ** Action : + !! + !! History : + !! ! 06-03 (K. Mogensen) Original code + !! ! 06-05 (K. Mogensen) Reformatted + !! ! 06-10 (A. Weaver) Cleaning + !! ! 10-05 (D. Lea) Update to month length calculation for NEMO vn3.2 + !! ! 2014-09 (D. Lea) Change to call generic routine calc_date + !!---------------------------------------------------------------------- + + IMPLICIT NONE + + !! * Arguments + REAL(wp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS + + CALL calc_date( nitend, ddobsfin ) + + END SUBROUTINE fin_date + + SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, ifiles, cobstypes, cfiles ) + + INTEGER, INTENT(IN) :: ntypes ! Total number of obs types + INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type + INTEGER, DIMENSION(ntypes), INTENT(OUT) :: & + & ifiles ! Out number of files for each type + CHARACTER(len=lca), DIMENSION(ntypes), INTENT(IN) :: & + & cobstypes ! List of obs types + CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(IN) :: & + & cfiles ! List of files for all types + + !Local variables + INTEGER :: jfile + INTEGER :: jtype + + DO jtype = 1, ntypes + + ifiles(jtype) = 0 + DO jfile = 1, jpmaxnfiles + IF ( trim(cfiles(jtype,jfile)) /= '' ) & + ifiles(jtype) = ifiles(jtype) + 1 + END DO + + IF ( ifiles(jtype) == 0 ) THEN + CALL ctl_stop( 'Logical for observation type '//TRIM(cobstypes(jtype))// & + & ' set to true but no files available to read' ) + ENDIF + + IF(lwp) THEN + WRITE(numout,*) ' '//cobstypes(jtype)//' input observation file names:' + DO jfile = 1, ifiles(jtype) + WRITE(numout,*) ' '//TRIM(cfiles(jtype,jfile)) + END DO + ENDIF + + END DO + + END SUBROUTINE obs_settypefiles + + SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein, & + & n2dint_default, n2dint_type, & + & ravglamscl_type, ravgphiscl_type, & + & lfp_indegs_type, lavnight_type, & + & n2dint, ravglamscl, ravgphiscl, & + & lfpindegs, lavnight ) + + INTEGER, INTENT(IN) :: ntypes ! Total number of obs types + INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs + INTEGER, INTENT(IN) :: n2dint_default ! Default option for interpolation type + INTEGER, INTENT(IN) :: n2dint_type ! Option for interpolation type + REAL(wp), INTENT(IN) :: & + & ravglamscl_type, & !E/W diameter of obs footprint for this type + & ravgphiscl_type !N/S diameter of obs footprint for this type + LOGICAL, INTENT(IN) :: lfp_indegs_type !T=> footprint in degrees, F=> in metres + LOGICAL, INTENT(IN) :: lavnight_type !T=> obs represent night time average + CHARACTER(len=8), INTENT(IN) :: ctypein + + INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & + & n2dint + REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: & + & ravglamscl, ravgphiscl + LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: & + & lfpindegs, lavnight + + lavnight(jtype) = lavnight_type + + IF ( (n2dint_type >= 0) .AND. (n2dint_type <= 6) ) THEN + n2dint(jtype) = n2dint_type + ELSE IF ( n2dint_type == -1 ) THEN + n2dint(jtype) = n2dint_default + ELSE + CALL ctl_stop(' Choice of '//TRIM(ctypein)//' horizontal (2D) interpolation method', & + & ' is not available') + ENDIF + + ! For averaging observation footprints set options for size of footprint + IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN + IF ( ravglamscl_type > 0._wp ) THEN + ravglamscl(jtype) = ravglamscl_type + ELSE + CALL ctl_stop( 'Incorrect value set for averaging footprint '// & + 'scale (ravglamscl) for observation type '//TRIM(ctypein) ) + ENDIF + + IF ( ravgphiscl_type > 0._wp ) THEN + ravgphiscl(jtype) = ravgphiscl_type + ELSE + CALL ctl_stop( 'Incorrect value set for averaging footprint '// & + 'scale (ravgphiscl) for observation type '//TRIM(ctypein) ) + ENDIF + + lfpindegs(jtype) = lfp_indegs_type + + ENDIF + + ! Write out info + IF(lwp) THEN + IF ( n2dint(jtype) <= 4 ) THEN + WRITE(numout,*) ' '//TRIM(ctypein)// & + & ' model counterparts will be interpolated horizontally' + ELSE IF ( n2dint(jtype) <= 6 ) THEN + WRITE(numout,*) ' '//TRIM(ctypein)// & + & ' model counterparts will be averaged horizontally' + WRITE(numout,*) ' '//' with E/W scale: ',ravglamscl(jtype) + WRITE(numout,*) ' '//' with N/S scale: ',ravgphiscl(jtype) + IF ( lfpindegs(jtype) ) THEN + WRITE(numout,*) ' '//' (in degrees)' + ELSE + WRITE(numout,*) ' '//' (in metres)' + ENDIF + ENDIF + ENDIF + + END SUBROUTINE obs_setinterpopts + +END MODULE diaobs \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/find_obs_proc.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/find_obs_proc.h90 new file mode 100644 index 0000000..b947b17 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/find_obs_proc.h90 @@ -0,0 +1,60 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: find_obs_proc.h90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE find_obs_proc(kldi,klei,kldj,klej,kmyproc,kobsp,kobsi,kobsj,kno) + !!---------------------------------------------------------------------- + !! *** ROUTINE find_obs_proc *** + !! + !! ** Purpose : From the array kobsp containing the results of the grid + !! grid search on each processor the processor return a + !! decision of which processors should hold the observation. + !! + !! ** Method : Use i and j and halo regions to decide which processor to + !! put ob in. Intended to avoid the mpp calls required by + !! obs_mpp_find_obs_proc + !! + !! History : + !!! 03-08 (D. Lea) Original code + !!----------------------------------------------------------------------- + + !! * Arguments + + INTEGER, INTENT(IN) :: kldi ! Start of inner domain in i + INTEGER, INTENT(IN) :: klei ! End of inner domain in i + INTEGER, INTENT(IN) :: kldj ! Start of inner domain in j + INTEGER, INTENT(IN) :: klej ! End of inner domain in j + + INTEGER, INTENT(IN) :: kmyproc + INTEGER, INTENT(IN) :: kno + + INTEGER, DIMENSION(kno), INTENT(IN) :: kobsi + INTEGER, DIMENSION(kno), INTENT(IN) :: kobsj + INTEGER, DIMENSION(kno), INTENT(INOUT) :: kobsp + + !! * local variables + INTEGER :: & + & ji + + ! first and last indoor i- and j-indexes kldi, klei, kldj, klej + ! exclude any obs in the bottom-left overlap region + ! also any obs outside to whole region (defined by jpi and jpj) + ! I am assuming that kobsp does not need to be the correct processor + ! number + + DO ji = 1, kno + IF (kobsi(ji) < kldi .OR. kobsj(ji) < kldj & + .OR. kobsi(ji) > klei .OR. kobsj(ji) > klej) THEN + IF (lwp .AND. kobsp(ji) /= -1) WRITE(numout,*) & + & 'kobs: ',kobsi(ji), kobsj(ji), kobsp(ji) + kobsp(ji)=1000000 + ENDIF + END DO + + ! Ensure that observations not in processor are masked + + WHERE(kobsp(:) /= kmyproc) kobsp(:)=1000000 + + END SUBROUTINE find_obs_proc \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/greg2jul.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/greg2jul.h90 new file mode 100644 index 0000000..d815b0d --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/greg2jul.h90 @@ -0,0 +1,89 @@ +SUBROUTINE greg2jul( ksec, kmin, khour, kday, kmonth, kyear, pjulian, & + & krefdate ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE greg2jul *** + !! + !! ** Purpose : Produce the time relative to the current date and time. + !! + !! ** Method : The units are days, so hours and minutes transform to + !! fractions of a day. + !! + !! Reference date : 19500101 + !! ** Action : + !! + !! History : + !! ! 06-04 (A. Vidard) Original + !! ! 06-04 (A. Vidard) Reformatted + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + ! * Arguments + INTEGER, INTENT(IN) :: & + & ksec, & + & kmin, & + & khour, & + & kday, & + & kmonth, & + & kyear + REAL(KIND=dp), INTENT(OUT) :: & + & pjulian + INTEGER, INTENT(IN), OPTIONAL :: & + & krefdate + + !! * Local declarations + INTEGER, PARAMETER :: & + & jpgreg = 15 + 31 * ( 10 + 12 * 1582 ), & ! Gregorian calendar introduction date + & jporef = 2433283, & ! Julian reference date: 19500101 + & jparef = 2415021, & ! Julian reference date: 19000101 + & jpgref = 2299161 ! Julian reference date start of Gregorian calender + INTEGER :: & + & ija, & + & ijy, & + & ijm, & + & ijultmp, & + & ijyear, & + & iref + CHARACTER(len=200) :: & + & cerr + + IF ( PRESENT( krefdate ) ) THEN + SELECT CASE ( krefdate ) + + CASE( 0 ) + iref = jpgref + + CASE( 19500101 ) + iref = jporef + + CASE( 19000101 ) + iref = jparef + + CASE DEFAULT + WRITE(cerr,'(A,I8.8)')'greg2jul: Unknown krefdate:', krefdate + CALL ctl_stop( cerr ) + + END SELECT + + ELSE + iref = jporef + ENDIF + + ! Main computation + ijyear = kyear + IF ( ijyear < 0 ) ijyear = ijyear + 1 + IF ( kmonth > 2 ) THEN + ijy = ijyear + ijm = kmonth + 1 + ELSE + ijy = ijyear - 1 + ijm = kmonth + 13 + ENDIF + ijultmp = INT( 365.25 * ijy ) + INT( 30.6001 * ijm ) + kday + 1720995 + IF ( kday + 31 * ( kmonth + 12 * ijyear ) >= jpgreg ) THEN + ija = INT( 0.01 * ijy ) + ijultmp = ijultmp + 2 - ija + INT( 0.25 * ija ) + ENDIF + pjulian = ( ijultmp - iref ) + ( ( 60 * khour + kmin ) * 60 + ksec ) / 86400. + + END SUBROUTINE greg2jul \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/grt_cir_dis.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/grt_cir_dis.h90 new file mode 100644 index 0000000..c4ea5c2 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/grt_cir_dis.h90 @@ -0,0 +1,39 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: grt_cir_dis.h90 13226 2020-07-02 14:24:31Z orioltp $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(KIND=wp) FUNCTION grt_cir_dis( pa1, pa2, pb1, pb2, pc1, pc2 ) + !!---------------------------------------------------------------------- + !! *** FUNCTION grt_cir_dis *** + !! + !! ** Purpose : Great circle distance between pts (lat1,lon1) + !! & (lat2,lon2) + !! + !! ** Method : Geometry. + !! + !! History : + !! ! 1995-12 (G. Madec, E. Durand, A. Weaver, N. Daget) Original + !! ! 2006-03 (A. Vidard) Migration to NEMOVAR + !! ! 2006-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp) :: pa1 ! sin(lat1) + REAL(KIND=wp) :: pa2 ! sin(lat2) + REAL(KIND=wp) :: pb1 ! cos(lat1) * cos(lon1) + REAL(KIND=wp) :: pb2 ! cos(lat2) * cos(lon2) + REAL(KIND=wp) :: pc1 ! cos(lat1) * sin(lon1) + REAL(KIND=wp) :: pc2 ! cos(lat2) * sin(lon2) + + REAL(KIND=wp) :: cosdist ! cosine of great circle distance + + ! Compute cosine of great circle distance, constraining it to be between + ! -1 and 1 (rounding errors can take it slightly outside this range + cosdist = MAX( MIN( pa1 * pa2 + pb1 * pb2 + pc1 * pc2, 1.0_wp), -1.0_wp ) + + grt_cir_dis = & + & ASIN( SQRT( 1.0_wp - cosdist**2.0_wp ) ) + + END FUNCTION grt_cir_dis \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/grt_cir_dis_saa.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/grt_cir_dis_saa.h90 new file mode 100644 index 0000000..c76484a --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/grt_cir_dis_saa.h90 @@ -0,0 +1,31 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: grt_cir_dis_saa.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(KIND=wp) FUNCTION grt_cir_dis_saa( pa, pb, pc ) + !!---------------------------------------------------------------------- + !! *** FUNCTION grt_cir_dis_saa *** + !! + !! ** Purpose : Great circle distance between pts (lat1,lon1) + !! & (lat2,lon2) with a small-angle approximation + !! + !! ** Method : Geometry + !! + !! ** Action : + !! + !! History + !! ! 95-12 (G. Madec, E. Durand, A. Weaver, N. Daget) Original + !! ! 06-03 (A. Vidard) Migration to NEMOVAR + !! ! 06-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp) :: pa ! lon1 - lon2 + REAL(KIND=wp) :: pb ! lat1 - lat2 + REAL(KIND=wp) :: pc ! cos(lat2) + + grt_cir_dis_saa = SQRT( pa * pa + ( pb * pc )**2 ) + + END FUNCTION grt_cir_dis_saa \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/jul2greg.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/jul2greg.h90 new file mode 100644 index 0000000..f7087c9 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/jul2greg.h90 @@ -0,0 +1,115 @@ +RECURSIVE SUBROUTINE jul2greg( ksec, kminut, khour, kday, kmonth, kyear, & + & prelday, krefdate ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE jul2greg *** + !! + !! ** Purpose : Take the relative time in days and re-express in terms of + !! seconds, minutes, hours, days, month, year. + !! + !! ** Method : Reference date : 19500101 + !! + !! ** Action : + !! + !! History + !! ! 06-04 (A. Vidard) Original + !! ! 06-05 (A. Vidard) Reformatted and refdate + !! ! 06-10 (A. Weaver) Cleanup + !! ! 2014-09 (D. Lea) Change to use FLOOR to deal with negative prelday + !!----------------------------------------------------------------------- + + ! * Arguments + INTEGER, INTENT(IN), OPTIONAL :: & + & krefdate + INTEGER, INTENT(OUT) :: & + & ksec, & + & kminut, & + & khour, & + & kday, & + & kmonth, & + & kyear + REAL(KIND=dp), INTENT(IN) :: & + & prelday + + !! * Local declarations + INTEGER, PARAMETER :: & + & jpgreg = 2299161, & + & jporef = 2433283, & + & jparef = 2415021 + INTEGER :: & + & ijulian, & + & ij1, & + & ija, & + & ijb, & + & ijc, & + & ijd, & + & ije, & + & isec, & + & imin, & + & ihou, & + & iday, & + & imon, & + & iyea, & + & iref + REAL(KIND=wp) :: & + & zday, & + & zref + CHARACTER(len=200) :: & + & cerr + + ! Main computation + IF ( PRESENT( krefdate ) ) THEN + + SELECT CASE ( krefdate ) + + CASE( 0 ) + iref = jpgreg + + CASE( 19500101 ) + iref = jporef + + CASE( 19000101 ) + iref = jparef + + CASE DEFAULT + WRITE(cerr,'(A,I8.8)')'jul2greg: Unknown krefdate:', krefdate + CALL ctl_stop( cerr ) + + END SELECT + + ELSE + iref = jporef + ENDIF + + zday = prelday + ksec = FLOOR( 86400. * MOD( zday, 1. ) ) + + IF ( ksec < 0. ) ksec = 86400. + ksec + + khour = ksec / 3600 + kminut = ( ksec - 3600 * khour ) / 60 + ksec = MOD( ksec , 60 ) + + ijulian = iref + INT( zday ) + IF ( zday < 0. ) ijulian = ijulian - 1 + + ! If input date after 10/15/1582 : + IF ( ijulian >= jpgreg ) THEN + ij1 = INT( ( DBLE( ijulian - 1867216 ) - 0.25 ) / 36524.25 ) + ija = ijulian + 1 + ij1 - INT( ( 0.25 * ij1 ) ) + ELSE + ija = ijulian + ENDIF + + ijb = ija + 1524 + ijc = INT( 6680. + ( DBLE ( ijb - 2439870 ) - 122.1 ) / 365.25 ) + ijd = 365 * ijc + INT( 0.25 * ijc ) + ije = INT( ( ijb - ijd ) / 30.6001 ) + kday = ijb - ijd - INT( 30.6001 * ije ) + kmonth = ije - 1 + IF ( kmonth > 12 ) kmonth = kmonth - 12 + kyear = ijc - 4715 + IF ( kmonth > 2 ) kyear = kyear - 1 + IF ( kyear <= 0 ) kyear = kyear - 1 + + END SUBROUTINE jul2greg \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/julian.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/julian.F90 new file mode 100644 index 0000000..7e3274b --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/julian.F90 @@ -0,0 +1,33 @@ +MODULE julian + !!====================================================================== + !! *** MODULE julian *** + !! Ocean : Julian data utilities + !!===================================================================== + + !!---------------------------------------------------------------------- + !! jul2greg : Convert relative time to date + !! greg2jul : Convert date to relative time + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp, & + & dp + !USE in_out_manager ! I/O manager + USE lib_mpp, ONLY : & + & ctl_warn, ctl_stop + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + PUBLIC jul2greg, & ! Convert relative time to date + & greg2jul ! Convert date to relative time + + !! $Id: julian.F90 5215 2015-04-15 16:11:56Z nicolasmartin $ +CONTAINS + +#include "jul2greg.h90" + +#include "greg2jul.h90" + +END MODULE julian \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/linquad.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/linquad.h90 new file mode 100644 index 0000000..b6d1e17 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/linquad.h90 @@ -0,0 +1,58 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: linquad.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + LOGICAL FUNCTION linquad( px, py, pxv, pyv ) + !!---------------------------------------------------------------------- + !! *** FUNCTION linquad *** + !! + !! ** Purpose : Determine whether a point P(x,y) lies within or on the + !! boundary of a quadrangle (ABCD) of any shape on a plane. + !! + !! ** Method : Check if the vectorial products PA x PC, PB x PA, + !! PC x PD, and PD x PB are all negative. + !! + !! ** Action : + !! + !! History : + !! ! 2001-11 (N. Daget, A. Weaver) + !! ! 2006-08 (A. Weaver) NEMOVAR migration + !! ! 2006-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: px ! (lon) of the point P(x,y) + REAL(KIND=wp), INTENT(IN) :: py ! (lat) of the point P(x,y) + REAL(KIND=wp), DIMENSION(4), INTENT(IN) :: & + & pxv, & ! (lon, lat) of the surrounding cell + & pyv + + !! * Local declarations + REAL(KIND=wp) :: zst1 + REAL(KIND=wp) :: zst2 + REAL(KIND=wp) :: zst3 + REAL(KIND=wp) :: zst4 + + !----------------------------------------------------------------------- + ! Test to see if the point is within the cell + !----------------------------------------------------------------------- + linquad = .FALSE. + zst1 = ( px - pxv(1) ) * ( py - pyv(4) ) & + & - ( py - pyv(1) ) * ( px - pxv(4) ) + IF ( zst1 <= 0.0 ) THEN + zst2 = ( px - pxv(4) ) * ( py - pyv(3) ) & + & - ( py - pyv(4) ) * ( px - pxv(3) ) + IF ( zst2 <= 0.0 ) THEN + zst3 = ( px - pxv(3) ) * ( py - pyv(2) ) & + & - ( py - pyv(3) ) * ( px - pxv(2) ) + IF ( zst3 <= 0.0) THEN + zst4 = ( px - pxv(2) ) * ( py - pyv(1) ) & + & - ( py - pyv(2) ) * ( px - pxv(1) ) + IF ( zst4 <= 0.0 ) linquad = .TRUE. + ENDIF + ENDIF + ENDIF + + END FUNCTION linquad \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/maxdist.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/maxdist.h90 new file mode 100644 index 0000000..48bfdbe --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/maxdist.h90 @@ -0,0 +1,76 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: maxdist.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(wp) FUNCTION maxdist( pxv, pyv ) + !!---------------------------------------------------------------------- + !! *** FUNCTION maxdist *** + !! + !! ** Purpose : Compute the maximum distance between any points within + !! a cell + !! + !! ** Method : Call to grt_cir_dis + !! + !! ** Action : + !! + !! History : + !! ! 2006-08 (K. Mogensen) + !! ! 2006-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), DIMENSION(4), INTENT(IN) :: & + & pxv, & ! (lon, lat) of the surrounding cell + & pyv + + !! * Local declarations + REAL(KIND=wp), DIMENSION(4) :: & + & zxv, & + & zyv, & + & za, & + & zb, & + & zc + REAL(KIND=wp) :: zdist + + INTEGER :: ji + INTEGER :: jj + + !----------------------------------------------------------------------- + ! Convert data to radians + !----------------------------------------------------------------------- + DO ji = 1, 4 + zxv(ji) = pxv(ji) * rad + zyv(ji) = pyv(ji) * rad + END DO + + !----------------------------------------------------------------------- + ! Prepare input to grt_cir_dis + !----------------------------------------------------------------------- + DO ji = 1, 4 + za(ji) = SIN( zyv(ji) ) + zb(ji) = COS( zyv(ji) ) * COS( zxv(ji) ) + zc(ji) = COS( zyv(ji) ) * SIN( zxv(ji) ) + END DO + + !----------------------------------------------------------------------- + ! Get max distance between any points in the area + !----------------------------------------------------------------------- + maxdist = 0.0 + DO jj = 1, 4 + DO ji = jj+1, 4 + zdist = grt_cir_dis( za(jj), za(ji), zb(jj), & + & zb(ji), zc(jj), zc(ji)) + IF ( zdist > maxdist ) THEN + maxdist = zdist + ENDIF + END DO + END DO + + !----------------------------------------------------------------------- + ! Convert to degrees. + !----------------------------------------------------------------------- + maxdist = maxdist / rad + + END FUNCTION maxdist \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/mpp_map.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/mpp_map.F90 new file mode 100644 index 0000000..dd87509 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/mpp_map.F90 @@ -0,0 +1,85 @@ +MODULE mpp_map + !!====================================================================== + !! *** MODULE mpp_mpa *** + !! NEMOVAR: MPP global grid point mapping to processors + !!====================================================================== + !! History : 2.0 ! 2007-08 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! mppmap_init : Initialize mppmap. + !!---------------------------------------------------------------------- + USE par_kind, ONLY : wp ! Precision variables + USE par_oce , ONLY : jpi, jpj, Nis0, Nie0, Njs0, Nje0 ! Ocean parameters + USE dom_oce , ONLY : mig, mjg, narea ! Ocean space and time domain variables +#if ! defined key_mpi_off + USE lib_mpp , ONLY : mpi_comm_oce ! MPP library +#endif + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC :: mppmap_init, mppmap !: ??? + + INTEGER, DIMENSION(:,:), ALLOCATABLE :: mppmap ! ??? + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: mpp_map.F90 14229 2020-12-20 12:45:55Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE mppmap_init + !!---------------------------------------------------------------------- + !! *** ROUTINE mppmap_init *** + !! + !! ** Purpose : Setup a global map of processor rank for all gridpoints + !! + !! ** Method : MPI all reduce. + !! + !! ** Action : This does only work for MPI. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(:,:), ALLOCATABLE :: imppmap ! +#if ! defined key_mpi_off + INTEGER :: ierr + +INCLUDE 'mpif.h' +#endif + !!---------------------------------------------------------------------- + + IF (.NOT. ALLOCATED(mppmap)) THEN + ALLOCATE( & + & mppmap(jpiglo,jpjglo) & + & ) + ENDIF + ! Initialize local imppmap + + ALLOCATE( & + & imppmap(jpiglo,jpjglo) & + & ) + imppmap(:,:) = 0 + +! ! Setup local grid points + imppmap(mig(1):mig(jpi),mjg(1):mjg(jpj)) = narea + + ! Get global data + +#if ! defined key_mpi_off + + ! Call the MPI library to find the max across processors + CALL mpi_allreduce( imppmap, mppmap, jpiglo*jpjglo, mpi_integer, & + & mpi_max, mpi_comm_oce, ierr ) +#else + + ! No MPP: Just copy the data + mppmap(:,:) = imppmap(:,:) +#endif + ! + END SUBROUTINE mppmap_init + + !!====================================================================== +END MODULE mpp_map \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_averg_h2d.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_averg_h2d.F90 new file mode 100644 index 0000000..d019f6f --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_averg_h2d.F90 @@ -0,0 +1,821 @@ +MODULE obs_averg_h2d + !!====================================================================== + !! *** MODULE obs_averg_h2d *** + !! Observation diagnostics: Perform the horizontal averaging + !! from model grid to observation footprint + !!===================================================================== + + !!---------------------------------------------------------------------- + !! obs_averg_h2d : Horizontal averaging to the observation footprint + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp + USE par_oce, ONLY : & + & jpi, jpj + USE phycst, ONLY : & ! Physical constants + & rad, & + & ra, & + & rpi + USE dom_oce, ONLY : & + & e1t, e2t, & + & e1f, e2f, & + & glamt, gphit + USE in_out_manager + USE obs_const, ONLY : & + & obfillflt ! Fillvalue + USE obs_utils ! Utility functions + USE lib_mpp, ONLY : & + & ctl_warn, ctl_stop, & + & mpp_min, lk_mpp + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE obs_avg_h2d_rad, & ! Horizontal averaging using a radial footprint + & obs_avg_h2d_rec, & ! Horizontal averaging using a rectangular footprint + & obs_deg2dist, & ! Conversion of distance in degrees to distance in metres + & obs_dist2corners ! Distance from the centre of obs footprint to the corners of a grid box + + PUBLIC obs_avg_h2d, & ! Horizontal averaging to the observation footprint + & obs_avg_h2d_init, & ! Set up weights for the averaging + & obs_max_fpsize ! Works out the maximum number of grid points required for the averaging + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_averg_h2d.F90 14275 2021-01-07 12:13:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + SUBROUTINE obs_avg_h2d_init( kpk, kpk2, kmaxifp, kmaxjfp, k2dint, plam, pphi, & + & pglam, pgphi, pglamf, pgphif, pmask, plamscl, pphiscl, lindegrees, & + & pweig, iminpoints ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_avg_h2d_init *** + !! + !! ** Purpose : Computes weights for horizontal averaging to the + !! observation footprint. + !! + !! ** Method : Horizontal averaging to the observation footprint using + !! model values at a defined area. + !! + !! Averaging schemes : + !! + !! Two horizontal averaging schemes are available: + !! - weighted radial footprint (k2dint = 5) + !! - weighted rectangular footprint (k2dint = 6) + !! + !! History : + !! ! 13-10 (M. Martin) + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk, & ! Parameter values for automatic arrays + & kpk2, & + & kmaxifp, & ! Max size of model points in i-direction for obs footprint + & kmaxjfp, & ! Max size of model points in j-direction for obs footprint + & k2dint ! Averaging scheme options - see header + REAL(KIND=wp), INTENT(INOUT) :: & + & plam, & ! Geographical (lat,lon) coordinates of + & pphi ! observation + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: & + & pglam, & ! Model variable lon + & pgphi ! Model variable lat + REAL(KIND=wp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: & + & pglamf, & ! Model variable lon at corners of grid-boxes + & pgphif ! Model variable lat at corners of grid-boxes + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & ! Diameter (lat,lon) of obs footprint in metres + & pphiscl ! This is the full width (rather than half-width) + LOGICAL, INTENT(IN) :: & + & lindegrees ! T=> obs footprint specified in degrees, F=> in metres + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) :: & + & pweig ! Weights for averaging + INTEGER, INTENT(IN), OPTIONAL :: & + & iminpoints ! Reject point which is not surrounded + ! by at least iminpoints sea points + + !! * Local declarations + INTEGER :: & + & jk + INTEGER :: & + & ikmax + + + !------------------------------------------------------------------------ + ! + !------------------------------------------------------------------------ + + !------------------------------------------------------------------------ + ! Initialize number of levels + !------------------------------------------------------------------------ + IF ( kpk2 == 1 ) THEN + ikmax = 1 + ELSEIF ( kpk2 == kpk) THEN + ikmax = kpk-1 + ENDIF + + + SELECT CASE (k2dint) + CASE(5) + CALL obs_avg_h2d_rad( kpk2, ikmax, kmaxifp, kmaxjfp, plam, pphi, & + & plamscl, pphiscl, lindegrees, pmask, pglam, pgphi, pglamf, pgphif, pweig ) + CASE(6) + CALL obs_avg_h2d_rec( kpk2, ikmax, kmaxifp, kmaxjfp, plam, pphi, & + & plamscl, pphiscl, lindegrees, pmask, pglam, pgphi, pglamf, pgphif, pweig ) + END SELECT + + + END SUBROUTINE obs_avg_h2d_init + + + SUBROUTINE obs_avg_h2d_rad( kpk2, kmax, kmaxifp, kmaxjfp, plam, pphi, & + & plamscl, pphiscl, lindegrees, pmask, pglam, pgphi, pglamf, pgphif, pweig ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_avg_h2d_rad *** + !! + !! ** Purpose : Computes weights for horizontal averaging to the + !! observation using a radial footprint. + !! + !! ** Method : Calculate whether each grid box is completely or + !! partially within the observation footprint. + !! If it is partially in the footprint then calculate + !! the ratio of the area inside the footprint to the total + !! area of the grid box. + !! + !! History : + !! ! 14-01 (M. Martin) + !!----------------------------------------------------------------------- + !! * Modules used + USE phycst, ONLY : & ! Physical constants + & ra, & + & rpi + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + + INTEGER, INTENT(IN) :: & + & kmaxifp, & ! Max size of model points in i-direction for obs footprint + & kmaxjfp ! Max size of model points in j-direction for obs footprint + + REAL(KIND=wp), INTENT(IN) :: & + & plam, & + & pphi ! Geographical (lat,lon) coordinates of + ! observation + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & ! Diameter (lat,lon) of obs footprint in metres or degrees (see below) + & pphiscl ! This is the full width (rather than half-width) + LOGICAL, INTENT(IN) :: & + & lindegrees ! T=>scales specified in degrees, F=> in metres + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: & + & pglam, & ! Model variable lon + & pgphi ! Model variable lat + REAL(KIND=wp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: & + & pglamf, & ! Model variable lon at corners of grid boxes + & pgphif ! Model variable lat at corners of grid boxes + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) :: & + & pweig ! Weights for interpolation + + !! Local declarations + INTEGER :: ji, jj, jk + INTEGER :: jvert, jis, jjs + INTEGER :: jnumvert, jnumvertbig + INTEGER, PARAMETER :: & + & jnumsubgrid = 20 ! The number of sub grid-boxes (in x and y directions) used to approximate area of obs fp + + REAL(KIND=wp), DIMENSION(4) :: & + & zxvert, zyvert, & ! The lon/lat of the vertices(corners) of the grid box in m relative to centre of obs fp + & zdist ! Distance of each vertex to the centre of the obs footprint + REAL(KIND=wp), DIMENSION(4) :: & + & zxgrid, zygrid, & ! Distance of each vertex of grid box to the centre of the grid box in x/y directions + & zdgrid + REAL(KIND=wp) :: & + & zdx, zdy, & ! The sub grid-box sizes (in metres) + & zarea_subbox, & ! The area of each sub grid-box (in metres squared) + & zxpos, zypos, & ! The x,y position (relative to centre of obs footprint) of the centre of each sub grid-box + & zsubdist, & ! The distance of the centre of each sub grid-box from the centre of the obs footprint + & zarea_fp, & ! Total area of obs footprint within the grid box + & zareabox ! Total area of the grid box + REAL(KIND=wp) :: & + & zphiscl_m, & ! Diameter of obs footprint in metres + & zlamscl_m + !--------------------------------------------------------------------------------------------------- + !Initialise weights to zero. + pweig(:,:,:) = 0.0_wp + + !Two footprint sizes can be specified in the namelist but this routine assumes a circular footprint. + !If the two sizes are different then write out a warning. + IF ( pphiscl /= plamscl ) THEN + CALL ctl_warn( 'obs_avg_h2d_rad:', & + & 'The two components of the obs footprint size are not equal', & + & 'yet the radial option has been selected - using pphiscl here' ) + ENDIF + + DO jk = 1, kmax + DO ji = 1, kmaxifp + DO jj = 1, kmaxjfp + + IF ( pmask(ji,jj,jk) == 1.0_wp ) THEN + + IF ( lindegrees ) THEN + !If the scales are specified in degrees, work out the + !scales (metres) in x/y directions + CALL obs_deg2dist( 1, 1, pglam(ji,jj), pgphi(ji,jj), & + & plamscl, pphiscl, zlamscl_m, zphiscl_m ) + ELSE + zphiscl_m = pphiscl + ENDIF + + + ! Work out the area of the grid box using distance of corners relative to centre of grid box + CALL obs_dist2corners(pglamf(ji,jj), pglamf(ji+1,jj), pglamf(ji,jj+1), pglamf(ji+1,jj+1), & + & pgphif(ji,jj), pgphif(ji+1,jj), pgphif(ji,jj+1), pgphif(ji+1,jj+1), & + & pglam(ji,jj), pgphi(ji,jj), zxgrid, zygrid, zdgrid) + zareabox = ABS( zxgrid(1) - zxgrid(2) ) * ABS( zygrid(1) - zygrid(4) ) + + !1. Determine how many of the vertices of the grid box lie within the circle + + !For each vertex, calculate its location and distance relative + !to the centre of the observation footprint + + CALL obs_dist2corners(pglamf(ji,jj), pglamf(ji+1,jj), pglamf(ji,jj+1), pglamf(ji+1,jj+1), & + & pgphif(ji,jj), pgphif(ji+1,jj), pgphif(ji,jj+1), pgphif(ji+1,jj+1), & + & plam, pphi, zxvert, zyvert, zdist) + + jnumvert = 0 + jnumvertbig = 0 + DO jvert = 1, 4 + + !If the distance to the center to the observation footprint is less + !than the radius of the footprint (half the diameter) then this + !vertex is within the observation footprint + IF ( zdist(jvert) <= ( zphiscl_m / 2.0_wp ) ) jnumvert = jnumvert + 1 + + !For expediency, check if the vertices are "nearly" within the obs + !footprint as if none of them are close to the edge of the footprint + !then the footprint is unlikely to be intersecting the grid box + IF ( zdist(jvert) - ( 0.5_wp * zareabox ) <= ( zphiscl_m / 2.0 ) ) & + & jnumvertbig = jnumvertbig + 1 + + END DO + + !2. If none of the vertices are even close to the edge of the obs + !footprint then leave weight as zero and cycle to next grid box. + IF ( jnumvertbig == 0 ) CYCLE + + !3. If all the vertices of the box are within the observation footprint then the + ! whole grid box is within the footprint so set the weight to one and + ! move to the next grid box. + IF ( jnumvert == 4 ) THEN + pweig(ji,jj,jk) = 1.0_wp + CYCLE + ENDIF + + + !4. Use a brute force technique for calculating the area within + ! the grid box covered by the obs footprint. + ! (alternative could be to use formulae on + ! http://mathworld.wolfram.com/Circle-LineIntersection.html) + ! For now split the grid box into a specified number of smaller + ! boxes and add up the area of those whose centre is within the obs footprint. + ! Order of vertices is 1=topleft, 2=topright, 3=bottomright, 4=bottomleft + zdx = ABS( zxvert(3) - zxvert(4) ) / REAL(jnumsubgrid, wp) + zdy = ABS( zyvert(1) - zyvert(4) ) / REAL(jnumsubgrid, wp) + zarea_subbox = zdx * zdy + + zarea_fp = 0.0_wp + DO jis = 1, jnumsubgrid + zxpos = zxvert(4) + ( REAL(jis, wp) * zdx ) - (0.5_wp * zdx ) + DO jjs = 1, jnumsubgrid + !Find the distance of the centre of this sub grid box to the + !centre of the obs footprint + zypos = zyvert(4) + ( REAL(jjs, wp) * zdy ) - ( 0.5_wp * zdy ) + zsubdist = SQRT( (zxpos * zxpos) + (zypos * zypos) ) + IF ( zsubdist < ( zphiscl_m / 2.0_wp ) ) & + & zarea_fp = zarea_fp + zarea_subbox + END DO + END DO + + !6. Calculate the ratio of the area of the footprint within the box + ! to the total area of the grid box and use this fraction to weight + ! the model value in this grid box. + pweig(ji,jj,jk) = MIN( zarea_fp / zareabox, 1.0_wp ) + + END IF !pmask + END DO + END DO + END DO + + END SUBROUTINE obs_avg_h2d_rad + + + SUBROUTINE obs_avg_h2d_rec( kpk2, kmax, kmaxifp, kmaxjfp, plam, pphi, & + & plamscl, pphiscl, lindegrees, pmask, pglam, pgphi, pglamf, pgphif, pweig ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_avg_h2d_rec *** + !! + !! ** Purpose : Computes weights for horizontal averaging to the + !! observation using a rectangular footprint which + !! is aligned with lines of lat/lon. + !! + !! ** Method : Horizontal averaging to the observation footprint using + !! model values at a defined area. + !! + !! History : + !! ! 14-01 (M. Martin) + !!----------------------------------------------------------------------- + !! * Modules used + USE phycst, ONLY : & ! Physical constants + & ra, & + & rpi + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + + INTEGER, INTENT(IN) :: & + & kmaxifp, & ! Max size of model points in i-direction for obs footprint + & kmaxjfp ! Max size of model points in j-direction for obs footprint + + REAL(KIND=wp), INTENT(IN) :: & + & plam, & + & pphi ! Geographical (lat,lon) coordinates of + ! observation + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & + & pphiscl ! Width in x/y directions of obs footprint in metres + ! This is the full width (rather than half-width) + LOGICAL, INTENT(IN) :: & + & lindegrees !T=> scales specified in degrees, F=> in metres + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp), INTENT(IN) :: & + & pglam, & ! Model variable lat at centre of grid boxes + & pgphi ! Model variable lon at centre of grid boxes + REAL(KIND=wp), DIMENSION(kmaxifp+1,kmaxjfp+1), INTENT(IN) :: & + & pglamf, & ! Model variable lat at corners of grid boxes + & pgphif ! Model variable lon at corners of grid boxes + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(OUT) :: & + & pweig ! Weights for interpolation + + !! Local declarations + INTEGER :: ji, jj, jk + INTEGER :: jvert + INTEGER, DIMENSION(4) :: & + & jnumvert + REAL(KIND=wp), DIMENSION(4) :: & + & zxvert, zyvert ! The lon/lat of the vertices(corners) of the grid box in m relative to centre of obs fp + REAL(KIND=wp), DIMENSION(4) :: & + & zdist ! Distance of each vertex to the centre of the obs footprint + REAL(KIND=wp), DIMENSION(4) :: & + & zxgrid, zygrid, & ! Distance of each vertex of grid box to the centre of the grid box in x/y directions + & zdgrid + REAL(KIND=wp) :: & + & zareabox, & ! Total area of grid box + & zarea_fp, & ! Total area of obs footprint + & zarea_intersect ! Area of the intersection between the grid box and the obs footprint + REAL(KIND=wp) :: & + & zlamscl_m, & + & zphiscl_m ! Total width (lat,lon) of obs footprint in metres + REAL(KIND=wp) :: & + & z_awidth, z_aheight, & ! Width and height of model grid box + & z_cwidth, z_cheight ! Width and height of union of model grid box and obs footprint + REAL(KIND=wp) :: & + & zleft, zright, & ! Distance (metres) of corners area of intersection + & ztop, zbottom ! between grid box and obs footprint + + !----------------------------------------------------------------------- + + !Initialise weights to zero + pweig(:,:,:) = 0.0_wp + + !Loop over the grid boxes which have been identified as potentially being within the + !observation footprint + DO jk = 1, kmax + DO ji = 1, kmaxifp + DO jj = 1, kmaxjfp + + IF ( pmask(ji,jj,jk) == 1.0_wp ) THEN + + + IF ( lindegrees ) THEN + !If the scales are specified in degrees, work out the + !scales (metres) in x/y directions + CALL obs_deg2dist( 1, 1, pglam(ji,jj), pgphi(ji,jj), & + & plamscl, pphiscl, zlamscl_m, zphiscl_m ) + ELSE + zlamscl_m = plamscl + zphiscl_m = pphiscl + ENDIF + + ! Work out the area of the grid box using distance of corners relative to centre of grid box + CALL obs_dist2corners(pglamf(ji,jj), pglamf(ji+1,jj), pglamf(ji,jj+1), pglamf(ji+1,jj+1), & + & pgphif(ji,jj), pgphif(ji+1,jj), pgphif(ji,jj+1), pgphif(ji+1,jj+1), & + & pglam(ji,jj), pgphi(ji,jj), zxgrid, zygrid, zdgrid) + + !Calculate width and height of model grid box + z_awidth = ABS( zxgrid(1) - zxgrid(2) ) + z_aheight = ABS( zygrid(1) - zygrid(4) ) + zareabox = z_awidth * z_aheight + + ! Work out area of the observation footprint + zarea_fp = zlamscl_m * zphiscl_m + + ! For each corner of the grid box, calculate its location and distance relative + ! to the centre of the observation footprint + CALL obs_dist2corners(pglamf(ji,jj), pglamf(ji+1,jj), pglamf(ji,jj+1), pglamf(ji+1,jj+1), & + & pgphif(ji,jj), pgphif(ji+1,jj), pgphif(ji,jj+1), pgphif(ji+1,jj+1), & + & plam, pphi, zxvert, zyvert, zdist) + + !Work out maximum width and height of rectangle covered by corners of obs fp and grid box + z_cwidth = MAX( zxvert(1), zxvert(2), -zlamscl_m/2.0_wp, zlamscl_m/2.0_wp ) - & + & MIN( zxvert(1), zxvert(2), -zlamscl_m/2.0_wp, zlamscl_m/2.0_wp ) + + z_cheight = MAX( zyvert(1), zyvert(4), zphiscl_m/2.0_wp, -zphiscl_m/2.0_wp ) - & + & MIN( zyvert(1), zyvert(4), zphiscl_m/2.0_wp, -zphiscl_m/2.0_wp ) + + IF ( ( z_cwidth >= z_awidth + zlamscl_m ) .OR. & + & ( z_cheight >= z_aheight + zphiscl_m ) ) THEN + !The obs footprint and the model grid box don't overlap so set weight to zero + pweig(ji,jj,jk) = 0.0_wp + ELSE IF ( ( z_cwidth == zlamscl_m ) .AND. & + & ( z_cheight == zphiscl_m ) ) THEN + !The grid box is totally contained within the obs footprint so set weight to one + pweig(ji,jj,jk) = 1.0_wp + ELSE IF ( ( z_cwidth == z_awidth ) .AND. & + & ( z_cheight == z_aheight ) ) THEN + !The obs footprint is totally contained within the grid box so set weight as ratio of the two + pweig(ji,jj,jk) = zarea_fp / zareabox + ELSE + !The obs footprint and the grid box overlap so calculate the area of the intersection of the two + zleft = max(zxvert(1), -zlamscl_m/2.0_wp) + zright = min(zxvert(2), zlamscl_m/2.0_wp) + zbottom = max(zyvert(4), -zphiscl_m/2.0_wp) + ztop = min(zyvert(1), zphiscl_m/2.0_wp) + + IF ( ( zleft < zright ) .AND. ( zbottom < ztop ) ) THEN + zarea_intersect = ( zright - zleft ) * ( ztop - zbottom ) + pweig(ji,jj,jk) = zarea_intersect / zareabox + ENDIF + ENDIF + + END IF !pmask + END DO + END DO + END DO + + END SUBROUTINE obs_avg_h2d_rec + + SUBROUTINE obs_avg_h2d( kpk, kpk2, kmaxifp, kmaxjfp, pweig, pmod, pobsk ) + + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d *** + !! + !! ** Purpose : Horizontal averaging to the observation footprint. + !! + !! ** Method : Average the model points based on the weights already calculated. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 13/10. M. Martin. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk, & ! Parameter values for automatic arrays + & kpk2 + INTEGER, INTENT(IN) :: & + & kmaxifp, & ! Max size of model points in i-direction for obs footprint + & kmaxjfp ! Max size of model points in j-direction for obs footprint + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pweig ! Interpolation weights + REAL(KIND=wp), DIMENSION(kmaxifp,kmaxjfp,kpk2), INTENT(IN) :: & + & pmod ! Model variable to interpolate + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & pobsk ! Model profile interpolated to obs (i,j) pt + + INTEGER :: & + & jk + INTEGER :: & + & ikmax + REAL(KIND=wp) :: & + & zsum + + !------------------------------------------------------------------------ + ! Initialize number of levels + !------------------------------------------------------------------------ + IF ( kpk2 == 1 ) THEN + ikmax = 1 + ELSEIF ( kpk2 == kpk) THEN + ikmax = kpk-1 + ENDIF + + !------------------------------------------------------------------------ + ! Average model values to the observation footprint + !------------------------------------------------------------------------ + pobsk = obfillflt + + DO jk = 1, ikmax + + zsum = SUM( pweig(:,:,jk) ) + + IF ( zsum /= 0.0_wp ) THEN + pobsk(jk) = SUM ( pweig(:,:,jk) * pmod(:,:,jk), Mask=pweig(:,:,jk) > 0.0_wp ) + pobsk(jk) = pobsk(jk) / zsum + END IF + + END DO + + END SUBROUTINE obs_avg_h2d + + SUBROUTINE obs_max_fpsize( k2dint, plamscl, pphiscl, lindegrees, pmask, kmaxifp, kmaxjfp ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_max_fpsize *** + !! + !! ** Purpose : Calculate maximum number of grid points which may + !! need to be used in the averaging in the global domain. + !! + !! + !! ** Method : Work out the minimum grid size and work out + !! how many of the smallest grid points would be needed + !! to cover the scale of the observation footprint. + !! This needs to be done using the max/min of the global domain + !! as the obs can be distributed from other parts of the grid. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 14/01. M. Martin. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER , INTENT(IN) :: & + & k2dint !Type of interpolation/averaging used + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & !Total width/radius in metres of the observation footprint + & pphiscl ! + LOGICAL, INTENT(IN) :: & + & lindegrees !T=> plamscl and pphiscl are specified in degrees + REAL(KIND=wp), DIMENSION(jpi,jpj), INTENT(IN) :: & + & pmask !Land/sea mask + !F=> plamscl and pphiscl are specified in metres + INTEGER, INTENT(OUT) :: & + & kmaxifp, & !Max number of grid points in i,j directions to use in averaging + & kmaxjfp !these have to be even so that the footprint is centred + + !! * Local variables + REAL(KIND=wp) :: & + & ze1min, & !Minimum global grid-size in i,j directions + & ze2min + REAL(KIND=wp) :: & + & zphiscl_m, & + & zlamscl_m + !------------------------------------------------------------------------ + + IF ( k2dint <= 4 ) THEN + !If interpolation is being used then only need to use a 2x2 footprint + kmaxifp = 2 + kmaxjfp = 2 + + ELSE + + IF ( lindegrees ) THEN + !If the scales are specified in degrees, work out the max + !distance (metres) in x/y directions + CALL obs_deg2dist( jpi, jpj, glamt, gphit, & + & plamscl, pphiscl, zlamscl_m, zphiscl_m ) + ELSE + zlamscl_m = plamscl + zphiscl_m = pphiscl + ENDIF + + ze1min = MINVAL( e1t(:,:), mask = pmask(:,:) == 1._wp ) + ze2min = MINVAL( e2t(:,:), mask = pmask(:,:) == 1._wp ) + + IF(lk_mpp) THEN + CALL mpp_min( 'obs_averg_h2d', ze1min ) + CALL mpp_min( 'obs_averg_h2d', ze2min ) + ENDIF + + kmaxifp = ceiling(zlamscl_m/ze1min) + 1 + kmaxjfp = ceiling(zphiscl_m/ze2min) + 1 + + !Ensure that these numbers are even + kmaxifp = kmaxifp + MOD(kmaxifp,2) + kmaxjfp = kmaxjfp + MOD(kmaxjfp,2) + + + ENDIF + + END SUBROUTINE obs_max_fpsize + + SUBROUTINE obs_deg2dist( ki, kj, pglam, pgphi, plamscl_deg, pphiscl_deg, & + & plamscl_max, pphiscl_max ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_deg2dist *** + !! + !! ** Purpose : Calculate the maximum distance in m of the length scale + !! in degrees. + !! + !! ** Method : At each lon/lat point, work out the distances in the + !! zonal and meridional directions. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 14/01. M. Martin. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER , INTENT(IN) :: & + & ki, kj !x/y dimensions of input lat/lon variables + REAL(KIND=wp), INTENT(IN), DIMENSION(ki,kj) :: & + & pglam, pgphi !Longitude and latitudes of grid points + REAL(KIND=wp), INTENT(IN) :: & + & plamscl_deg, & !Size in degrees of the observation footprint + & pphiscl_deg ! + REAL(KIND=wp), INTENT(OUT) :: & + & plamscl_max, & !Maximum size of obs footprint in metres + & pphiscl_max + + !! * Local declarations + INTEGER :: & + & ji, jj !Counters + REAL(KIND=wp) :: & + & zlon1, zlon2, & !Lon values surrounding centre of grid point + & zlat1, zlat2, & !Lat values surrounding centre of grid point + & zdlat, zdlon !Distance in radians in lat/lon directions + REAL(KIND=wp) :: & + & za1, za2, za, zc, zd + + plamscl_max = -1.0_wp + pphiscl_max = -1.0_wp + + DO ji = 1, ki + DO jj = 1, kj + + !Calculate distance in metres in zonal(x) direction + + zlon1 = rad * ( pglam(ji,jj) + ( 0.5_wp * plamscl_deg ) ) + zlon2 = rad * ( pglam(ji,jj) - ( 0.5_wp * plamscl_deg ) ) + zlat1 = rad * pgphi(ji,jj) + zlat2 = rad * pgphi(ji,jj) + zdlon = zlon2 - zlon1 + zdlat = zlat2 - zlat1 + + za1 = sin( zdlat/2.0_wp ) + za2 = sin( zdlon/2.0_wp ) + za = ( za1 * za1 ) + ( COS( zlat1 ) * COS( zlat2 ) * ( za2 * za2 ) ) + zc = 2.0_wp * atan2( SQRT( za ), SQRT( 1.0_wp-za ) ) + zd = ra * zc + + IF ( zd > plamscl_max ) plamscl_max = zd + + !Calculate distance in metres in meridional(y) direction + + zlon1 = rad * pglam(ji,jj) + zlon2 = rad * pglam(ji,jj) + zlat1 = rad * ( pgphi(ji,jj) + ( 0.5_wp * pphiscl_deg ) ) + zlat2 = rad * ( pgphi(ji,jj) - ( 0.5_wp * pphiscl_deg ) ) + zdlon = zlon2 - zlon1 + zdlat = zlat2 - zlat1 + + za1 = sin( zdlat/2.0_wp ) + za2 = sin( zdlon/2.0_wp ) + za = ( za1 * za1 ) + ( COS( zlat1 ) * COS( zlat2 ) * ( za2 * za2 ) ) + zc = 2.0_wp * atan2( SQRT( za ), SQRT( 1.0_wp-za ) ) + zd = ra * zc + + IF ( zd > pphiscl_max ) pphiscl_max = zd + + END DO + END DO + + END SUBROUTINE obs_deg2dist + + SUBROUTINE obs_dist2corners(pglam_bl, pglam_br, pglam_tl, pglam_tr, & + & pgphi_bl, pgphi_br, pgphi_tl, pgphi_tr, & + & plam, pphi, pxvert, pyvert, pdist) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_dist2corners *** + !! + !! ** Purpose : Calculate distance from centre of obs footprint to the corners of a grid box + !! + !! ** Method : Use great circle distance formulae. + !! Order of corners is 1=topleft, 2=topright, 3=bottomright, 4=bottomleft + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 14/01. M. Martin. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: & + & pglam_bl, pglam_br, & !lon at corners of grid box + & pglam_tl, pglam_tr + REAL(KIND=wp), INTENT(IN) :: & + & pgphi_bl, pgphi_br, & !lat at corners of grid box + & pgphi_tl, pgphi_tr + REAL(KIND=wp), INTENT(IN) :: & + & pphi, plam !lat/lon of centre of obs footprint + REAL(KIND=wp), DIMENSION(4), INTENT(OUT) :: & + & pxvert, pyvert !x/y location (in metres relative to centre of obs footprint) of corners + REAL(KIND=wp), DIMENSION(4), INTENT(OUT) :: & + & pdist !distance (in metres) of each corner relative to centre of obs footprint + + !! * Local variables + INTEGER :: & + & jvert !Counter for corners + REAL(KIND=wp) :: & + & zphi, zlam !Local values for lon/lat of corners + REAL(KIND=wp) :: & + & za1, za2, & !For great circle distance calculations + & zb1, zb2, & + & zc1, zc2 + REAL(KIND=wp) :: & + & zdist_centre_lat, & !Distances in lat/lon directions (in metres) + & zdist_centre_lon + + !!----------------------------------------------------------------------- + + ! Work out latitudinal and longitudinal distance from centre of + ! obs fp to corners of grid box + DO jvert = 1, 4 + SELECT CASE(jvert) + CASE(1) + zphi = pgphi_tl + zlam = pglam_tl + CASE(2) + zphi = pgphi_tr + zlam = pglam_tr + CASE(3) + zphi = pgphi_br + zlam = pglam_br + CASE(4) + zphi = pgphi_bl + zlam = pglam_bl + END SELECT + + IF (zlam == plam ) THEN + pxvert(jvert) = 0.0_wp + ELSE + za1 = SIN( zphi * rad ) + za2 = SIN( zphi * rad ) + zb1 = COS( zphi * rad ) * COS( zlam * rad ) + zb2 = COS( zphi * rad ) * COS( plam * rad ) + zc1 = COS( zphi * rad ) * SIN( zlam * rad ) + zc2 = COS( zphi * rad ) * SIN( plam * rad ) + pxvert(jvert) = grt_cir_dis( za1, za2, zb1, zb2, zc1, zc2 ) + pxvert(jvert) = ra * pxvert(jvert) + IF ( zlam < plam ) pxvert(jvert) = - pxvert(jvert) + ENDIF + + IF ( zphi == pphi ) THEN + pyvert(jvert) = 0.0_wp + ELSE + za1 = SIN( zphi * rad ) + za2 = SIN( pphi * rad ) + zb1 = COS( zphi * rad ) * COS( zlam * rad ) + zb2 = COS( pphi * rad ) * COS( zlam * rad ) + zc1 = COS( zphi * rad ) * SIN( zlam * rad ) + zc2 = COS( pphi * rad ) * SIN( zlam * rad ) + pyvert(jvert) = grt_cir_dis( za1, za2, zb1, zb2, zc1, zc2 ) + pyvert(jvert) = ra * pyvert(jvert) + IF ( zphi < pphi ) pyvert(jvert) = - pyvert(jvert) + ENDIF + + !Calculate the distance of each vertex relative to centre of obs footprint + pdist(jvert) = SQRT( ( pxvert(jvert) * pxvert(jvert) ) + & + & ( pyvert(jvert) * pyvert(jvert) ) ) + + END DO + + END SUBROUTINE obs_dist2corners + +END MODULE obs_averg_h2d \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_const.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_const.F90 new file mode 100644 index 0000000..2058726 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_const.F90 @@ -0,0 +1,22 @@ +MODULE obs_const + !!===================================================================== + !! *** MODULE obs_const *** + !! Observation diagnostics: Constants used by many modules + !!===================================================================== + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_const.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & sp + IMPLICIT NONE + + !! * Routine/type accessibility + PUBLIC + + REAL(kind=sp), PARAMETER :: obfillflt=99999. + +END MODULE obs_const \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_conv.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_conv.F90 new file mode 100644 index 0000000..e3bdbad --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_conv.F90 @@ -0,0 +1,45 @@ +MODULE obs_conv + !!===================================================================== + !! *** MODULE obs_conv *** + !! Observation diagnostics: Various conversion functions + !!===================================================================== + !! + !! potemp : Compute potential temperature from insitu temperature, + !! salinity and pressure + !! fspott : Compute potential temperature from insitu temperature, + !! salinity and pressure + !! atg : Compute adiabatic temperature gradient deg c per decibar + !! theta : Compute potential temperature from insitu temperature, + !! salinity and pressure + !! depth : Compute depth from pressure and latitude. + !! p_to_dep : Compute depth from pressure and latitude + !! (approximate version) + !! dep_to_p : Compute pressure from depth and latitude + !! (approximate version) + !!--------------------------------------------------------------------- + !! * Modules used + USE par_kind + IMPLICIT NONE + + !! * Function accessibility + PRIVATE + PUBLIC & + & potemp, & + & fspott, & + & atg, & + & theta, & + & depth, & + & p_to_dep, & + & dep_to_p + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_conv.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "obs_conv_functions.h90" + +END MODULE obs_conv \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_conv_functions.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_conv_functions.h90 new file mode 100644 index 0000000..8fc5ee9 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_conv_functions.h90 @@ -0,0 +1,294 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_conv_functions.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL(KIND=wp) FUNCTION potemp( ps, pt, pp, ppr ) + !!---------------------------------------------------------------------- + !! *** FUNCTION potemp *** + !! + !! ** Purpose : Compute potential temperature + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: potemp(35,20,2000,0) = 19.621967 + !! + !! References : T. J. Mcdougall, D. R. Jackett, D. G. Wright + !! and R. Feistel + !! Accurate and computationally efficient algoritms for + !! potential temperatures and density of seawater + !! Journal of atmospheric and oceanic technology + !! Vol 20, 2003, pp 730-741 + !! + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + + REAL(KIND=wp), INTENT(IN) :: ps + REAL(KIND=wp), INTENT(IN) :: pt + REAL(KIND=wp), INTENT(IN) :: pp + REAL(KIND=wp), INTENT(IN) :: ppr + + !! * Local declarations + REAL(KIND=wp) :: zpol + REAL(KIND=wp), PARAMETER :: a1 = 1.067610e-05 + REAL(KIND=wp), PARAMETER :: a2 = -1.434297e-06 + REAL(KIND=wp), PARAMETER :: a3 = -7.566349e-09 + REAL(KIND=wp), PARAMETER :: a4 = -8.535585e-06 + REAL(KIND=wp), PARAMETER :: a5 = 3.074672e-08 + REAL(KIND=wp), PARAMETER :: a6 = 1.918639e-08 + REAL(KIND=wp), PARAMETER :: a7 = 1.788718e-10 + + zpol = a1 + a2 * ps + a3 * ( pp + ppr ) + a4 * pt & + & + a5 * ps * pt + a6 * pt * pt + a7 * pt * ( pp + ppr ) + + potemp = pt + ( pp - ppr ) * zpol + + END FUNCTION potemp + + REAL(KIND=wp) FUNCTION fspott( pft, pfs, pfp ) + !!---------------------------------------------------------------------- + !! *** FUNCTION fspott *** + !! + !! ** Purpose : Compute potential temperature + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : Check value: fspott(10,25,1000) = 8.4678516 + !! + !! References : A. E. Gill + !! Atmosphere-Ocean Dynamics + !! Volume 30 (International Geophysics) + !! + !! History : + !! ! 07-05 (K. Mogensen) NEMO adopting of OPAVAR code. + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp) :: pft ! in situ temperature in degrees Celsius + REAL(KIND=wp) :: pfs ! salinity in psu + REAL(KIND=wp) :: pfp ! pressure in bars + + fspott = & + & pft - pfp * ( ( 3.6504e-4 & + & + pft * ( 8.3198e-5 & + & + pft * ( -5.4065e-7 & + & + pft * 4.0274e-9 ) ) ) & + & + ( pfs - 35.0 ) * ( 1.7439e-5 & + & - pft * 2.9778e-7 ) & + & + pfp * ( 8.9309e-7 & + & + pft * ( -3.1628e-8 & + & + pft * 2.1987e-10 ) & + & - ( pfs - 35.0 ) * 4.1057e-9 & + & + pfp * ( -1.6056e-10 & + & + pft * 5.0484e-12 ) ) ) + + END FUNCTION fspott + + REAL(KIND=wp) FUNCTION atg( p_s, p_t, p_p ) + !!---------------------------------------------------------------------- + !! *** FUNCTION atg *** + !! + !! ** Purpose : Compute adiabatic temperature gradient deg c per decibar + !! + !! ** Method : A regression formula is used + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: atg(40,40,10000) = 3.255974e-4 + !! + !! References : N. P. Fotonoff and R.C. Millard jr., + !! Algoritms for computation of fundamental + !! properties of seawater + !! Unesco technical papers in marine science 44 + !! Unesco 1983 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code based on the F77 code. + !!---------------------------------------------------------------------- + + !! * Arguments + + REAL(KIND=wp), INTENT(IN) :: p_s ! Salinity in PSU + REAL(KIND=wp), INTENT(IN) :: p_t ! Temperature in centigrades + REAL(KIND=wp), INTENT(IN) :: p_p ! Pressure in decibars. + + !! * Local declarations + + REAL(KIND=wp) :: z_ds + + z_ds = p_s - 35.0 + atg = ((( -2.1687e-16 * p_t + 1.8676e-14 ) * p_t - 4.6206e-13 ) * p_p & + & + (( 2.7759e-12 * p_t - 1.1351e-10 ) * z_ds + (( - 5.4481e-14 * p_t & + & + 8.733e-12 ) * p_t - 6.7795e-10 ) * p_t + 1.8741e-8)) * p_p & + & + ( -4.2393e-8 * p_t + 1.8932e-6 ) * z_ds & + & + (( 6.6228e-10 * p_t - 6.836e-8 ) * p_t + 8.5258e-6 ) * p_t + 3.5803e-5 + + END FUNCTION atg + + REAL(KIND=wp) FUNCTION theta( p_s, p_t0, p_p0, p_pr ) + !!---------------------------------------------------------------------- + !! *** FUNCTION theta *** + !! + !! ** Purpose : Compute potential temperature + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: theta(40,40,10000,0) = 36.89073 + !! + !! References : N. P. Fotonoff and R.C. Millard jr., + !! Algoritms for computation of fundamental + !! properties of seawater + !! Unesco technical papers in marine science 44 + !! Unesco 1983 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code based on the F77 code. + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_s + REAL(KIND=wp), INTENT(IN) :: p_t0 + REAL(KIND=wp), INTENT(IN) :: p_p0 + REAL(KIND=wp), INTENT(IN) :: p_pr + + !! * Local declarations + REAL(KIND=wp) :: z_p + REAL(KIND=wp) :: z_t + REAL(KIND=wp) :: z_h + REAL(KIND=wp) :: z_xk + REAL(KIND=wp) :: z_q + + z_p = p_p0 + z_t = p_t0 + z_h = p_pr - z_p + z_xk = z_h * atg( p_s, z_t, z_p ) + Z_t = z_t + 0.5 * z_xk + z_q = z_xk + z_p = z_p + 0.5 * z_h + z_xk = z_h * atg( p_s, z_t, z_p ) + z_t = z_t + 0.29289322 * ( z_xk - z_q ) + z_q = 0.58578644 * z_xk + 0.121320344 * z_q + z_xk = z_h * atg( p_s, z_t, z_p ) + z_t = z_t + 1.707106781 * ( z_xk - z_q ) + z_q = 3.414213562 * z_xk - 4.121320244 * z_q + z_p = z_p + 0.5 * z_h + z_xk = z_h * atg( p_s, z_t, z_p ) + theta = z_t + ( z_xk - 2.0 * z_q ) / 6.0 + + END FUNCTION theta + + REAL(KIND=wp) FUNCTION depth( p_p, p_lat ) + !!---------------------------------------------------------------------- + !! *** FUNCTION depth *** + !! + !! ** Purpose : Compute depth from pressure and latitudes + !! + !! ** Method : A regression formula is used. + !! + !! ** Action : The code is kept as close to the F77 code as possible + !! Check value: depth(10000,30) = 9712.653 + !! + !! References : N. P. Fotonoff and R.C. Millard jr., + !! Algoritms for computation of fundamental + !! properties of seawater + !! Unesco technical papers in marine science 44 + !! Unesco 1983 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code based on the F77 code. + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_p ! Pressure in decibars + REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees + + !! * Local declarations + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_gr + + z_x = SIN( p_lat / 57.29578 ) + z_x = z_x * z_x + z_gr = 9.780318 * ( 1.0 + ( 5.2788e-3 + 2.36e-5 * z_x ) * z_x ) + 1.092e-6 * p_p + depth = ((( -1.82e-15 * p_p + 2.279e-10 ) * p_p - 2.2512e-5 ) * p_p + 9.72659 ) * p_p + depth = depth / z_gr + + END FUNCTION depth + + REAL(KIND=wp) FUNCTION p_to_dep( p_p, p_lat ) + !!---------------------------------------------------------------------- + !! *** FUNCTION p_to_dep *** + !! + !! ** Purpose : Compute depth from pressure and latitudes + !! + !! ** Method : A regression formula is used. This version is less + !! accurate the "depth" but invertible. + !! + !! ** Action : + !! + !! References : P.M Saunders + !! Pratical conversion of pressure to depth + !! Journal of physical oceanography Vol 11, 1981, pp 573-574 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_p ! Pressure in decibars + REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees + + !! * Local declarations + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_c1 + REAL(KIND=wp) :: z_c2 + + z_x = SIN( p_lat / 57.29578 ) + z_x = z_x * z_x + z_c1 = ( 5.92 + 5.25 * z_x ) * 1e-3 + z_c2 = 2.21e-6 + p_to_dep = (1 - z_c1) * p_p - z_c2 * p_p * p_p + + END FUNCTION p_to_dep + + REAL(KIND=wp) FUNCTION dep_to_p( p_dep, p_lat ) + !!---------------------------------------------------------------------- + !! *** FUNCTION dep_to_p *** + !! + !! ** Purpose : Compute depth from pressure and latitudes + !! + !! ** Method : The expression used in p_to_dep is inverted. + !! + !! ** Action : + !! + !! References : P.M Saunders + !! Pratical conversion of pressure to depth + !! Journal of physical oceanography Vol 11, 1981, pp 573-574 + !! + !! History : + !! ! 07-05 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: p_dep ! Depth in meters + REAL(KIND=wp), INTENT(IN) :: p_lat ! Latitude in degrees + + !! * Local declarations + REAL(KIND=wp) :: z_x + REAL(KIND=wp) :: z_c1 + REAL(KIND=wp) :: z_c2 + REAL(KIND=wp) :: z_d + + z_x = SIN( p_lat / 57.29578 ) + z_x = z_x * z_x + z_c1 = ( 5.92 + 5.25 * z_x ) * 1e-3 + z_c2 = 2.21e-6 + z_d = ( z_c1 - 1 ) * ( z_c1 - 1 ) - 4 * z_c2 * p_dep + dep_to_p = (( 1 - z_c1 ) - SQRT( z_d )) / ( 2 * z_c2 ) + + END FUNCTION dep_to_p \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_fbm.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_fbm.F90 new file mode 100644 index 0000000..e758b34 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_fbm.F90 @@ -0,0 +1,1998 @@ +MODULE obs_fbm + !!====================================================================== + !! *** MODULE obs_fbm *** + !! Observation operators : I/O + tools for feedback files + !!====================================================================== + !! History : + !! ! 08-11 (K. Mogensen) Initial version + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! init_obfbdata : Initialize sizes in obfbdata structure + !! alloc_obfbdata : Allocate data in an obfbdata structure + !! dealloc_obfbdata : Dellocate data in an obfbdata structure + !! copy_obfbdata : Copy an obfbdata structure + !! subsamp_obfbdata : Sumsample an obfbdata structure + !! merge_obfbdata : Merge multiple obfbdata structures into an one. + !! write_obfbdata : Write an obfbdata structure into a netCDF file. + !! read_obfbdata : Read an obfbdata structure from a netCDF file. + !!---------------------------------------------------------------------- + USE netcdf + USE obs_utils ! Various utilities for observation operators + + IMPLICIT NONE + PUBLIC + + ! Type kinds for feedback data. + + INTEGER, PARAMETER :: fbsp = SELECTED_REAL_KIND( 6, 37) !: single precision + INTEGER, PARAMETER :: fbdp = SELECTED_REAL_KIND(12,307) !: double precision + + ! Parameters for string lengths. + + INTEGER, PARAMETER :: ilenwmo = 8 !: Length of station identifier + INTEGER, PARAMETER :: ilentyp = 4 !: Length of type + INTEGER, PARAMETER :: ilenname = 8 !: Length of variable names + INTEGER, PARAMETER :: ilengrid = 1 !: Grid (e.g. 'T') length + INTEGER, PARAMETER :: ilenjuld = 14 !: Lenght of reference julian date + INTEGER, PARAMETER :: idefnqcf = 2 !: Default number of words in QC + ! flags + INTEGER, PARAMETER :: ilenlong = 128 !: Length of long name + INTEGER, PARAMETER :: ilenunit = 32 !: Length of units + + ! Missinge data indicators + + INTEGER, PARAMETER :: fbimdi = -99999 !: Integers + REAL(fbsp), PARAMETER :: fbrmdi = 99999 !: Reals + + ! Main data structure for observation feedback data. + + TYPE obfbdata + LOGICAL :: lalloc !: Allocation status for data + LOGICAL :: lgrid !: Include grid search info + INTEGER :: nvar !: Number of variables + INTEGER :: nobs !: Number of observations + INTEGER :: nlev !: Number of levels + INTEGER :: nadd !: Number of additional entries + INTEGER :: next !: Number of extra variables + INTEGER :: nqcf !: Number of words per qc flag + CHARACTER(LEN=ilenwmo), DIMENSION(:), POINTER :: & + & cdwmo !: Identifier + CHARACTER(LEN=ilentyp), DIMENSION(:), POINTER :: & + & cdtyp !: Instrument type + CHARACTER(LEN=ilenjuld) :: & + & cdjuldref !: Julian date reference + INTEGER, DIMENSION(:), POINTER :: & + & kindex !: Index of observations in the original file + INTEGER, DIMENSION(:), POINTER :: & + & ioqc, & !: Observation QC + & ipqc, & !: Position QC + & itqc !: Time QC + INTEGER, DIMENSION(:,:), POINTER :: & + & ioqcf, & !: Observation QC flags + & ipqcf, & !: Position QC flags + & itqcf !: Time QC flags + INTEGER, DIMENSION(:,:), POINTER :: & + & idqc !: Depth QC + INTEGER, DIMENSION(:,:,:), POINTER :: & + & idqcf !: Depth QC flags + REAL(KIND=fbdp), DIMENSION(:), POINTER :: & + & plam, & !: Longitude + & pphi, & !: Latitude + & ptim !: Time + REAL(KIND=fbsp), DIMENSION(:,:), POINTER :: & + & pdep !: Depth + CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: & + & cname !: Name of variable + REAL(fbsp), DIMENSION(:,:,:), POINTER :: & + & pob !: Observation + CHARACTER(LEN=ilenlong), DIMENSION(:), POINTER :: & + & coblong !: Observation long name (for output) + CHARACTER(LEN=ilenunit), DIMENSION(:), POINTER :: & + & cobunit !: Observation units (for output) + INTEGER, DIMENSION(:,:), POINTER :: & + & ivqc !: Variable QC + INTEGER, DIMENSION(:,:,:), POINTER :: & + & ivqcf !: Variable QC flags + INTEGER, DIMENSION(:,:,:), POINTER :: & + & ivlqc !: Variable level QC + INTEGER, DIMENSION(:,:,:,:), POINTER :: & + & ivlqcf !: Variable level QC flags + INTEGER, DIMENSION(:,:), POINTER :: & + & iproc, & !: Processor of obs (no I/O for this variable). + & iobsi, & !: Global i index + & iobsj !: Global j index + INTEGER, DIMENSION(:,:,:), POINTER :: & + & iobsk !: k index + CHARACTER(LEN=ilengrid), DIMENSION(:), POINTER :: & + & cgrid !: Grid for this variable + CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: & + & caddname !: Additional entries names + CHARACTER(LEN=ilenlong), DIMENSION(:,:), POINTER :: & + & caddlong !: Additional entries long name (for output) + CHARACTER(LEN=ilenunit), DIMENSION(:,:), POINTER :: & + & caddunit !: Additional entries units (for output) + REAL(fbsp), DIMENSION(:,:,:,:) , POINTER :: & + & padd !: Additional entries + CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: & + & cextname !: Extra variables names + CHARACTER(LEN=ilenlong), DIMENSION(:), POINTER :: & + & cextlong !: Extra variables long name (for output) + CHARACTER(LEN=ilenunit), DIMENSION(:), POINTER :: & + & cextunit !: Extra variables units (for output) + REAL(fbsp), DIMENSION(:,:,:) , POINTER :: & + & pext !: Extra variables + END TYPE obfbdata + + PRIVATE putvaratt_obfbdata + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_fbm.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE init_obfbdata( fbdata ) + !!---------------------------------------------------------------------- + !! *** ROUTINE init_obfbdata *** + !! + !! ** Purpose : Initialize sizes in obfbdata structure + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata ! obsfbdata structure + + fbdata%nvar = 0 + fbdata%nobs = 0 + fbdata%nlev = 0 + fbdata%nadd = 0 + fbdata%next = 0 + fbdata%nqcf = idefnqcf + fbdata%lalloc = .FALSE. + fbdata%lgrid = .FALSE. + + END SUBROUTINE init_obfbdata + + SUBROUTINE alloc_obfbdata( fbdata, kvar, kobs, klev, kadd, kext, lgrid, & + & kqcf) + !!---------------------------------------------------------------------- + !! *** ROUTINE alloc_obfbdata *** + !! + !! ** Purpose : Allocate data in an obfbdata structure + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata ! obsfbdata structure to be allocated + INTEGER, INTENT(IN) :: kvar ! Number of variables + INTEGER, INTENT(IN) :: kobs ! Number of observations + INTEGER, INTENT(IN) :: klev ! Number of levels + INTEGER, INTENT(IN) :: kadd ! Number of additional entries + INTEGER, INTENT(IN) :: kext ! Number of extra variables + LOGICAL, INTENT(IN) :: lgrid ! Include grid search information + INTEGER, OPTIONAL :: kqcf ! Number of words for QC flags + !! * Local variables + INTEGER :: ji + INTEGER :: jv + + ! Check allocation status and deallocate previous allocated structures + + IF ( fbdata%lalloc ) THEN + CALL dealloc_obfbdata( fbdata ) + ENDIF + + ! Set dimensions + + fbdata%lalloc = .TRUE. + fbdata%nvar = kvar + fbdata%nobs = kobs + fbdata%nlev = MAX( klev, 1 ) + fbdata%nadd = kadd + fbdata%next = kext + IF ( PRESENT(kqcf) ) THEN + fbdata%nqcf = kqcf + ELSE + fbdata%nqcf = idefnqcf + ENDIF + + ! Set data not depending on number of observations + + fbdata%cdjuldref = REPEAT( 'X', ilenjuld ) + + ! Allocate and initialize standard data + + ALLOCATE( & + & fbdata%cname(fbdata%nvar), & + & fbdata%coblong(fbdata%nvar), & + & fbdata%cobunit(fbdata%nvar) & + & ) + DO ji = 1, fbdata%nvar + WRITE(fbdata%cname(ji),'(A,I2.2)')'V_',ji + fbdata%coblong(ji) = REPEAT( ' ', ilenlong ) + fbdata%cobunit(ji) = REPEAT( ' ', ilenunit ) + END DO + + ! Optionally also store grid search information + + IF ( lgrid ) THEN + ALLOCATE ( & + & fbdata%cgrid(fbdata%nvar) & + & ) + fbdata%cgrid(:) = REPEAT( 'X', ilengrid ) + fbdata%lgrid = .TRUE. + ENDIF + + ! Allocate and initialize additional entries if present + + IF ( fbdata%nadd > 0 ) THEN + ALLOCATE( & + & fbdata%caddname(fbdata%nadd), & + & fbdata%caddlong(fbdata%nadd, fbdata%nvar), & + & fbdata%caddunit(fbdata%nadd, fbdata%nvar) & + & ) + DO ji = 1, fbdata%nadd + WRITE(fbdata%caddname(ji),'(A,I2.2)')'A',ji + END DO + DO jv = 1, fbdata%nvar + DO ji = 1, fbdata%nadd + fbdata%caddlong(ji,jv) = REPEAT( ' ', ilenlong ) + fbdata%caddunit(ji,jv) = REPEAT( ' ', ilenunit ) + END DO + END DO + ENDIF + + ! Allocate and initialize additional variables if present + + IF ( fbdata%next > 0 ) THEN + ALLOCATE( & + & fbdata%cextname(fbdata%next), & + & fbdata%cextlong(fbdata%next), & + & fbdata%cextunit(fbdata%next) & + & ) + DO ji = 1, fbdata%next + WRITE(fbdata%cextname(ji),'(A,I2.2)')'E_',ji + fbdata%cextlong(ji) = REPEAT( ' ', ilenlong ) + fbdata%cextunit(ji) = REPEAT( ' ', ilenunit ) + END DO + ENDIF + + ! Data depending on number of observations is only allocated if nobs>0 + + IF ( fbdata%nobs > 0 ) THEN + + ALLOCATE( & + & fbdata%cdwmo(fbdata%nobs), & + & fbdata%cdtyp(fbdata%nobs), & + & fbdata%ioqc(fbdata%nobs), & + & fbdata%ioqcf(fbdata%nqcf,fbdata%nobs), & + & fbdata%ipqc(fbdata%nobs), & + & fbdata%ipqcf(fbdata%nqcf,fbdata%nobs), & + & fbdata%itqc(fbdata%nobs), & + & fbdata%itqcf(fbdata%nqcf,fbdata%nobs), & + & fbdata%idqc(fbdata%nlev,fbdata%nobs), & + & fbdata%idqcf(fbdata%nqcf,fbdata%nlev,fbdata%nobs), & + & fbdata%plam(fbdata%nobs), & + & fbdata%pphi(fbdata%nobs), & + & fbdata%pdep(fbdata%nlev,fbdata%nobs), & + & fbdata%ptim(fbdata%nobs), & + & fbdata%kindex(fbdata%nobs), & + & fbdata%ivqc(fbdata%nobs,fbdata%nvar), & + & fbdata%ivqcf(fbdata%nqcf,fbdata%nobs,fbdata%nvar), & + & fbdata%ivlqc(fbdata%nlev,fbdata%nobs,fbdata%nvar), & + & fbdata%ivlqcf(fbdata%nqcf,fbdata%nlev,fbdata%nobs,fbdata%nvar), & + & fbdata%pob(fbdata%nlev,fbdata%nobs,fbdata%nvar) & + & ) + fbdata%kindex(:) = fbimdi + fbdata%cdwmo(:) = REPEAT( 'X', ilenwmo ) + fbdata%cdtyp(:) = REPEAT( 'X', ilentyp ) + fbdata%ioqc(:) = fbimdi + fbdata%ioqcf(:,:) = fbimdi + fbdata%ipqc(:) = fbimdi + fbdata%ipqcf(:,:) = fbimdi + fbdata%itqc(:) = fbimdi + fbdata%itqcf(:,:) = fbimdi + fbdata%idqc(:,:) = fbimdi + fbdata%idqcf(:,:,:) = fbimdi + fbdata%plam(:) = fbrmdi + fbdata%pphi(:) = fbrmdi + fbdata%pdep(:,:) = fbrmdi + fbdata%ptim(:) = fbrmdi + fbdata%ivqc(:,:) = fbimdi + fbdata%ivqcf(:,:,:) = fbimdi + fbdata%ivlqc(:,:,:) = fbimdi + fbdata%ivlqcf(:,:,:,:) = fbimdi + fbdata%pob(:,:,:) = fbrmdi + + ! Optionally also store grid search information + + IF ( lgrid ) THEN + ALLOCATE ( & + & fbdata%iproc(fbdata%nobs,fbdata%nvar), & + & fbdata%iobsi(fbdata%nobs,fbdata%nvar), & + & fbdata%iobsj(fbdata%nobs,fbdata%nvar), & + & fbdata%iobsk(fbdata%nlev,fbdata%nobs,fbdata%nvar) & + & ) + fbdata%iproc(:,:) = fbimdi + fbdata%iobsi(:,:) = fbimdi + fbdata%iobsj(:,:) = fbimdi + fbdata%iobsk(:,:,:) = fbimdi + fbdata%lgrid = .TRUE. + ENDIF + + ! Allocate and initialize additional entries if present + + IF ( fbdata%nadd > 0 ) THEN + ALLOCATE( & + & fbdata%padd(fbdata%nlev,fbdata%nobs,fbdata%nadd,fbdata%nvar) & + & ) + fbdata%padd(:,:,:,:) = fbrmdi + ENDIF + + ! Allocate and initialize additional variables if present + + IF ( fbdata%next > 0 ) THEN + ALLOCATE( & + & fbdata%pext(fbdata%nlev,fbdata%nobs,fbdata%next) & + & ) + fbdata%pext(:,:,:) = fbrmdi + ENDIF + + ENDIF + + END SUBROUTINE alloc_obfbdata + + SUBROUTINE dealloc_obfbdata( fbdata ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dealloc_obfbdata *** + !! + !! ** Purpose : Deallocate data in an obfbdata strucure + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata ! obsfbdata structure + + ! Deallocate data + + DEALLOCATE( & + & fbdata%cname, & + & fbdata%coblong,& + & fbdata%cobunit & + & ) + + ! Deallocate optional grid search information + + IF ( fbdata%lgrid ) THEN + DEALLOCATE ( & + & fbdata%cgrid & + & ) + ENDIF + + ! Deallocate additional entries + + IF ( fbdata%nadd > 0 ) THEN + DEALLOCATE( & + & fbdata%caddname, & + & fbdata%caddlong, & + & fbdata%caddunit & + & ) + ENDIF + + ! Deallocate extra variables + + IF ( fbdata%next > 0 ) THEN + DEALLOCATE( & + & fbdata%cextname, & + & fbdata%cextlong, & + & fbdata%cextunit & + & ) + ENDIF + + ! Deallocate arrays depending on number of obs (if nobs>0 only). + + IF ( fbdata%nobs > 0 ) THEN + + DEALLOCATE( & + & fbdata%cdwmo, & + & fbdata%cdtyp, & + & fbdata%ioqc, & + & fbdata%ioqcf, & + & fbdata%ipqc, & + & fbdata%ipqcf, & + & fbdata%itqc, & + & fbdata%itqcf, & + & fbdata%idqc, & + & fbdata%idqcf, & + & fbdata%plam, & + & fbdata%pphi, & + & fbdata%pdep, & + & fbdata%ptim, & + & fbdata%kindex, & + & fbdata%ivqc, & + & fbdata%ivqcf, & + & fbdata%ivlqc, & + & fbdata%ivlqcf, & + & fbdata%pob & + & ) + + + ! Deallocate optional grid search information + + IF ( fbdata%lgrid ) THEN + DEALLOCATE ( & + & fbdata%iproc, & + & fbdata%iobsi, & + & fbdata%iobsj, & + & fbdata%iobsk & + & ) + ENDIF + + ! Deallocate additional entries + + IF ( fbdata%nadd > 0 ) THEN + DEALLOCATE( & + & fbdata%padd & + & ) + ENDIF + + ! Deallocate extra variables + + IF ( fbdata%next > 0 ) THEN + DEALLOCATE( & + & fbdata%pext & + & ) + ENDIF + + ENDIF + + ! Reset arrays sizes + + fbdata%lalloc = .FALSE. + fbdata%lgrid = .FALSE. + fbdata%nvar = 0 + fbdata%nobs = 0 + fbdata%nlev = 0 + fbdata%nadd = 0 + fbdata%next = 0 + + END SUBROUTINE dealloc_obfbdata + + SUBROUTINE copy_obfbdata( fbdata1, fbdata2, kadd, kext, lgrid, kqcf ) + !!---------------------------------------------------------------------- + !! *** ROUTINE copy_obfbdata *** + !! + !! ** Purpose : Copy an obfbdata structure + !! + !! ** Method : Copy all data from fbdata1 to fbdata2 + !! If fbdata2 is allocated it needs to be compliant + !! with fbdata1. + !! Additional entries can be added by setting nadd + !! Additional extra fields can be added by setting next + !! Grid information can be included with lgrid=.true. + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata1 ! Input obsfbdata structure + TYPE(obfbdata) :: fbdata2 ! Output obsfbdata structure + INTEGER, INTENT(IN), OPTIONAL :: kadd ! Number of additional entries + INTEGER, INTENT(IN), OPTIONAL :: kext ! Number of extra variables + INTEGER, INTENT(IN), OPTIONAL :: kqcf ! Number of words per qc flags + LOGICAL, OPTIONAL :: lgrid ! Grid info on output file + + !! * Local variables + INTEGER :: nadd + INTEGER :: next + INTEGER :: nqcf + LOGICAL :: llgrid + INTEGER :: jv + INTEGER :: je + INTEGER :: ji + INTEGER :: jk + INTEGER :: jq + + ! Check allocation status of fbdata1 + + IF ( .NOT. fbdata1%lalloc ) THEN + CALL fatal_error( 'copy_obfbdata: input data not allocated', & + & __LINE__ ) + ENDIF + + ! If nadd,next not specified use the ones from fbdata1 + ! Otherwise check that they have large than the original ones + + IF ( PRESENT(kadd) ) THEN + nadd = kadd + IF ( nadd < fbdata1%nadd ) THEN + CALL warning ( 'copy_obfbdata: ' // & + & 'nadd smaller than input nadd', __LINE__ ) + ENDIF + ELSE + nadd = fbdata1%nadd + ENDIF + IF ( PRESENT(kext) ) THEN + next = kext + IF ( next < fbdata1%next ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'next smaller than input next', __LINE__ ) + ENDIF + ELSE + next = fbdata1%next + ENDIF + IF ( PRESENT(lgrid) ) THEN + llgrid = lgrid + IF ( fbdata1%lgrid .AND. (.NOT. llgrid) ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'switching off grid info not possible', & + & __LINE__ ) + ENDIF + ELSE + llgrid = fbdata1%lgrid + ENDIF + IF ( PRESENT(kqcf) ) THEN + nqcf = kqcf + IF ( nqcf < fbdata1%nqcf ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'nqcf smaller than input nqcf', __LINE__ ) + ENDIF + ELSE + nqcf = fbdata1%nqcf + ENDIF + + ! Check allocation status of fbdata2 and + ! a) check that it conforms in size if already allocated + ! b) allocate it if not already allocated + + IF ( fbdata2%lalloc ) THEN + IF ( fbdata1%nvar > fbdata2%nvar ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output kvar smaller than input kvar', __LINE__ ) + ENDIF + IF ( fbdata1%nobs > fbdata2%nobs ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output kobs smaller than input kobs', __LINE__ ) + ENDIF + IF ( fbdata1%nlev > fbdata2%nlev ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output klev smaller than input klev', __LINE__ ) + ENDIF + IF ( fbdata1%nadd > fbdata2%nadd ) THEN + CALL warning ( 'copy_obfbdata: ' // & + & 'output nadd smaller than input nadd', __LINE__ ) + ENDIF + IF ( fbdata1%next > fbdata2%next ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output next smaller than input next', __LINE__ ) + ENDIF + IF ( fbdata1%lgrid .NEQV. fbdata2%lgrid ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'lgrid inconsistent', __LINE__ ) + ENDIF + IF ( fbdata1%next > fbdata2%next ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output next smaller than input next', __LINE__ ) + ENDIF + IF ( fbdata1%nqcf > fbdata2%nqcf ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output smaller than input kext', __LINE__ ) + ENDIF + ELSE + CALL alloc_obfbdata( fbdata2, fbdata1%nvar, fbdata1%nobs, & + & fbdata1%nlev, nadd, next, llgrid, kqcf = nqcf ) + ENDIF + + ! Copy the header data + + fbdata2%cdjuldref = fbdata1%cdjuldref + + DO ji = 1, fbdata1%nobs + fbdata2%cdwmo(ji) = fbdata1%cdwmo(ji) + fbdata2%cdtyp(ji) = fbdata1%cdtyp(ji) + fbdata2%ioqc(ji) = fbdata1%ioqc(ji) + fbdata2%ipqc(ji) = fbdata1%ipqc(ji) + fbdata2%itqc(ji) = fbdata1%itqc(ji) + fbdata2%plam(ji) = fbdata1%plam(ji) + fbdata2%pphi(ji) = fbdata1%pphi(ji) + fbdata2%ptim(ji) = fbdata1%ptim(ji) + fbdata2%kindex(ji) = fbdata1%kindex(ji) + DO jq = 1, fbdata1%nqcf + fbdata2%ioqcf(jq,ji) = fbdata1%ioqcf(jq,ji) + fbdata2%ipqcf(jq,ji) = fbdata1%ipqcf(jq,ji) + fbdata2%itqcf(jq,ji) = fbdata1%itqcf(jq,ji) + END DO + DO jk = 1, fbdata1%nlev + fbdata2%idqc(jk,ji) = fbdata1%idqc(jk,ji) + fbdata2%pdep(jk,ji) = fbdata1%pdep(jk,ji) + DO jq = 1, fbdata1%nqcf + fbdata2%idqcf(jq,jk,ji) = fbdata1%idqcf(jq,jk,ji) + END DO + END DO + END DO + + ! Copy the variable data + + DO jv = 1, fbdata1%nvar + fbdata2%cname(jv) = fbdata1%cname(jv) + fbdata2%coblong(jv) = fbdata1%coblong(jv) + fbdata2%cobunit(jv) = fbdata1%cobunit(jv) + DO ji = 1, fbdata1%nobs + fbdata2%ivqc(ji,jv) = fbdata1%ivqc(ji,jv) + DO jq = 1, fbdata1%nqcf + fbdata2%ivqcf(jq,ji,jv) = fbdata1%ivqcf(jq,ji,jv) + END DO + DO jk = 1, fbdata1%nlev + fbdata2%ivlqc(jk,ji,jv) = fbdata1%ivlqc(jk,ji,jv) + fbdata2%pob(jk,ji,jv) = fbdata1%pob(jk,ji,jv) + DO jq = 1, fbdata1%nqcf + fbdata2%ivlqcf(jq,jk,ji,jv) = fbdata1%ivlqcf(jq,jk,ji,jv) + END DO + END DO + END DO + END DO + + ! Copy grid information + + IF ( fbdata1%lgrid ) THEN + DO jv = 1, fbdata1%nvar + fbdata2%cgrid(jv) = fbdata1%cgrid(jv) + DO ji = 1, fbdata1%nobs + fbdata2%iproc(ji,jv) = fbdata1%iproc(ji,jv) + fbdata2%iobsi(ji,jv) = fbdata1%iobsi(ji,jv) + fbdata2%iobsj(ji,jv) = fbdata1%iobsj(ji,jv) + DO jk = 1, fbdata1%nlev + fbdata2%iobsk(jk,ji,jv) = fbdata1%iobsk(jk,ji,jv) + END DO + END DO + END DO + ENDIF + + ! Copy additional information + + DO je = 1, MIN( fbdata1%nadd, fbdata2%nadd ) + fbdata2%caddname(je) = fbdata1%caddname(je) + END DO + DO jv = 1, fbdata1%nvar + DO je = 1, MIN( fbdata1%nadd, fbdata2%nadd ) + fbdata2%caddlong(je,jv) = fbdata1%caddlong(je,jv) + fbdata2%caddunit(je,jv) = fbdata1%caddunit(je,jv) + DO ji = 1, fbdata1%nobs + DO jk = 1, fbdata1%nlev + fbdata2%padd(jk,ji,je,jv) = fbdata1%padd(jk,ji,je,jv) + END DO + END DO + END DO + END DO + + ! Copy extra information + + DO je = 1, fbdata1%next + fbdata2%cextname(je) = fbdata1%cextname(je) + fbdata2%cextlong(je) = fbdata1%cextlong(je) + fbdata2%cextunit(je) = fbdata1%cextunit(je) + END DO + DO je = 1, fbdata1%next + DO ji = 1, fbdata1%nobs + DO jk = 1, fbdata1%nlev + fbdata2%pext(jk,ji,je) = fbdata1%pext(jk,ji,je) + END DO + END DO + END DO + + END SUBROUTINE copy_obfbdata + + SUBROUTINE subsamp_obfbdata( fbdata1, fbdata2, llvalid ) + !!---------------------------------------------------------------------- + !! *** ROUTINE susbamp_obfbdata *** + !! + !! ** Purpose : Subsample an obfbdata structure based on the + !! logical mask. + !! + !! ** Method : Copy all data from fbdata1 to fbdata2 if + !! llvalid(obs)==true + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obfbdata) :: fbdata1 ! Input obsfbdata structure + TYPE(obfbdata) :: fbdata2 ! Output obsfbdata structure + LOGICAL, DIMENSION(fbdata1%nobs) :: llvalid ! Grid info on output file + !! * Local variables + INTEGER :: nobs + INTEGER :: jv + INTEGER :: je + INTEGER :: ji + INTEGER :: jk + INTEGER :: jq + INTEGER :: ij + + ! Check allocation status of fbdata1 + + IF ( .NOT. fbdata1%lalloc ) THEN + CALL fatal_error( 'copy_obfbdata: input data not allocated', & + & __LINE__ ) + ENDIF + + ! Check allocation status of fbdata2 and abort if already allocated + + IF ( fbdata2%lalloc ) THEN + CALL fatal_error( 'subsample_obfbdata: ' // & + & 'fbdata2 already allocated', __LINE__ ) + ENDIF + + ! Count number of subsampled observations + + nobs = COUNT(llvalid) + + ! Allocate new data structure + + CALL alloc_obfbdata( fbdata2, fbdata1%nvar, nobs, & + & fbdata1%nlev, fbdata1%nadd, fbdata1%next, & + & fbdata1%lgrid, kqcf = fbdata1%nqcf ) + + ! Copy the header data + + fbdata2%cdjuldref = fbdata1%cdjuldref + + ij = 0 + DO ji = 1, fbdata1%nobs + IF ( llvalid(ji) ) THEN + ij = ij +1 + fbdata2%cdwmo(ij) = fbdata1%cdwmo(ji) + fbdata2%cdtyp(ij) = fbdata1%cdtyp(ji) + fbdata2%ioqc(ij) = fbdata1%ioqc(ji) + fbdata2%ipqc(ij) = fbdata1%ipqc(ji) + fbdata2%itqc(ij) = fbdata1%itqc(ji) + fbdata2%plam(ij) = fbdata1%plam(ji) + fbdata2%pphi(ij) = fbdata1%pphi(ji) + fbdata2%ptim(ij) = fbdata1%ptim(ji) + fbdata2%kindex(ij) = fbdata1%kindex(ji) + DO jq = 1, fbdata1%nqcf + fbdata2%ioqcf(jq,ij) = fbdata1%ioqcf(jq,ji) + fbdata2%ipqcf(jq,ij) = fbdata1%ipqcf(jq,ji) + fbdata2%itqcf(jq,ij) = fbdata1%itqcf(jq,ji) + END DO + DO jk = 1, fbdata1%nlev + fbdata2%idqc(jk,ij) = fbdata1%idqc(jk,ji) + fbdata2%pdep(jk,ij) = fbdata1%pdep(jk,ji) + DO jq = 1, fbdata1%nqcf + fbdata2%idqcf(jq,jk,ij) = fbdata1%idqcf(jq,jk,ji) + END DO + END DO + ENDIF + END DO + + ! Copy the variable data + + DO jv = 1, fbdata1%nvar + fbdata2%cname(jv) = fbdata1%cname(jv) + fbdata2%coblong(jv) = fbdata1%coblong(jv) + fbdata2%cobunit(jv) = fbdata1%cobunit(jv) + ij = 0 + DO ji = 1, fbdata1%nobs + IF ( llvalid(ji) ) THEN + ij = ij + 1 + fbdata2%ivqc(ij,jv) = fbdata1%ivqc(ji,jv) + DO jq = 1, fbdata1%nqcf + fbdata2%ivqcf(jq,ij,jv) = fbdata1%ivqcf(jq,ji,jv) + END DO + DO jk = 1, fbdata1%nlev + fbdata2%ivlqc(jk,ij,jv) = fbdata1%ivlqc(jk,ji,jv) + fbdata2%pob(jk,ij,jv) = fbdata1%pob(jk,ji,jv) + DO jq = 1, fbdata1%nqcf + fbdata2%ivlqcf(jq,jk,ij,jv) = fbdata1%ivlqcf(jq,jk,ji,jv) + END DO + END DO + ENDIF + END DO + END DO + + ! Copy grid information + + IF ( fbdata1%lgrid ) THEN + DO jv = 1, fbdata1%nvar + fbdata2%cgrid(jv) = fbdata1%cgrid(jv) + ij = 0 + DO ji = 1, fbdata1%nobs + IF ( llvalid(ji) ) THEN + ij = ij + 1 + fbdata2%iproc(ij,jv) = fbdata1%iproc(ji,jv) + fbdata2%iobsi(ij,jv) = fbdata1%iobsi(ji,jv) + fbdata2%iobsj(ij,jv) = fbdata1%iobsj(ji,jv) + DO jk = 1, fbdata1%nlev + fbdata2%iobsk(jk,ij,jv) = fbdata1%iobsk(jk,ji,jv) + END DO + ENDIF + END DO + END DO + ENDIF + + ! Copy additional information + + DO je = 1, fbdata1%nadd + fbdata2%caddname(je) = fbdata1%caddname(je) + END DO + DO jv = 1, fbdata1%nvar + DO je = 1, fbdata1%nadd + fbdata2%caddlong(je,jv) = fbdata1%caddlong(je,jv) + fbdata2%caddunit(je,jv) = fbdata1%caddunit(je,jv) + ij = 0 + DO ji = 1, fbdata1%nobs + IF ( llvalid(ji) ) THEN + ij = ij + 1 + DO jk = 1, fbdata1%nlev + fbdata2%padd(jk,ij,je,jv) = fbdata1%padd(jk,ji,je,jv) + END DO + ENDIF + END DO + END DO + END DO + + ! Copy extra information + + DO je = 1, fbdata1%next + fbdata2%cextname(je) = fbdata1%cextname(je) + fbdata2%cextlong(je) = fbdata1%cextlong(je) + fbdata2%cextunit(je) = fbdata1%cextunit(je) + END DO + DO je = 1, fbdata1%next + ij = 0 + DO ji = 1, fbdata1%nobs + IF ( llvalid(ji) ) THEN + ij = ij + 1 + DO jk = 1, fbdata1%nlev + fbdata2%pext(jk,ij,je) = fbdata1%pext(jk,ji,je) + END DO + ENDIF + END DO + END DO + + END SUBROUTINE subsamp_obfbdata + + SUBROUTINE merge_obfbdata( nsets, fbdatain, fbdataout, iset, inum, iind ) + !!---------------------------------------------------------------------- + !! *** ROUTINE merge_obfbdata *** + !! + !! ** Purpose : Merge multiple obfbdata structures into an one. + !! + !! ** Method : The order of elements is based on the indices in + !! iind. + !! All input data are assumed to be consistent. This + !! is assumed to be checked before calling this routine. + !! Likewise output data is assume to be consistent as + !! well without error checking. + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN):: nsets ! Number of input data sets + TYPE(obfbdata), DIMENSION(nsets) :: fbdatain ! Input obsfbdata structure + TYPE(obfbdata) :: fbdataout ! Output obsfbdata structure + INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: & + & iset ! Set number for a given obs. + INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: & + & inum ! Number within set for an obs + INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: & + & iind ! Indices for copying. + !! * Local variables + + INTEGER :: js + INTEGER :: jo + INTEGER :: jv + INTEGER :: je + INTEGER :: ji + INTEGER :: jk + INTEGER :: jq + + ! Check allocation status of fbdatain + + DO js = 1, nsets + IF ( .NOT. fbdatain(js)%lalloc ) THEN + CALL fatal_error( 'merge_obfbdata: input data not allocated', & + & __LINE__ ) + ENDIF + END DO + + ! Check allocation status of fbdataout + + IF ( .NOT.fbdataout%lalloc ) THEN + CALL fatal_error( 'merge_obfbdata: output data not allocated', & + & __LINE__ ) + ENDIF + + ! Merge various names + + DO jv = 1, fbdatain(1)%nvar + fbdataout%cname(jv) = fbdatain(1)%cname(jv) + fbdataout%coblong(jv) = fbdatain(1)%coblong(jv) + fbdataout%cobunit(jv) = fbdatain(1)%cobunit(jv) + IF ( fbdatain(1)%lgrid ) THEN + fbdataout%cgrid(jv) = fbdatain(1)%cgrid(jv) + ENDIF + END DO + DO jv = 1, fbdatain(1)%nadd + fbdataout%caddname(jv) = fbdatain(1)%caddname(jv) + END DO + DO jv = 1, fbdatain(1)%nvar + DO je = 1, fbdatain(1)%nadd + fbdataout%caddlong(je,jv) = fbdatain(1)%caddlong(je,jv) + fbdataout%caddunit(je,jv) = fbdatain(1)%caddunit(je,jv) + END DO + END DO + DO jv = 1, fbdatain(1)%next + fbdataout%cextname(jv) = fbdatain(1)%cextname(jv) + fbdataout%cextlong(jv) = fbdatain(1)%cextlong(jv) + fbdataout%cextunit(jv) = fbdatain(1)%cextunit(jv) + END DO + fbdataout%cdjuldref = fbdatain(1)%cdjuldref + + ! Loop over total views + + DO jo = 1, fbdataout%nobs + + js = iset(iind(jo)) + ji = inum(iind(jo)) + + ! Merge the header data + + fbdataout%cdwmo(jo) = fbdatain(js)%cdwmo(ji) + fbdataout%cdtyp(jo) = fbdatain(js)%cdtyp(ji) + fbdataout%ioqc(jo) = fbdatain(js)%ioqc(ji) + fbdataout%ipqc(jo) = fbdatain(js)%ipqc(ji) + fbdataout%itqc(jo) = fbdatain(js)%itqc(ji) + fbdataout%plam(jo) = fbdatain(js)%plam(ji) + fbdataout%pphi(jo) = fbdatain(js)%pphi(ji) + fbdataout%ptim(jo) = fbdatain(js)%ptim(ji) + fbdataout%kindex(jo) = fbdatain(js)%kindex(ji) + DO jq = 1, fbdatain(js)%nqcf + fbdataout%ioqcf(jq,jo) = fbdatain(js)%ioqcf(jq,ji) + fbdataout%ipqcf(jq,jo) = fbdatain(js)%ipqcf(jq,ji) + fbdataout%itqcf(jq,jo) = fbdatain(js)%itqcf(jq,ji) + END DO + DO jk = 1, fbdatain(js)%nlev + fbdataout%pdep(jk,jo) = fbdatain(js)%pdep(jk,ji) + fbdataout%idqc(jk,jo) = fbdatain(js)%idqc(jk,ji) + DO jq = 1, fbdatain(js)%nqcf + fbdataout%idqcf(jq,jk,jo) = fbdatain(js)%idqcf(jq,jk,ji) + END DO + END DO + + ! Merge the variable data + + DO jv = 1, fbdatain(js)%nvar + fbdataout%ivqc(jo,jv) = fbdatain(js)%ivqc(ji,jv) + DO jq = 1, fbdatain(js)%nqcf + fbdataout%ivqcf(jq,jo,jv) = fbdatain(js)%ivqcf(jq,ji,jv) + END DO + DO jk = 1, fbdatain(js)%nlev + fbdataout%ivlqc(jk,jo,jv) = fbdatain(js)%ivlqc(jk,ji,jv) + fbdataout%pob(jk,jo,jv) = fbdatain(js)%pob(jk,ji,jv) + DO jq = 1, fbdatain(js)%nqcf + fbdataout%ivlqcf(jq,jk,jo,jv) = & + & fbdatain(js)%ivlqcf(jq,jk,ji,jv) + END DO + END DO + END DO + + ! Merge grid information + + IF ( fbdatain(js)%lgrid ) THEN + DO jv = 1, fbdatain(js)%nvar + fbdataout%cgrid(jv) = fbdatain(js)%cgrid(jv) + fbdataout%iproc(jo,jv) = fbdatain(js)%iproc(ji,jv) + fbdataout%iobsi(jo,jv) = fbdatain(js)%iobsi(ji,jv) + fbdataout%iobsj(jo,jv) = fbdatain(js)%iobsj(ji,jv) + DO jk = 1, fbdatain(js)%nlev + fbdataout%iobsk(jk,jo,jv) = fbdatain(js)%iobsk(jk,ji,jv) + END DO + END DO + ENDIF + + ! Merge additional information + + DO jv = 1, fbdatain(js)%nvar + DO je = 1, fbdatain(js)%nadd + DO jk = 1, fbdatain(js)%nlev + fbdataout%padd(jk,jo,je,jv) = fbdatain(js)%padd(jk,ji,je,jv) + END DO + END DO + END DO + + ! Merge extra information + + DO je = 1, fbdatain(js)%next + DO jk = 1, fbdatain(js)%nlev + fbdataout%pext(jk,jo,je) = fbdatain(js)%pext(jk,ji,je) + END DO + END DO + + END DO + + END SUBROUTINE merge_obfbdata + + SUBROUTINE write_obfbdata( cdfilename, fbdata ) + !!---------------------------------------------------------------------- + !! *** ROUTINE write_obfbdata *** + !! + !! ** Purpose : Write an obfbdata structure into a netCDF file. + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + CHARACTER(len=*) :: cdfilename ! Output filename + TYPE(obfbdata) :: fbdata ! obsfbdata structure + !! * Local variables + CHARACTER(LEN=14), PARAMETER :: cpname = 'write_obfbdata' + ! Dimension ids + INTEGER :: idfile + INTEGER :: idodim + INTEGER :: idldim + INTEGER :: idvdim + INTEGER :: idadim + INTEGER :: idedim + INTEGER :: idsndim + INTEGER :: idsgdim + INTEGER :: idswdim + INTEGER :: idstdim + INTEGER :: idjddim + INTEGER :: idqcdim + INTEGER :: idvard + INTEGER :: idaddd + INTEGER :: idextd + INTEGER :: idcdwmo + INTEGER :: idcdtyp + INTEGER :: idplam + INTEGER :: idpphi + INTEGER :: idpdep + INTEGER :: idptim + INTEGER :: idptimr + INTEGER :: idioqc + INTEGER :: idioqcf + INTEGER :: idipqc + INTEGER :: idipqcf + INTEGER :: iditqc + INTEGER :: iditqcf + INTEGER :: ididqc + INTEGER :: ididqcf + INTEGER :: idkindex + INTEGER, DIMENSION(fbdata%nvar) :: & + & idpob, & + & idivqc, & + & idivqcf, & + & idivlqc, & + & idivlqcf, & + & idiobsi, & + & idiobsj, & + & idiobsk, & + & idcgrid + INTEGER, DIMENSION(fbdata%nadd,fbdata%nvar) :: idpadd + INTEGER, DIMENSION(fbdata%next) :: idpext + INTEGER, DIMENSION(1) :: incdim1 + INTEGER, DIMENSION(2) :: incdim2 + INTEGER, DIMENSION(3) :: incdim3 + INTEGER, DIMENSION(4) :: incdim4 + + INTEGER :: jv + INTEGER :: je + INTEGER :: ioldfill + CHARACTER(len=nf90_max_name) :: & + & cdtmp + CHARACTER(len=16), PARAMETER :: & + & cdqcconv = 'q where q =[0,9]' + CHARACTER(len=24), PARAMETER :: & + & cdqcfconv = 'NEMOVAR flag conventions' + CHARACTER(len=ilenlong) :: & + & cdltmp + + ! Open output filename + + CALL chkerr( nf90_create( TRIM( cdfilename ), nf90_clobber, idfile ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_set_fill( idfile, nf90_nofill, ioldfill ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'title', & + & 'NEMO observation operator output' ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'Convention', & + & 'NEMO unified observation operator output' ),& + & cpname,__LINE__ ) + + ! Create the dimensions + + CALL chkerr( nf90_def_dim( idfile, 'N_OBS' , fbdata%nobs, idodim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_def_dim( idfile, 'N_LEVELS', fbdata%nlev, idldim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_def_dim( idfile, 'N_VARS', fbdata%nvar, idvdim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_def_dim( idfile, 'N_QCF', fbdata%nqcf, idqcdim ),& + & cpname,__LINE__ ) + IF ( fbdata%nadd > 0 ) THEN + CALL chkerr( nf90_def_dim( idfile, 'N_ENTRIES', fbdata%nadd, idadim ), & + & cpname,__LINE__ ) + ENDIF + IF ( fbdata%next > 0 ) THEN + CALL chkerr( nf90_def_dim( idfile, 'N_EXTRA', fbdata%next, idedim ), & + & cpname,__LINE__ ) + ENDIF + CALL chkerr( nf90_def_dim( idfile, 'STRINGNAM', ilenname, idsndim ), & + & cpname,__LINE__ ) + IF (fbdata%lgrid) THEN + CALL chkerr( nf90_def_dim( idfile, 'STRINGGRID', ilengrid, idsgdim ),& + & cpname,__LINE__ ) + ENDIF + CALL chkerr( nf90_def_dim( idfile, 'STRINGWMO', ilenwmo, idswdim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_def_dim( idfile, 'STRINGTYP', ilentyp, idstdim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_def_dim( idfile, 'STRINGJULD', ilenjuld, idjddim ), & + & cpname,__LINE__ ) + + ! Define netCDF variables for header information + + incdim2(1) = idsndim + incdim2(2) = idvdim + + CALL chkerr( nf90_def_var( idfile, 'VARIABLES', nf90_char, incdim2, & + & idvard ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idvard, & + & 'List of variables in feedback files' ) + + IF ( fbdata%nadd > 0 ) THEN + incdim2(1) = idsndim + incdim2(2) = idadim + CALL chkerr( nf90_def_var( idfile, 'ENTRIES', nf90_char, incdim2, & + & idaddd ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idaddd, & + & 'List of additional entries for each '// & + & 'variable in feedback files' ) + ENDIF + + IF ( fbdata%next > 0 ) THEN + incdim2(1) = idsndim + incdim2(2) = idedim + CALL chkerr( nf90_def_var( idfile, 'EXTRA', nf90_char, incdim2, & + & idextd ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idextd, & + & 'List of extra variables' ) + ENDIF + + incdim2(1) = idswdim + incdim2(2) = idodim + CALL chkerr( nf90_def_var( idfile, 'STATION_IDENTIFIER', & + & nf90_char, incdim2, & + & idcdwmo ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idcdwmo, & + & 'Station identifier' ) + incdim2(1) = idstdim + incdim2(2) = idodim + CALL chkerr( nf90_def_var( idfile, 'STATION_TYPE', & + & nf90_char, incdim2, & + & idcdtyp ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idcdtyp, & + & 'Code instrument type' ) + incdim1(1) = idodim + CALL chkerr( nf90_def_var( idfile, 'LONGITUDE', & + & nf90_double, incdim1, & + & idplam ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idplam, & + & 'Longitude', cdunits = 'degrees_east', & + & rfillvalue = fbrmdi ) + CALL chkerr( nf90_def_var( idfile, 'LATITUDE', & + & nf90_double, incdim1, & + & idpphi ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idpphi, & + & 'Latitude', cdunits = 'degrees_north', & + & rfillvalue = fbrmdi ) + incdim2(1) = idldim + incdim2(2) = idodim + CALL chkerr( nf90_def_var( idfile, 'DEPTH', & + & nf90_double, incdim2, & + & idpdep ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idpdep, & + & 'Depth', cdunits = 'metre', & + & rfillvalue = fbrmdi ) + incdim3(1) = idqcdim + incdim3(2) = idldim + incdim3(3) = idodim + CALL chkerr( nf90_def_var( idfile, 'DEPTH_QC', & + & nf90_int, incdim2, & + & ididqc ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, ididqc, & + & 'Quality on depth', & + & conventions = cdqcconv, & + & ifillvalue = 0 ) + CALL chkerr( nf90_def_var( idfile, 'DEPTH_QC_FLAGS', & + & nf90_int, incdim3, & + & ididqcf ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, ididqcf, & + & 'Quality flags on depth', & + & conventions = cdqcfconv ) + CALL chkerr( nf90_def_var( idfile, 'JULD', & + & nf90_double, incdim1, & + & idptim ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idptim, & + & 'Julian day', & + & cdunits = 'days since JULD_REFERENCE', & + & conventions = 'relative julian days with '// & + & 'decimal part (as parts of day)', & + & rfillvalue = fbrmdi ) + incdim1(1) = idjddim + CALL chkerr( nf90_def_var( idfile, 'JULD_REFERENCE', & + & nf90_char, incdim1, & + & idptimr ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idptimr, & + & 'Date of reference for julian days ', & + & conventions = 'YYYYMMDDHHMMSS' ) + incdim1(1) = idodim + CALL chkerr( nf90_def_var( idfile, 'OBSERVATION_QC', & + & nf90_int, incdim1, & + & idioqc ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idioqc, & + & 'Quality on observation', & + & conventions = cdqcconv, & + & ifillvalue = 0 ) + incdim2(1) = idqcdim + incdim2(2) = idodim + CALL chkerr( nf90_def_var( idfile, 'OBSERVATION_QC_FLAGS', & + & nf90_int, incdim2, & + & idioqcf ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idioqcf, & + & 'Quality flags on observation', & + & conventions = cdqcfconv, & + & ifillvalue = 0 ) + CALL chkerr( nf90_def_var( idfile, 'POSITION_QC', & + & nf90_int, incdim1, & + & idipqc ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idipqc, & + & 'Quality on position (latitude and longitude)', & + & conventions = cdqcconv, & + & ifillvalue = 0 ) + CALL chkerr( nf90_def_var( idfile, 'POSITION_QC_FLAGS', & + & nf90_int, incdim2, & + & idipqcf ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idipqcf, & + & 'Quality flags on position', & + & conventions = cdqcfconv, & + & ifillvalue = 0 ) + CALL chkerr( nf90_def_var( idfile, 'JULD_QC', & + & nf90_int, incdim1, & + & iditqc ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, iditqc, & + & 'Quality on date and time', & + & conventions = cdqcconv, & + & ifillvalue = 0 ) + CALL chkerr( nf90_def_var( idfile, 'JULD_QC_FLAGS', & + & nf90_int, incdim2, & + & iditqcf ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, iditqcf, & + & 'Quality flags on date and time', & + & conventions = cdqcfconv, & + & ifillvalue = 0 ) + CALL chkerr( nf90_def_var( idfile, 'ORIGINAL_FILE_INDEX', & + & nf90_int, incdim1, & + & idkindex ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idkindex, & + & 'Index in original data file', & + & ifillvalue = fbimdi ) + + ! Define netCDF variables for individual variables + + DO jv = 1, fbdata%nvar + + incdim1(1) = idodim + incdim2(1) = idldim + incdim2(2) = idodim + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, & + & incdim2, idpob(jv) ), & + & cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idpob(jv), & + & fbdata%coblong(jv), & + & cdunits = fbdata%cobunit(jv), & + & rfillvalue = fbrmdi ) + + IF ( fbdata%nadd > 0 ) THEN + DO je = 1, fbdata%nadd + WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',& + & TRIM(fbdata%caddname(je)) + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, & + & incdim2, idpadd(je,jv) ), & + & cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idpadd(je,jv), & + & fbdata%caddlong(je,jv), & + & cdunits = fbdata%caddunit(je,jv), & + & rfillvalue = fbrmdi ) + END DO + ENDIF + + cdltmp = fbdata%coblong(jv) + IF (( cdltmp(1:1) >= 'A' ).AND.( cdltmp(1:1) <= 'Z' )) & + & cdltmp(1:1) = ACHAR(IACHAR(cdltmp(1:1)) + 32) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & + & incdim1, idivqc(jv) ), & + & cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idivqc(jv), & + & 'Quality on '//cdltmp, & + & conventions = cdqcconv, & + & ifillvalue = 0 ) + incdim2(1) = idqcdim + incdim2(2) = idodim + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC_FLAGS' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & + & incdim2, idivqcf(jv) ), & + & cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idivqcf(jv), & + & 'Quality flags on '//cdltmp, & + & conventions = cdqcfconv, & + & ifillvalue = 0 ) + incdim2(1) = idldim + incdim2(2) = idodim + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & + & incdim2, idivlqc(jv) ), & + & cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idivlqc(jv), & + & 'Quality for each level on '//cdltmp, & + & conventions = cdqcconv, & + & ifillvalue = 0 ) + incdim3(1) = idqcdim + incdim3(2) = idldim + incdim3(3) = idodim + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC_FLAGS' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & + & incdim3, idivlqcf(jv) ), & + & cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idivlqcf(jv), & + & 'Quality flags for each level on '//& + & cdltmp, & + & conventions = cdqcfconv, & + & ifillvalue = 0 ) + + IF (fbdata%lgrid) THEN + incdim2(1) = idldim + incdim2(2) = idodim + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSI' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & + & incdim1, idiobsi(jv) ), & + & cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idiobsi(jv), & + & 'ORCA grid search I coordinate') + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSJ' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & + & incdim1, idiobsj(jv) ), & + & cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idiobsj(jv), & + & 'ORCA grid search J coordinate') + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSK' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & + & incdim2, idiobsk(jv) ), & + & cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idiobsk(jv), & + & 'ORCA grid search K coordinate') + incdim1(1) = idsgdim + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_GRID' + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_char, incdim1, & + & idcgrid(jv) ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idcgrid(jv), & + & 'ORCA grid search grid (T,U,V)') + ENDIF + + END DO + + IF ( fbdata%next > 0 ) THEN + DO je = 1, fbdata%next + incdim2(1) = idldim + incdim2(2) = idodim + WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je)) + CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, & + & incdim2, idpext(je) ), & + & cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idpext(je), & + & fbdata%cextlong(je), & + & cdunits = fbdata%cextunit(je), & + & rfillvalue = fbrmdi ) + END DO + ENDIF + + ! Stop definitions + + CALL chkerr( nf90_enddef( idfile ), cpname, __LINE__ ) + + ! Write the variables + + CALL chkerr( nf90_put_var( idfile, idvard, fbdata%cname ), & + & cpname, __LINE__ ) + + IF ( fbdata%nadd > 0 ) THEN + CALL chkerr( nf90_put_var( idfile, idaddd, fbdata%caddname ), & + & cpname, __LINE__ ) + ENDIF + + IF ( fbdata%next > 0 ) THEN + CALL chkerr( nf90_put_var( idfile, idextd, fbdata%cextname ), & + & cpname, __LINE__ ) + ENDIF + + CALL chkerr( nf90_put_var( idfile, idptimr, fbdata%cdjuldref ), & + & cpname, __LINE__ ) + + ! Only write the data if observation is available + + IF ( fbdata%nobs > 0 ) THEN + + CALL chkerr( nf90_put_var( idfile, idcdwmo, fbdata%cdwmo ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idcdtyp, fbdata%cdtyp ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idplam, fbdata%plam ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idpphi, fbdata%pphi ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idpdep, fbdata%pdep ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idptim, fbdata%ptim ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idioqc, fbdata%ioqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idioqcf, fbdata%ioqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idipqc, fbdata%ipqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idipqcf, fbdata%ipqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, iditqc, fbdata%itqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, iditqcf, fbdata%itqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, ididqc, fbdata%idqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, ididqcf, fbdata%idqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idkindex, fbdata%kindex ), & + & cpname, __LINE__ ) + + DO jv = 1, fbdata%nvar + CALL chkerr( nf90_put_var( idfile, idpob(jv), fbdata%pob(:,:,jv) ), & + & cpname, __LINE__ ) + IF ( fbdata%nadd > 0 ) THEN + DO je = 1, fbdata%nadd + CALL chkerr( nf90_put_var( idfile, idpadd(je,jv), & + & fbdata%padd(:,:,je,jv) ), & + & cpname, __LINE__ ) + END DO + ENDIF + CALL chkerr( nf90_put_var( idfile, idivqc(jv), & + & fbdata%ivqc(:,jv) ),& + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idivqcf(jv), & + & fbdata%ivqcf(:,:,jv) ),& + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idivlqc(jv), & + & fbdata%ivlqc(:,:,jv) ),& + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idivlqcf(jv), & + & fbdata%ivlqcf(:,:,:,jv) ),& + & cpname, __LINE__ ) + IF (fbdata%lgrid) THEN + CALL chkerr( nf90_put_var( idfile, idiobsi(jv), & + & fbdata%iobsi(:,jv) ),& + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idiobsj(jv), & + & fbdata%iobsj(:,jv) ),& + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idiobsk(jv), & + & fbdata%iobsk(:,:,jv) ),& + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idcgrid(jv), & + & fbdata%cgrid(jv) ), & + & cpname, __LINE__ ) + ENDIF + END DO + + IF ( fbdata%next > 0 ) THEN + DO je = 1, fbdata%next + CALL chkerr( nf90_put_var( idfile, idpext(je), & + & fbdata%pext(:,:,je) ), & + & cpname, __LINE__ ) + END DO + ENDIF + + ENDIF + + ! Close the file + + CALL chkerr( nf90_close( idfile ), cpname, __LINE__ ) + + + END SUBROUTINE write_obfbdata + + SUBROUTINE putvaratt_obfbdata( idfile, idvar, cdlongname, cdunits, & + & conventions, cfillvalue, & + & ifillvalue, rfillvalue ) + !!---------------------------------------------------------------------- + !! *** ROUTINE putvaratt_obfbdata *** + !! + !! ** Purpose : Write netcdf attributes for variable + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER :: idfile ! File netcdf id. + INTEGER :: idvar ! Variable netcdf id. + CHARACTER(len=*) :: cdlongname ! Long name for variable + CHARACTER(len=*), OPTIONAL :: cdunits ! Units for variable + CHARACTER(len=*), OPTIONAL :: cfillvalue ! Fill value for character variables + INTEGER, OPTIONAL, INTENT(IN) :: ifillvalue ! Fill value for integer variables + REAL(kind=fbsp), OPTIONAL :: rfillvalue ! Fill value for real variables + CHARACTER(len=*), OPTIONAL :: conventions ! Conventions for variable + !! * Local variables + CHARACTER(LEN=18), PARAMETER :: & + & cpname = 'putvaratt_obfbdata' + + CALL chkerr( nf90_put_att( idfile, idvar, 'long_name', & + & TRIM(cdlongname) ), & + & cpname, __LINE__ ) + + IF ( PRESENT(cdunits) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, 'units', & + & TRIM(cdunits) ), & + & cpname, __LINE__ ) + + ENDIF + + IF ( PRESENT(conventions) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, 'Conventions', & + & TRIM(conventions) ), & + & cpname, __LINE__ ) + + ENDIF + + IF ( PRESENT(cfillvalue) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', & + & TRIM(cfillvalue) ), & + & cpname, __LINE__ ) + + ENDIF + + IF ( PRESENT(ifillvalue) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', & + & ifillvalue ), & + & cpname, __LINE__ ) + + ENDIF + + IF ( PRESENT(rfillvalue) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', & + & rfillvalue ), & + & cpname, __LINE__ ) + + ENDIF + + END SUBROUTINE putvaratt_obfbdata + + SUBROUTINE read_obfbdata( cdfilename, fbdata, ldgrid ) + !!---------------------------------------------------------------------- + !! *** ROUTINE read_obfbdata *** + !! + !! ** Purpose : Read an obfbdata structure from a netCDF file. + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + CHARACTER(len=*) :: cdfilename ! Input filename + TYPE(obfbdata) :: fbdata ! obsfbdata structure + LOGICAL, OPTIONAL, INTENT(IN) :: ldgrid ! Allow forcing of grid info + !! * Local variables + CHARACTER(LEN=14), PARAMETER :: cpname = 'read_obfbdata' + INTEGER :: idfile + INTEGER :: idodim + INTEGER :: idldim + INTEGER :: idvdim + INTEGER :: idadim + INTEGER :: idedim + INTEGER :: idgdim + INTEGER :: idvard + INTEGER :: idaddd + INTEGER :: idextd + INTEGER :: idcdwmo + INTEGER :: idcdtyp + INTEGER :: idplam + INTEGER :: idpphi + INTEGER :: idpdep + INTEGER :: idptim + INTEGER :: idptimr + INTEGER :: idioqc + INTEGER :: idioqcf + INTEGER :: idipqc + INTEGER :: idipqcf + INTEGER :: ididqc + INTEGER :: ididqcf + INTEGER :: iditqc + INTEGER :: iditqcf + INTEGER :: idkindex + INTEGER, DIMENSION(:), ALLOCATABLE :: & + & idpob, & + & idivqc, & + & idivqcf, & + & idivlqc, & + & idivlqcf, & + & idiobsi, & + & idiobsj, & + & idiobsk, & + & idcgrid, & + & idpext + INTEGER, DIMENSION(:,:), ALLOCATABLE :: & + & idpadd + INTEGER :: jv + INTEGER :: je + INTEGER :: nvar + INTEGER :: nobs + INTEGER :: nlev + INTEGER :: nadd + INTEGER :: next + LOGICAL :: lgrid + CHARACTER(len=NF90_MAX_NAME) :: cdtmp + + ! Check allocation status and deallocate previous allocated structures + + IF ( fbdata%lalloc ) THEN + CALL dealloc_obfbdata( fbdata ) + ENDIF + + ! Open input filename + + CALL chkerr( nf90_open( TRIM( cdfilename ), nf90_nowrite, idfile ), & + & cpname, __LINE__ ) + + ! Get input dimensions + + CALL chkerr( nf90_inq_dimid( idfile, 'N_OBS' , idodim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_inquire_dimension( idfile, idodim, len=nobs ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_inq_dimid( idfile, 'N_LEVELS', idldim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_inquire_dimension( idfile, idldim, len=nlev ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_inq_dimid( idfile, 'N_VARS', idvdim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_inquire_dimension( idfile, idvdim, len=nvar ), & + & cpname,__LINE__ ) + IF ( nf90_inq_dimid( idfile, 'N_ENTRIES', idadim ) == 0 ) THEN + CALL chkerr( nf90_inquire_dimension( idfile, idadim, len=nadd ), & + & cpname,__LINE__ ) + ELSE + nadd = 0 + ENDIF + IF ( nf90_inq_dimid( idfile, 'N_EXTRA', idedim ) == 0 ) THEN + CALL chkerr( nf90_inquire_dimension( idfile, idedim, len=next ), & + & cpname,__LINE__ ) + ELSE + next = 0 + ENDIF + ! + ! Check if this input file contains grid search informations + ! + lgrid = ( nf90_inq_dimid( idfile, 'STRINGGRID', idgdim ) == 0 ) + + ! Allocate data structure + + IF ( PRESENT(ldgrid) ) THEN + CALL alloc_obfbdata( fbdata, nvar, nobs, nlev, nadd, next, & + & lgrid.OR.ldgrid ) + ELSE + CALL alloc_obfbdata( fbdata, nvar, nobs, nlev, nadd, next, & + & lgrid ) + ENDIF + + ! Allocate netcdf identifiers + + ALLOCATE( & + & idpob(fbdata%nvar), & + & idivqc(fbdata%nvar), & + & idivqcf(fbdata%nvar), & + & idivlqc(fbdata%nvar), & + & idivlqcf(fbdata%nvar), & + & idiobsi(fbdata%nvar), & + & idiobsj(fbdata%nvar), & + & idiobsk(fbdata%nvar), & + & idcgrid(fbdata%nvar) & + & ) + IF ( fbdata%nadd > 0 ) THEN + ALLOCATE( & + & idpadd(fbdata%nadd,fbdata%nvar) & + & ) + ENDIF + IF ( fbdata%next > 0 ) THEN + ALLOCATE( & + & idpext(fbdata%next) & + & ) + ENDIF + + ! Read variables for header information + + CALL chkerr( nf90_inq_varid( idfile, 'VARIABLES',idvard ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idvard, fbdata%cname ), & + & cpname, __LINE__ ) + IF ( fbdata%nadd > 0 ) THEN + CALL chkerr( nf90_inq_varid( idfile, 'ENTRIES', idaddd ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idaddd, fbdata%caddname ), & + & cpname, __LINE__ ) + ENDIF + IF ( fbdata%next > 0 ) THEN + CALL chkerr( nf90_inq_varid( idfile, 'EXTRA', idextd ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idextd, fbdata%cextname ), & + & cpname, __LINE__ ) + ENDIF + + CALL chkerr( nf90_inq_varid( idfile, 'JULD_REFERENCE', idptimr ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idptimr, fbdata%cdjuldref ), & + & cpname, __LINE__ ) + + IF ( fbdata%nobs > 0 ) THEN + + CALL chkerr( nf90_inq_varid( idfile, 'STATION_IDENTIFIER', idcdwmo ),& + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idcdwmo, fbdata%cdwmo ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'STATION_TYPE', idcdtyp ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idcdtyp, fbdata%cdtyp), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'LONGITUDE', idplam ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idplam, fbdata%plam ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'LATITUDE', idpphi ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idpphi, fbdata%pphi ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'DEPTH', idpdep ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idpdep, fbdata%pdep ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'JULD', idptim ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idptim, fbdata%ptim ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'OBSERVATION_QC', idioqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idioqc, fbdata%ioqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'OBSERVATION_QC_FLAGS', idioqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idioqcf, fbdata%ioqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'POSITION_QC', idipqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idipqc, fbdata%ipqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'POSITION_QC_FLAGS', idipqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idipqcf, fbdata%ipqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'DEPTH_QC', ididqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, ididqc, fbdata%idqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'DEPTH_QC_FLAGS', ididqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, ididqcf, fbdata%idqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'JULD_QC', iditqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, iditqc, fbdata%itqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'JULD_QC_FLAGS', iditqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, iditqcf, fbdata%itqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'ORIGINAL_FILE_INDEX', idkindex ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idkindex, fbdata%kindex ), & + & cpname, __LINE__ ) + + ! Read netCDF variables for individual variables + + DO jv = 1, fbdata%nvar + + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpob(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idpob(jv), & + & fbdata%pob(:,:,jv) ), & + & cpname, __LINE__ ) + CALL getvaratt_obfbdata( idfile, idpob(jv), & + & fbdata%coblong(jv), & + & fbdata%cobunit(jv) ) + + IF ( fbdata%nadd > 0 ) THEN + DO je = 1, fbdata%nadd + WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',& + & TRIM(fbdata%caddname(je)) + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpadd(je,jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idpadd(je,jv), & + & fbdata%padd(:,:,je,jv) ), & + & cpname, __LINE__ ) + CALL getvaratt_obfbdata( idfile, idpadd(je,jv), & + & fbdata%caddlong(je,jv), & + & fbdata%caddunit(je,jv) ) + END DO + ENDIF + + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivqc(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idivqc(jv), & + & fbdata%ivqc(:,jv) ), & + & cpname, __LINE__ ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC_FLAGS' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivqcf(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idivqcf(jv), & + & fbdata%ivqcf(:,:,jv) ), & + & cpname, __LINE__ ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivlqc(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idivlqc(jv), & + & fbdata%ivlqc(:,:,jv) ), & + & cpname, __LINE__ ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC_FLAGS' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivlqcf(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idivlqcf(jv), & + & fbdata%ivlqcf(:,:,:,jv) ), & + & cpname, __LINE__ ) + IF ( lgrid ) THEN + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSI' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsi(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idiobsi(jv), & + & fbdata%iobsi(:,jv) ), & + & cpname, __LINE__ ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSJ' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsj(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idiobsj(jv), & + & fbdata%iobsj(:,jv) ), & + & cpname, __LINE__ ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSK' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsk(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idiobsk(jv), & + & fbdata%iobsk(:,:,jv) ), & + & cpname, __LINE__ ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_GRID' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idcgrid(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idcgrid(jv), & + & fbdata%cgrid(jv) ), & + & cpname, __LINE__ ) + ENDIF + + END DO + + IF ( fbdata%next > 0 ) THEN + DO je = 1, fbdata%next + WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je)) + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpext(je) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idpext(je), & + & fbdata%pext(:,:,je) ), & + & cpname, __LINE__ ) + CALL getvaratt_obfbdata( idfile, idpext(je), & + & fbdata%cextlong(je), & + & fbdata%cextunit(je) ) + END DO + ENDIF + + ELSE ! if no observations only get attributes + + DO jv = 1, fbdata%nvar + + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpob(jv) ), & + & cpname, __LINE__ ) + CALL getvaratt_obfbdata( idfile, idpob(jv), & + & fbdata%coblong(jv), & + & fbdata%cobunit(jv) ) + + IF ( fbdata%nadd > 0 ) THEN + DO je = 1, fbdata%nadd + WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',& + & TRIM(fbdata%caddname(je)) + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpadd(je,jv) ), & + & cpname, __LINE__ ) + CALL getvaratt_obfbdata( idfile, idpadd(je,jv), & + & fbdata%caddlong(je,jv), & + & fbdata%caddunit(je,jv) ) + END DO + ENDIF + + END DO + + IF ( fbdata%next > 0 ) THEN + DO je = 1, fbdata%next + WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je)) + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpext(je) ), & + & cpname, __LINE__ ) + CALL getvaratt_obfbdata( idfile, idpext(je), & + & fbdata%cextlong(je), & + & fbdata%cextunit(je) ) + END DO + ENDIF + + ENDIF + + ! Close the file + + CALL chkerr( nf90_close( idfile ), cpname, __LINE__ ) + + END SUBROUTINE read_obfbdata + + SUBROUTINE getvaratt_obfbdata( idfile, idvar, cdlongname, cdunits ) + !!---------------------------------------------------------------------- + !! *** ROUTINE putvaratt_obfbdata *** + !! + !! ** Purpose : Read netcdf attributes for variable + !! + !! ** Method : + !! + !! ** Action : + !! + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER :: idfile ! File netcdf id. + INTEGER :: idvar ! Variable netcdf id. + CHARACTER(len=*) :: cdlongname ! Long name for variable + CHARACTER(len=*) :: cdunits ! Units for variable + !! * Local variables + CHARACTER(LEN=18), PARAMETER :: cpname = 'getvaratt_obfbdata' + + CALL chkerr( nf90_get_att( idfile, idvar, 'long_name', & + & cdlongname ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_get_att( idfile, idvar, 'units', & + & cdunits ), & + & cpname, __LINE__ ) + + END SUBROUTINE getvaratt_obfbdata + +END MODULE obs_fbm \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_grd_bruteforce.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_grd_bruteforce.h90 new file mode 100644 index 0000000..e15bbbe --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_grd_bruteforce.h90 @@ -0,0 +1,349 @@ +SUBROUTINE obs_grd_bruteforce( kpi, kpj, kpiglo, kpjglo, & + & kldi, klei, kldj, klej, & + & kmyproc, ktotproc, & + & pglam, pgphi, pmask, & + & kobs, plam, pphi, kobsi, kobsj, & + & kproc) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_grd_bruteforce *** + !! + !! ** Purpose : Search gridpoints to find the grid box containing + !! the observations + !! + !! ** Method : Call to linquad + !! + !! ** Action : Return kproc holding the observation and kiobsi,kobsj + !! valid on kproc=kmyproc processor only. + !! + !! History : + !! ! 2001-11 (N. Daget, A. Weaver) + !! ! 2006-03 (A. Weaver) NEMOVAR migration. + !! ! 2006-05 (K. Mogensen) Moved to to separate routine. + !! ! 2007-10 (A. Vidard) Bug fix in wrap around checks; cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kpi ! Number of local longitudes + INTEGER, INTENT(IN) :: kpj ! Number of local latitudes + INTEGER, INTENT(IN) :: kpiglo ! Number of global longitudes + INTEGER, INTENT(IN) :: kpjglo ! Number of global latitudes + INTEGER, INTENT(IN) :: kldi ! Start of inner domain in i + INTEGER, INTENT(IN) :: klei ! End of inner domain in i + INTEGER, INTENT(IN) :: kldj ! Start of inner domain in j + INTEGER, INTENT(IN) :: klej ! End of inner domain in j + INTEGER, INTENT(IN) :: kmyproc ! Processor number for MPP + INTEGER, INTENT(IN) :: ktotproc ! Total number of processors + REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) :: & + & pglam, & ! Grid point longitude + & pgphi, & ! Grid point latitude + & pmask ! Grid point mask + INTEGER,INTENT(IN) :: kobs ! Size of the observation arrays + REAL(KIND=wp), DIMENSION(kobs), INTENT(IN) :: & + & plam, & ! Longitude of obsrvations + & pphi ! Latitude of observations + INTEGER, DIMENSION(kobs), INTENT(OUT) :: & + & kobsi, & ! I-index of observations + & kobsj, & ! J-index of observations + & kproc ! Processor number of observations + + !! * Local declarations + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zplam, zpphi + REAL(wp) :: zlammax + REAL(wp) :: zlam + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jo + INTEGER :: jlon + INTEGER :: jlat + INTEGER :: joffset + INTEGER :: jostride + REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: & + & zlamg, & + & zphig, & + & zmskg, & + & zphitmax,& + & zphitmin,& + & zlamtmax,& + & zlamtmin + LOGICAL, DIMENSION(:,:), ALLOCATABLE :: & + & llinvalidcell + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zlamtm, & + & zphitm + + !----------------------------------------------------------------------- + ! Define grid setup for grid search + !----------------------------------------------------------------------- + IF (ln_grid_global) THEN + jlon = kpiglo + jlat = kpjglo + joffset = kmyproc + jostride = ktotproc + ELSE + jlon = kpi + jlat = kpj + joffset = 0 + jostride = 1 + ENDIF + !----------------------------------------------------------------------- + ! Set up data for grid search + !----------------------------------------------------------------------- + ALLOCATE( & + & zlamg(jlon,jlat), & + & zphig(jlon,jlat), & + & zmskg(jlon,jlat), & + & zphitmax(jlon-1,jlat-1), & + & zphitmin(jlon-1,jlat-1), & + & zlamtmax(jlon-1,jlat-1), & + & zlamtmin(jlon-1,jlat-1), & + & llinvalidcell(jlon-1,jlat-1), & + & zlamtm(4,jlon-1,jlat-1), & + & zphitm(4,jlon-1,jlat-1) & + & ) + !----------------------------------------------------------------------- + ! Copy data to local arrays + !----------------------------------------------------------------------- + IF (ln_grid_global) THEN + zlamg(:,:) = -1.e+10 + zphig(:,:) = -1.e+10 + zmskg(:,:) = -1.e+10 + DO jj = kldj, klej + DO ji = kldi, klei + zlamg(mig(ji),mjg(jj)) = pglam(ji,jj) + zphig(mig(ji),mjg(jj)) = pgphi(ji,jj) + zmskg(mig(ji),mjg(jj)) = pmask(ji,jj) + END DO + END DO + CALL mpp_global_max( zlamg ) + CALL mpp_global_max( zphig ) + CALL mpp_global_max( zmskg ) + ELSE + DO jj = 1, jlat + DO ji = 1, jlon + zlamg(ji,jj) = pglam(ji,jj) + zphig(ji,jj) = pgphi(ji,jj) + zmskg(ji,jj) = pmask(ji,jj) + END DO + END DO + ENDIF + !----------------------------------------------------------------------- + ! Copy longitudes and latitudes + !----------------------------------------------------------------------- + ALLOCATE( & + & zplam(kobs), & + & zpphi(kobs) & + & ) + DO jo = 1, kobs + zplam(jo) = plam(jo) + zpphi(jo) = pphi(jo) + END DO + !----------------------------------------------------------------------- + ! Set default values for output + !----------------------------------------------------------------------- + kproc(:) = -1 + kobsi(:) = -1 + kobsj(:) = -1 + !----------------------------------------------------------------------- + ! Copy grid positions to temporary arrays and renormalize to 0 to 360. + !----------------------------------------------------------------------- + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + zlamtm(1,ji,jj) = zlamg(ji ,jj ) + zphitm(1,ji,jj) = zphig(ji ,jj ) + zlamtm(2,ji,jj) = zlamg(ji+1,jj ) + zphitm(2,ji,jj) = zphig(ji+1,jj ) + zlamtm(3,ji,jj) = zlamg(ji+1,jj+1) + zphitm(3,ji,jj) = zphig(ji+1,jj+1) + zlamtm(4,ji,jj) = zlamg(ji ,jj+1) + zphitm(4,ji,jj) = zphig(ji ,jj+1) + END DO + END DO + WHERE ( zlamtm(:,:,:) < 0.0_wp ) + zlamtm(:,:,:) = zlamtm(:,:,:) + 360.0_wp + END WHERE + WHERE ( zlamtm(:,:,:) > 360.0_wp ) + zlamtm(:,:,:) = zlamtm(:,:,:) - 360.0_wp + END WHERE + !----------------------------------------------------------------------- + ! Handle case of the wraparound; beware, not working with orca180 + !----------------------------------------------------------------------- + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + zlammax = MAXVAL( zlamtm(:,ji,jj) ) + WHERE (zlammax - zlamtm(:, ji, jj) > 180 ) & + & zlamtm(:,ji,jj) = zlamtm(:,ji,jj) + 360._wp + zphitmax(ji,jj) = MAXVAL(zphitm(:,ji,jj)) + zphitmin(ji,jj) = MINVAL(zphitm(:,ji,jj)) + zlamtmax(ji,jj) = MAXVAL(zlamtm(:,ji,jj)) + zlamtmin(ji,jj) = MINVAL(zlamtm(:,ji,jj)) + END DO + END DO + !----------------------------------------------------------------------- + ! Search for boxes with only land points mark them invalid + !----------------------------------------------------------------------- + llinvalidcell(:,:) = .FALSE. + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + llinvalidcell(ji,jj) = & + & zmskg(ji ,jj ) == 0.0_wp .AND. & + & zmskg(ji+1,jj ) == 0.0_wp .AND. & + & zmskg(ji+1,jj+1) == 0.0_wp .AND. & + & zmskg(ji ,jj+1) == 0.0_wp + END DO + END DO + + !------------------------------------------------------------------------ + ! Master loop for grid search + !------------------------------------------------------------------------ + + DO jo = 1+joffset, kobs, jostride + + !--------------------------------------------------------------------- + ! Ensure that all observation longtiudes are between 0 and 360 + !--------------------------------------------------------------------- + + IF ( zplam(jo) < 0.0_wp ) zplam(jo) = zplam(jo) + 360.0_wp + IF ( zplam(jo) > 360.0_wp ) zplam(jo) = zplam(jo) - 360.0_wp + + !--------------------------------------------------------------------- + ! Find observations which are on within 1e-6 of a grid point + !--------------------------------------------------------------------- + + gridloop: DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + IF ( ABS( zphig(ji,jj) - zpphi(jo) ) < 1e-6 ) THEN + zlam = zlamg(ji,jj) + IF ( zlam < 0.0_wp ) zlam = zlam + 360.0_wp + IF ( zlam > 360.0_wp ) zlam = zlam - 360.0_wp + IF ( ABS( zlam - zplam(jo) ) < 1e-6 ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = kmyproc + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = kmyproc + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridloop + ENDIF + ENDIF + ENDIF + END DO + END DO gridloop + + !--------------------------------------------------------------------- + ! Ensure that all observation longtiudes are between -180 and 180 + !--------------------------------------------------------------------- + + IF ( zplam(jo) > 180 ) zplam(jo) = zplam(jo) - 360.0_wp + + !--------------------------------------------------------------------- + ! Do coordinate search using brute force. + ! - For land points kproc is set to number of the processor + 1000000 + ! and we continue the search. + ! - For ocean points kproc is set to the number of the processor + ! and we stop the search. + !--------------------------------------------------------------------- + + IF ( kproc(jo) == -1 ) THEN + + ! Normal case + gridpoints : DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + + IF ( ( zplam(jo) > zlamtmax(ji,jj) ) .OR. & + & ( zplam(jo) < zlamtmin(ji,jj) ) ) CYCLE + + IF ( ABS( zpphi(jo) ) < 85 ) THEN + IF ( ( zpphi(jo) > zphitmax(ji,jj) ) .OR. & + & ( zpphi(jo) < zphitmin(ji,jj) ) ) CYCLE + ENDIF + + IF ( linquad( zplam(jo), zpphi(jo), & + & zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = kmyproc + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = kmyproc + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridpoints + ENDIF + ENDIF + + END DO + END DO gridpoints + + ENDIF + + ! In case of failure retry for obs. longtiude + 360. + IF ( kproc(jo) == -1 ) THEN + gridpoints_greenwich : DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + + IF ( ( zplam(jo)+360.0_wp > zlamtmax(ji,jj) ) .OR. & + & ( zplam(jo)+360.0_wp < zlamtmin(ji,jj) ) ) CYCLE + + IF ( ABS( zpphi(jo) ) < 85 ) THEN + IF ( ( zpphi(jo) > zphitmax(ji,jj) ) .OR. & + & ( zpphi(jo) < zphitmin(ji,jj) ) ) CYCLE + ENDIF + + IF ( linquad( zplam(jo)+360.0_wp, zpphi(jo), & + & zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = kmyproc + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = kmyproc + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridpoints_greenwich + ENDIF + ENDIF + + END DO + END DO gridpoints_greenwich + + ENDIF + END DO + + !---------------------------------------------------------------------- + ! Synchronize kproc on all processors + !---------------------------------------------------------------------- + IF ( ln_grid_global ) THEN + CALL obs_mpp_max_integer( kproc, kobs ) + CALL obs_mpp_max_integer( kobsi, kobs ) + CALL obs_mpp_max_integer( kobsj, kobs ) + ELSE + CALL obs_mpp_find_obs_proc( kproc, kobs ) + ENDIF + + WHERE( kproc(:) >= 1000000 ) + kproc(:) = kproc(:) - 1000000 + END WHERE + + DEALLOCATE( & + & zlamg, & + & zphig, & + & zmskg, & + & zphitmax, & + & zphitmin, & + & zlamtmax, & + & zlamtmin, & + & llinvalidcell, & + & zlamtm, & + & zphitm, & + & zplam, & + & zpphi & + & ) + + END SUBROUTINE obs_grd_bruteforce \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_grid.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_grid.F90 new file mode 100644 index 0000000..993448b --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_grid.F90 @@ -0,0 +1,1184 @@ +MODULE obs_grid + !!====================================================================== + !! *** MODULE obs_grid *** + !! Observation diagnostics: Various tools for grid searching etc. + !!====================================================================== + !!---------------------------------------------------------------------- + !! obs_grid_search : Find i,j on the ORCA grid from lat,lon + !! obs_level_search : Find level from depth + !! obs_zlevel_search : Find depth level from observed depth + !! obs_tlevel_search : Find temperature level from observed temp + !! obs_rlevel_search : Find density level from observed density + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp + USE par_oce, ONLY : & ! Ocean parameters + & jpk, & + & jpni, & + & jpnj, & + & jpnij + USE dom_oce ! Ocean space and time domain variables + USE obs_mpp, ONLY : & ! MPP support routines for observation diagnostics + & obs_mpp_find_obs_proc, & + & mpp_global_max, & + & obs_mpp_max_integer + USE phycst, ONLY : & ! Physical constants + & rad + USE obs_utils, ONLY : & ! Observation operator utility functions + & grt_cir_dis, & + & chkerr + USE in_out_manager ! Printing support + USE netcdf + USE obs_const, ONLY : & + & obfillflt ! Fillvalue + USE lib_mpp, ONLY : & + & ctl_warn, ctl_stop + + IMPLICIT NONE + + !! * Routine accessibility + PUBLIC obs_grid_setup, & ! Setup grid searching + & obs_grid_search, & ! Find i, j on the ORCA grid from lat, lon + & obs_grid_deallocate, & ! Deallocate the look up table + & obs_level_search ! Find level from depth + + PRIVATE linquad, & ! Determine whether a point lies within a cell + & maxdist, & ! Find the maximum distance between 2 pts in a cell + & obs_grd_bruteforce, & ! Find i, j on the ORCA grid from lat, lon + & obs_grd_lookup ! Find i, j on the ORCA grid from lat, lon quicker + + !!* Module variables + + !! Default values + REAL(wp), PUBLIC :: rn_gridsearchres = 0.5 ! Resolution of grid + INTEGER, PRIVATE :: gsearch_nlons_def ! Num of longitudes + INTEGER, PRIVATE :: gsearch_nlats_def ! Num of latitudes + REAL(wp), PRIVATE :: gsearch_lonmin_def ! Min longitude + REAL(wp), PRIVATE :: gsearch_latmin_def ! Min latitude + REAL(wp), PRIVATE :: gsearch_dlon_def ! Lon spacing + REAL(wp), PRIVATE :: gsearch_dlat_def ! Lat spacing + !! Variable versions + INTEGER, PRIVATE :: nlons ! Num of longitudes + INTEGER, PRIVATE :: nlats ! Num of latitudes + REAL(wp), PRIVATE :: lonmin ! Min longitude + REAL(wp), PRIVATE :: latmin ! Min latitude + REAL(wp), PRIVATE :: dlon ! Lon spacing + REAL(wp), PRIVATE :: dlat ! Lat spacing + + INTEGER, PRIVATE :: maxxdiff, maxydiff ! Max diffs between model points + INTEGER, PRIVATE :: limxdiff, limydiff + + ! Data storage + REAL(wp), PRIVATE, DIMENSION(:,:), ALLOCATABLE :: & + & lons, & + & lats + INTEGER, PRIVATE, DIMENSION(:,:), ALLOCATABLE :: & + & ixpos, & + & iypos, & + & iprocn + + ! Switches + LOGICAL, PUBLIC :: ln_grid_search_lookup ! Use lookup table to speed up grid search + LOGICAL, PUBLIC :: ln_grid_global ! Use global distribution of observations + CHARACTER(LEN=44), PUBLIC :: & + & cn_gridsearchfile ! file name head for grid search lookup + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_grid.F90 14275 2021-01-07 12:13:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_grid_search( kobsin, plam, pphi, kobsi, kobsj, kproc, & + & cdgrid ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_grid_search *** + !! + !! ** Purpose : Search local gridpoints to find the grid box containing + !! the observations calls either + !! obs_grd_bruteforce - the original brute force search + !! or + !! obs_grd_lookup - uses a lookup table to do a fast + !!search + !!History : + !! ! 2007-12 (D. Lea) + !!------------------------------------------------------------------------ + + !! * Arguments + INTEGER :: & + & kobsin ! Size of the observation arrays + REAL(KIND=wp), DIMENSION(kobsin), INTENT(IN) :: & + & plam, & ! Longitude of obsrvations + & pphi ! Latitude of observations + INTEGER, DIMENSION(kobsin), INTENT(OUT) :: & + & kobsi, & ! I-index of observations + & kobsj, & ! J-index of observations + & kproc ! Processor number of observations + CHARACTER(LEN=1) :: & + & cdgrid ! Grid to search + + IF(kobsin > 0) THEN + + IF ( ln_grid_search_lookup .AND. ( cdgrid == 'T' ) ) THEN + CALL obs_grd_lookup( kobsin, plam, pphi, & + & kobsi, kobsj, kproc ) + ELSE + IF ( cdgrid == 'T' ) THEN + CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & + & 1, jpi, 1, jpj, & + & narea-1, jpnij, & + & glamt, gphit, tmask, & + & kobsin, plam, pphi, & + & kobsi, kobsj, kproc ) + ELSEIF ( cdgrid == 'U' ) THEN + CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & + & 1, jpi, 1, jpj, & + & narea-1, jpnij, & + & glamu, gphiu, umask, & + & kobsin, plam, pphi, & + & kobsi, kobsj, kproc ) + ELSEIF ( cdgrid == 'V' ) THEN + CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & + & 1, jpi, 1, jpj, & + & narea-1, jpnij, & + & glamv, gphiv, vmask, & + & kobsin, plam, pphi, & + & kobsi, kobsj, kproc ) + ELSEIF ( cdgrid == 'F' ) THEN + CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & + & 1, jpi, 1, jpj, & + & narea-1, jpnij, & + & glamf, gphif, fmask, & + & kobsin, plam, pphi, & + & kobsi, kobsj, kproc ) + ELSE + CALL ctl_stop( 'Grid not supported' ) + ENDIF + ENDIF + + ENDIF + + END SUBROUTINE obs_grid_search + +#include "obs_grd_bruteforce.h90" + + SUBROUTINE obs_grd_lookup( kobs, plam, pphi, kobsi, kobsj, kproc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_grid_lookup *** + !! + !! ** Purpose : Search local gridpoints to find the grid box containing + !! the observations (much faster then obs_grd_bruteforce) + !! + !! ** Method : Call to linquad + !! + !! ** Action : Return kproc holding the observation and kiobsi,kobsj + !! valid on kproc=narea-1 processor only. + !! + !! History : + !! ! 2007-12 (D. Lea) new routine based on obs_grid_search + !!! updated with fixes from new version of obs_grid_search_bruteforce + !!! speeded up where points are not near a "difficult" region like an edge + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER :: kobs ! Size of the observation arrays + REAL(KIND=wp), DIMENSION(kobs), INTENT(IN) :: & + & plam, & ! Longitude of obsrvations + & pphi ! Latitude of observations + INTEGER, DIMENSION(kobs), INTENT(OUT) :: & + & kobsi, & ! I-index of observations + & kobsj, & ! J-index of observations + & kproc ! Processor number of observations + + !! * Local declarations + REAL(KIND=wp), DIMENSION(:), ALLOCATABLE :: & + & zplam + REAL(wp) :: zlammax + REAL(wp) :: zlam + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jo + INTEGER :: isx + INTEGER :: isy + INTEGER :: jimin + INTEGER :: jimax + INTEGER :: jjmin + INTEGER :: jjmax + INTEGER :: jojimin + INTEGER :: jojimax + INTEGER :: jojjmin + INTEGER :: jojjmax + INTEGER :: ipx1 + INTEGER :: ipy1 + INTEGER :: ip + INTEGER :: jp + INTEGER :: ipx + INTEGER :: ipy + INTEGER :: ipmx + INTEGER :: jlon + INTEGER :: jlat + INTEGER :: joffset + INTEGER :: jostride + REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: & + & zlamg, & + & zphig, & + & zmskg, & + & zphitmax,& + & zphitmin,& + & zlamtmax,& + & zlamtmin + LOGICAL, DIMENSION(:,:), ALLOCATABLE :: & + & llinvalidcell + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zlamtm, & + & zphitm + LOGICAL :: llfourflag + INTEGER :: ifourflagcountt + INTEGER :: ifourflagcountf + INTEGER, DIMENSION(5) :: ifourflagcountr + + !----------------------------------------------------------------------- + ! Define grid for grid search + !----------------------------------------------------------------------- + IF (ln_grid_global) THEN + jlon = jpiglo + jlat = jpjglo + joffset = narea-1 + jostride = jpnij + ELSE + jlon = jpi + jlat = jpj + joffset = 0 + jostride = 1 + ENDIF + !----------------------------------------------------------------------- + ! Set up data for grid search + !----------------------------------------------------------------------- + ALLOCATE( & + & zlamg(jlon,jlat), & + & zphig(jlon,jlat), & + & zmskg(jlon,jlat), & + & zphitmax(jlon-1,jlat-1), & + & zphitmin(jlon-1,jlat-1), & + & zlamtmax(jlon-1,jlat-1), & + & zlamtmin(jlon-1,jlat-1), & + & llinvalidcell(jlon-1,jlat-1), & + & zlamtm(4,jlon-1,jlat-1), & + & zphitm(4,jlon-1,jlat-1) & + & ) + !----------------------------------------------------------------------- + ! Copy data to local arrays + !----------------------------------------------------------------------- + IF (ln_grid_global) THEN + zlamg(:,:) = -1.e+10 + zphig(:,:) = -1.e+10 + zmskg(:,:) = -1.e+10 + ! Add various grids here. + DO jj = 1, jpj + DO ji = 1, jpi + zlamg(mig(ji),mjg(jj)) = glamt(ji,jj) + zphig(mig(ji),mjg(jj)) = gphit(ji,jj) + zmskg(mig(ji),mjg(jj)) = tmask(ji,jj,1) + END DO + END DO + CALL mpp_global_max( zlamg ) + CALL mpp_global_max( zphig ) + CALL mpp_global_max( zmskg ) + ELSE + ! Add various grids here. + DO jj = 1, jlat + DO ji = 1, jlon + zlamg(ji,jj) = glamt(ji,jj) + zphig(ji,jj) = gphit(ji,jj) + zmskg(ji,jj) = tmask(ji,jj,1) + END DO + END DO + ENDIF + !----------------------------------------------------------------------- + ! Copy longitudes + !----------------------------------------------------------------------- + ALLOCATE( & + & zplam(kobs) & + & ) + DO jo = 1, kobs + zplam(jo) = plam(jo) + END DO + !----------------------------------------------------------------------- + ! Set default values for output + !----------------------------------------------------------------------- + kproc(:) = -1 + kobsi(:) = -1 + kobsj(:) = -1 + !----------------------------------------------------------------------- + ! Copy grid positions to temporary arrays and renormalize to 0 to 360. + !----------------------------------------------------------------------- + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + zlamtm(1,ji,jj) = zlamg(ji ,jj ) + zphitm(1,ji,jj) = zphig(ji ,jj ) + zlamtm(2,ji,jj) = zlamg(ji+1,jj ) + zphitm(2,ji,jj) = zphig(ji+1,jj ) + zlamtm(3,ji,jj) = zlamg(ji+1,jj+1) + zphitm(3,ji,jj) = zphig(ji+1,jj+1) + zlamtm(4,ji,jj) = zlamg(ji ,jj+1) + zphitm(4,ji,jj) = zphig(ji ,jj+1) + END DO + END DO + WHERE ( zlamtm(:,:,:) < 0.0_wp ) + zlamtm(:,:,:) = zlamtm(:,:,:) + 360.0_wp + END WHERE + WHERE ( zlamtm(:,:,:) > 360.0_wp ) + zlamtm(:,:,:) = zlamtm(:,:,:) - 360.0_wp + END WHERE + !----------------------------------------------------------------------- + ! Handle case of the wraparound; beware, not working with orca180 + !----------------------------------------------------------------------- + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + zlammax = MAXVAL( zlamtm(:,ji,jj) ) + WHERE (zlammax - zlamtm(:, ji, jj) > 180 ) & + & zlamtm(:,ji,jj) = zlamtm(:,ji,jj) + 360._wp + zphitmax(ji,jj) = MAXVAL(zphitm(:,ji,jj)) + zphitmin(ji,jj) = MINVAL(zphitm(:,ji,jj)) + zlamtmax(ji,jj) = MAXVAL(zlamtm(:,ji,jj)) + zlamtmin(ji,jj) = MINVAL(zlamtm(:,ji,jj)) + END DO + END DO + !----------------------------------------------------------------------- + ! Search for boxes with only land points mark them invalid + !----------------------------------------------------------------------- + llinvalidcell(:,:) = .FALSE. + DO jj = 1, jlat-1 + DO ji = 1, jlon-1 + llinvalidcell(ji,jj) = & + & zmskg(ji ,jj ) == 0.0_wp .AND. & + & zmskg(ji+1,jj ) == 0.0_wp .AND. & + & zmskg(ji+1,jj+1) == 0.0_wp .AND. & + & zmskg(ji ,jj+1) == 0.0_wp + END DO + END DO + + if(lwp) WRITE(numout,*) 'obs_grid_lookup do coordinate search using lookup table' + + !----------------------------------------------------------------------- + ! Do coordinate search using lookup table with local searches. + ! - For land points kproc is set to number of the processor + 1000000 + ! and we continue the search. + ! - For ocean points kproc is set to the number of the processor + ! and we stop the search. + !----------------------------------------------------------------------- + ifourflagcountt = 0 + ifourflagcountf = 0 + ifourflagcountr(:) = 0 + + !------------------------------------------------------------------------ + ! Master loop for grid search + !------------------------------------------------------------------------ + + gpkobs: DO jo = 1+joffset, kobs, jostride + ! Normal case + ! specify 4 points which surround the lat lon of interest + ! x i,j+1 x i+1, j+1 + ! + ! + ! * lon,lat + ! x i,j x i+1,j + + ! bottom corner point + ipx1 = INT( ( zplam(jo) - lonmin ) / dlon + 1.0 ) + ipy1 = INT( ( pphi (jo) - latmin ) / dlat + 1.0 ) + + ipx = ipx1 + 1 + ipy = ipy1 + 1 + + ! flag for searching around four points separately + ! default to false + llfourflag = .FALSE. + + ! check for point fully outside of region + IF ( (ipx1 > nlons) .OR. (ipy1 > nlats) .OR. & + & (ipx < 1) .OR. (ipy < 1) ) THEN + CYCLE + ENDIF + ! check wrap around + IF ( (ipx > nlons) .OR. (ipy > nlats) .OR. & + & (ipx1 < 1) .OR. (ipy1 < 1) ) THEN + llfourflag=.TRUE. + ifourflagcountr(1) = ifourflagcountr(1) + 1 + ENDIF + + IF (.NOT. llfourflag) THEN + IF (MAXVAL(ixpos(ipx1:ipx,ipy1:ipy)) == -1) CYCLE! cycle if no lookup points found + ENDIF + + jimin = 0 + jimax = 0 + jjmin = 0 + jjmax = 0 + + IF (.NOT. llfourflag) THEN + + ! calculate points range + ! define a square region encompassing the four corner points + ! do I need the -1 points? + + jojimin = MINVAL(ixpos(ipx1:ipx,ipy1:ipy)) - 1 + jojimax = MAXVAL(ixpos(ipx1:ipx,ipy1:ipy)) + 1 + jojjmin = MINVAL(iypos(ipx1:ipx,ipy1:ipy)) - 1 + jojjmax = MAXVAL(iypos(ipx1:ipx,ipy1:ipy)) + 1 + + jimin = jojimin - 1 + jimax = jojimax + 1 + jjmin = jojjmin - 1 + jjmax = jojjmax + 1 + + IF ( jojimin < 0 .OR. jojjmin < 0) THEN + llfourflag = .TRUE. + ifourflagcountr(2) = ifourflagcountr(2) + 1 + ENDIF + IF ( jojimax - jojimin > maxxdiff) THEN + llfourflag = .TRUE. + ifourflagcountr(3) = ifourflagcountr(3) + 1 + ENDIF + IF ( jojjmax - jojjmin > maxydiff) THEN + llfourflag = .TRUE. + ifourflagcountr(4) = ifourflagcountr(4) + 1 + ENDIF + + ENDIF + + ipmx = 0 + IF (llfourflag) ipmx = 1 + + IF (llfourflag) THEN + ifourflagcountt = ifourflagcountt + 1 + ELSE + ifourflagcountf = ifourflagcountf + 1 + ENDIF + + gridpointsn : DO ip = 0, ipmx + DO jp = 0, ipmx + + IF ( kproc(jo) /= -1 ) EXIT gridpointsn + + ipx = ipx1 + ip + ipy = ipy1 + jp + + IF (llfourflag) THEN + + ! deal with wrap around + IF ( ipx > nlons ) ipx = 1 + IF ( ipy > nlats ) ipy = 1 + IF ( ipx < 1 ) ipx = nlons + IF ( ipy < 1 ) ipy = nlats + + ! get i,j + isx = ixpos(ipx,ipy) + isy = iypos(ipx,ipy) + + ! estimate appropriate search region (use max/min values) + jimin = isx - maxxdiff - 1 + jimax = isx + maxxdiff + 1 + jjmin = isy - maxydiff - 1 + jjmax = isy + maxydiff + 1 + + ENDIF + + IF ( jimin < 1 ) jimin = 1 + IF ( jimax > jlon-1 ) jimax = jlon-1 + IF ( jjmin < 1 ) jjmin = 1 + IF ( jjmax > jlat-1 ) jjmax = jlat-1 + + !--------------------------------------------------------------- + ! Ensure that all observation longtiudes are between 0 and 360 + !--------------------------------------------------------------- + + IF ( zplam(jo) < 0.0_wp ) zplam(jo) = zplam(jo) + 360.0_wp + IF ( zplam(jo) > 360.0_wp ) zplam(jo) = zplam(jo) - 360.0_wp + + !--------------------------------------------------------------- + ! Find observations which are on within 1e-6 of a grid point + !--------------------------------------------------------------- + + gridloop: DO jj = jjmin, jjmax + DO ji = jimin, jimax + IF ( ABS( zphig(ji,jj) - pphi(jo) ) < 1e-6 ) THEN + zlam = zlamg(ji,jj) + IF ( zlam < 0.0_wp ) zlam = zlam + 360.0_wp + IF ( zlam > 360.0_wp ) zlam = zlam - 360.0_wp + IF ( ABS( zlam - zplam(jo) ) < 1e-6 ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = narea-1 + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = narea-1 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridloop + ENDIF + ENDIF + ENDIF + END DO + END DO gridloop + + !--------------------------------------------------------------- + ! Ensure that all observation longtiudes are between -180/180 + !--------------------------------------------------------------- + + IF ( zplam(jo) > 180 ) zplam(jo) = zplam(jo) - 360.0_wp + + IF ( kproc(jo) == -1 ) THEN + + ! Normal case + gridpoints : DO jj = jjmin, jjmax + DO ji = jimin, jimax + + + IF ( ( zplam(jo) > zlamtmax(ji,jj) ) .OR. & + & ( zplam(jo) < zlamtmin(ji,jj) ) ) CYCLE + + IF ( ABS( pphi(jo) ) < 85 ) THEN + IF ( ( pphi(jo) > zphitmax(ji,jj) ) .OR. & + & ( pphi(jo) < zphitmin(ji,jj) ) ) CYCLE + ENDIF + + IF ( linquad( zplam(jo), pphi(jo), & + & zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = narea-1 + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = narea-1 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridpoints + ENDIF + ENDIF + + END DO + END DO gridpoints + ENDIF + + ! In case of failure retry for obs. longtiude + 360. + IF ( kproc(jo) == -1 ) THEN + gridpoints_greenwich : DO jj = jjmin, jjmax + DO ji = jimin, jimax + + IF ( ( zplam(jo)+360.0_wp > zlamtmax(ji,jj) ) .OR. & + & ( zplam(jo)+360.0_wp < zlamtmin(ji,jj) ) ) CYCLE + + IF ( ABS( pphi(jo) ) < 85 ) THEN + IF ( ( pphi(jo) > zphitmax(ji,jj) ) .OR. & + & ( pphi(jo) < zphitmin(ji,jj) ) ) CYCLE + ENDIF + + IF ( linquad( zplam(jo)+360.0_wp, pphi(jo), & + & zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN + IF ( llinvalidcell(ji,jj) ) THEN + kproc(jo) = narea-1 + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = narea-1 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + EXIT gridpoints_greenwich + ENDIF + ENDIF + + END DO + END DO gridpoints_greenwich + + ENDIF ! kproc + + END DO + END DO gridpointsn + END DO gpkobs ! kobs + + !---------------------------------------------------------------------- + ! Synchronize kproc on all processors + !---------------------------------------------------------------------- + IF ( ln_grid_global ) THEN + CALL obs_mpp_max_integer( kproc, kobs ) + CALL obs_mpp_max_integer( kobsi, kobs ) + CALL obs_mpp_max_integer( kobsj, kobs ) + ELSE + CALL obs_mpp_find_obs_proc( kproc, kobs ) + ENDIF + + WHERE( kproc(:) >= 1000000 ) + kproc(:) = kproc(:) - 1000000 + END WHERE + + DEALLOCATE( & + & zlamg, & + & zphig, & + & zmskg, & + & zphitmax, & + & zphitmin, & + & zlamtmax, & + & zlamtmin, & + & llinvalidcell, & + & zlamtm, & + & zphitm, & + & zplam & + & ) + + END SUBROUTINE obs_grd_lookup + + + SUBROUTINE obs_grid_setup + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_grid_setup *** + !! + !! ** Purpose : Setup a lookup table to reduce the searching required + !! for converting lat lons to grid point location + !! produces or reads in a preexisting file for use in + !! obs_grid_search_lookup_local + !! + !! ** Method : calls obs_grid_search_bruteforce_local with a array + !! of lats and lons + !! + !! History : + !! ! 2007-12 (D. Lea) new routine + !!---------------------------------------------------------------------- + + !! * Local declarations + CHARACTER(LEN=15), PARAMETER :: & + & cpname = 'obs_grid_setup' + CHARACTER(LEN=40) :: cfname + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jo + INTEGER :: idfile, idny, idnx, idxpos, idypos + INTEGER :: idlat, idlon, fileexist + INTEGER, DIMENSION(2) :: incdim + CHARACTER(LEN=20) :: datestr=" ",timestr=" " + REAL(wp) :: tmpx1, tmpx2, tmpy1, tmpy2 + REAL(wp) :: meanxdiff, meanydiff + REAL(wp) :: meanxdiff1, meanydiff1 + REAL(wp) :: meanxdiff2, meanydiff2 + INTEGER :: numx1, numx2, numy1, numy2, df + INTEGER :: jimin, jimax, jjmin, jjmax + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: & + & lonsi, & + & latsi + INTEGER, DIMENSION(:,:), ALLOCATABLE :: & + & ixposi, & + & iyposi, & + & iproci + INTEGER, PARAMETER :: histsize=90 + INTEGER, DIMENSION(histsize) :: & + & histx1, histx2, histy1, histy2 + REAL(wp), DIMENSION(histsize) :: & + & fhistx1, fhistx2, fhisty1, fhisty2 + REAL(wp) :: histtol + CHARACTER(LEN=26) :: clfmt ! writing format + INTEGER :: idg ! number of digits + + IF (ln_grid_search_lookup) THEN + + WRITE(numout,*) 'Calling obs_grid_setup' + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)'Grid search resolution : ', rn_gridsearchres + + gsearch_nlons_def = NINT( 360.0_wp / rn_gridsearchres ) + gsearch_nlats_def = NINT( 180.0_wp / rn_gridsearchres ) + gsearch_lonmin_def = -180.0_wp + 0.5_wp * rn_gridsearchres + gsearch_latmin_def = -90.0_wp + 0.5_wp * rn_gridsearchres + gsearch_dlon_def = rn_gridsearchres + gsearch_dlat_def = rn_gridsearchres + + IF (lwp) THEN + WRITE(numout,*)'Grid search gsearch_nlons_def = ',gsearch_nlons_def + WRITE(numout,*)'Grid search gsearch_nlats_def = ',gsearch_nlats_def + WRITE(numout,*)'Grid search gsearch_lonmin_def = ',gsearch_lonmin_def + WRITE(numout,*)'Grid search gsearch_latmin_def = ',gsearch_latmin_def + WRITE(numout,*)'Grid search gsearch_dlon_def = ',gsearch_dlon_def + WRITE(numout,*)'Grid search gsearch_dlat_def = ',gsearch_dlat_def + ENDIF + + IF ( ln_grid_global ) THEN + WRITE(cfname, FMT="(A,'_',A)") TRIM(cn_gridsearchfile), 'global.nc' + ELSE + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + ! define the following format: "(a,a,ix.x,a,ix.x,a,ix.x,a)" + WRITE(clfmt, "('(a,a,i', i1, '.', i1',a,i', i1, '.', i1',a,i', i1, '.', i1',a)')") idg, idg, idg, idg, idg, idg + WRITE(cfname, clfmt ) TRIM(cn_gridsearchfile),'_', narea-1,'of', jpni,'by', jpnj,'.nc' + ENDIF + + fileexist=nf90_open( TRIM( cfname ), nf90_nowrite, & + & idfile ) + + IF ( fileexist == nf90_noerr ) THEN + + ! read data + ! initially assume size is as defined (to be fixed) + + WRITE(numout,*) 'Reading: ',cfname + + CALL chkerr( nf90_open( TRIM( cfname ), nf90_nowrite, idfile ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'maxxdiff', maxxdiff ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'maxydiff', maxydiff ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'dlon', dlon ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'dlat', dlat ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'lonmin', lonmin ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'latmin', latmin ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_inq_dimid(idfile, 'nx' , idnx), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( idfile, idnx, len = nlons ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_dimid(idfile, 'ny' , idny), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( idfile, idny, len = nlats ), & + & cpname, __LINE__ ) + + ALLOCATE( & + & lons(nlons,nlats), & + & lats(nlons,nlats), & + & ixpos(nlons,nlats), & + & iypos(nlons,nlats), & + & iprocn(nlons,nlats) & + & ) + + CALL chkerr( nf90_inq_varid( idfile, 'XPOS', idxpos ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( idfile, idxpos, ixpos), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'YPOS', idypos ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( idfile, idypos, iypos), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_close( idfile ), cpname, __LINE__ ) + + ! setup arrays + + DO ji = 1, nlons + DO jj = 1, nlats + lons(ji,jj) = lonmin + (ji-1) * dlon + lats(ji,jj) = latmin + (jj-1) * dlat + END DO + END DO + + ! if we are not reading the file we need to create it + ! create new obs grid search lookup file + + ELSE + + ! call obs_grid_search + + IF (lwp) THEN + WRITE(numout,*) 'creating: ',cfname + WRITE(numout,*) 'calling obs_grid_search: ',nlons*nlats + ENDIF + + ! set parameters from default values + nlons = gsearch_nlons_def + nlats = gsearch_nlats_def + lonmin = gsearch_lonmin_def + latmin = gsearch_latmin_def + dlon = gsearch_dlon_def + dlat = gsearch_dlat_def + + ! setup arrays + + ALLOCATE( & + & lonsi(nlons,nlats), & + & latsi(nlons,nlats), & + & ixposi(nlons,nlats), & + & iyposi(nlons,nlats), & + & iproci(nlons,nlats) & + & ) + + DO ji = 1, nlons + DO jj = 1, nlats + lonsi(ji,jj) = lonmin + (ji-1) * dlon + latsi(ji,jj) = latmin + (jj-1) * dlat + END DO + END DO + + CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & + & 1, jpi, 1, jpj, & + & narea-1, jpnij, & + & glamt, gphit, tmask, & + & nlons*nlats, lonsi, latsi, & + & ixposi, iyposi, iproci ) + + ! minimise file size by removing regions with no data from xypos file + ! should be able to just use xpos (ypos will have the same areas of missing data) + + jimin=1 + jimax=nlons + jjmin=1 + jjmax=nlats + + minlon_xpos: DO ji= 1, nlons + IF (COUNT(ixposi(ji,:) >= 0) > 0) THEN + jimin=ji + EXIT minlon_xpos + ENDIF + END DO minlon_xpos + + maxlon_xpos: DO ji= nlons, 1, -1 + IF (COUNT(ixposi(ji,:) >= 0) > 0) THEN + jimax=ji + EXIT maxlon_xpos + ENDIF + END DO maxlon_xpos + + minlat_xpos: DO jj= 1, nlats + IF (COUNT(ixposi(:,jj) >= 0) > 0) THEN + jjmin=jj + EXIT minlat_xpos + ENDIF + END DO minlat_xpos + + maxlat_xpos: DO jj= nlats, 1, -1 + IF (COUNT(ixposi(:,jj) >= 0) > 0) THEN + jjmax=jj + EXIT maxlat_xpos + ENDIF + END DO maxlat_xpos + + lonmin = lonsi(jimin,jjmin) + latmin = latsi(jimin,jjmin) + nlons = jimax-jimin+1 + nlats = jjmax-jjmin+1 + + ! construct new arrays + + ALLOCATE( & + & lons(nlons,nlats), & + & lats(nlons,nlats), & + & ixpos(nlons,nlats), & + & iypos(nlons,nlats), & + & iprocn(nlons,nlats) & + & ) + + lons(:,:) = lonsi(jimin:jimax,jjmin:jjmax) + lats(:,:) = latsi(jimin:jimax,jjmin:jjmax) + ixpos(:,:) = ixposi(jimin:jimax,jjmin:jjmax) + iypos(:,:) = iyposi(jimin:jimax,jjmin:jjmax) + iprocn(:,:) = iproci(jimin:jimax,jjmin:jjmax) + + DEALLOCATE(lonsi,latsi,ixposi,iyposi,iproci) + + ! calculate (estimate) maxxdiff, maxydiff + ! this is to help define the search area for obs_grid_search_lookup + + maxxdiff = 1 + maxydiff = 1 + + tmpx1 = 0 + tmpx2 = 0 + tmpy1 = 0 + tmpy2 = 0 + + numx1 = 0 + numx2 = 0 + numy1 = 0 + numy2 = 0 + + ! calculate the mean absolute xdiff and ydiff + ! also calculate a histogram + ! note the reason why looking for xdiff and ydiff in both directions + ! is to allow for rotated grids + + DO ji = 1, nlons-1 + DO jj = 1, nlats-1 + IF ( ixpos(ji,jj) > 0 .AND. iypos(ji,jj) > 0 ) THEN + IF ( ixpos(ji+1,jj) > 0 ) THEN + df = ABS( ixpos(ji+1,jj) - ixpos(ji,jj) ) + tmpx1 = tmpx1+df + numx1 = numx1+1 + IF ( df < histsize ) histx1(df+1) = histx1(df+1) + 1 + ENDIF + IF ( ixpos(ji,jj+1) > 0 ) THEN + df = ABS( ixpos(ji,jj+1) - ixpos(ji,jj) ) + tmpx2 = tmpx2 + df + numx2 = numx2 + 1 + IF ( df < histsize ) histx2(df+1) = histx2(df+1) + 1 + ENDIF + IF (iypos(ji+1,jj) > 0) THEN + df = ABS( iypos(ji+1,jj) - iypos(ji,jj) ) + tmpy1 = tmpy1 + df + numy1 = numy1 + 1 + IF ( df < histsize ) histy1(df+1) = histy1(df+1) + 1 + ENDIF + IF ( iypos(ji,jj+1) > 0 ) THEN + df = ABS( iypos(ji,jj+1) - iypos(ji,jj) ) + tmpy2 = tmpy2 + df + numy2 = numy2 + 1 + IF ( df < histsize ) histy2(df+1) = histy2(df+1) + 1 + ENDIF + ENDIF + END DO + END DO + + IF (lwp) THEN + WRITE(numout,*) 'histograms' + WRITE(numout,*) '0 1 2 3 4 5 6 7 8 9 10 ...' + WRITE(numout,*) 'histx1' + WRITE(numout,*) histx1 + WRITE(numout,*) 'histx2' + WRITE(numout,*) histx2 + WRITE(numout,*) 'histy1' + WRITE(numout,*) histy1 + WRITE(numout,*) 'histy2' + WRITE(numout,*) histy2 + ENDIF + + meanxdiff1 = tmpx1 / numx1 + meanydiff1 = tmpy1 / numy1 + meanxdiff2 = tmpx2 / numx2 + meanydiff2 = tmpy2 / numy2 + + meanxdiff = MAXVAL((/ meanxdiff1, meanxdiff2 /)) + meanydiff = MAXVAL((/ meanydiff1, meanydiff2 /)) + + IF (lwp) THEN + WRITE(numout,*) tmpx1, tmpx2, tmpy1, tmpy2 + WRITE(numout,*) numx1, numx2, numy1, numy2 + WRITE(numout,*) 'meanxdiff: ',meanxdiff, meanxdiff1, meanxdiff2 + WRITE(numout,*) 'meanydiff: ',meanydiff, meanydiff1, meanydiff2 + ENDIF + + tmpx1 = 0 + tmpx2 = 0 + tmpy1 = 0 + tmpy2 = 0 + + numx1 = 0 + numx2 = 0 + numy1 = 0 + numy2 = 0 + + histx1(:) = 0 + histx2(:) = 0 + histy1(:) = 0 + histy2(:) = 0 + + limxdiff = meanxdiff * 4! limit the difference to avoid picking up wraparound + limydiff = meanydiff * 4 + + DO ji = 1, nlons-1 + DO jj = 1, nlats-1 + IF ( ixpos(ji,jj) > 0 .AND. iypos(ji,jj) > 0 ) THEN + + IF ( ixpos(ji+1,jj) > 0 ) THEN + df = ABS( ixpos(ji+1,jj)-ixpos(ji,jj) ) + tmpx1 = df + IF ( df < limxdiff ) numx1 = numx1+1 + IF ( df < histsize ) histx1(df+1) = histx1(df+1) + 1 + ENDIF + IF ( ixpos(ji,jj+1) > 0 ) THEN + df = ABS( ixpos(ji,jj+1) - ixpos(ji,jj) ) + tmpx2 = df + IF ( df < limxdiff ) numx2 = numx2 + 1 + IF ( df < histsize ) histx2(df+1) = histx2(df+1) + 1 + ENDIF + IF (iypos(ji+1,jj) > 0) THEN + df = ABS( iypos(ji+1,jj) - iypos(ji,jj) ) + tmpy1 = df + IF ( df < limydiff ) numy1 = numy1 + 1 + IF ( df < histsize ) histy1(df+1) = histy1(df+1) + 1 + ENDIF + IF (iypos(ji,jj+1) > 0) THEN + df = ABS( iypos(ji,jj+1) - iypos(ji,jj) ) + tmpy2 = df + IF ( df < limydiff ) numy2 = numy2+1 + IF ( df < histsize ) histy2(df+1) = histy2(df+1)+1 + ENDIF + + IF ( maxxdiff < tmpx1 .AND. tmpx1 < limxdiff ) & + & maxxdiff = tmpx1 + IF ( maxxdiff < tmpx2 .AND. tmpx2 < limxdiff ) & + & maxxdiff = tmpx2 + IF ( maxydiff < tmpy1 .AND. tmpy1 < limydiff ) & + & maxydiff = tmpy1 + IF ( maxydiff < tmpy2 .AND. tmpy2 < limydiff ) & + & maxydiff = tmpy2 + + ENDIF + END DO + END DO + + ! cumulative histograms + + DO ji = 1, histsize - 1 + histx1(ji+1) = histx1(ji+1) + histx1(ji) + histx2(ji+1) = histx2(ji+1) + histx2(ji) + histy1(ji+1) = histy1(ji+1) + histy1(ji) + histy2(ji+1) = histy2(ji+1) + histy2(ji) + END DO + + fhistx1(:) = histx1(:) * 1.0 / numx1 + fhistx2(:) = histx2(:) * 1.0 / numx2 + fhisty1(:) = histy1(:) * 1.0 / numy1 + fhisty2(:) = histy2(:) * 1.0 / numy2 + + ! output new histograms + + IF (lwp) THEN + WRITE(numout,*) 'cumulative histograms' + WRITE(numout,*) '0 1 2 3 4 5 6 7 8 9 10 ...' + WRITE(numout,*) 'fhistx1' + WRITE(numout,*) fhistx1 + WRITE(numout,*) 'fhistx2' + WRITE(numout,*) fhistx2 + WRITE(numout,*) 'fhisty1' + WRITE(numout,*) fhisty1 + WRITE(numout,*) 'fhisty2' + WRITE(numout,*) fhisty2 + ENDIF + + ! calculate maxxdiff and maxydiff based on cumulative histograms + ! where > 0.999 of points are + + ! maxval just converts 1x1 vector return from maxloc to a scalar + + histtol = 0.999 + tmpx1 = MAXVAL( MAXLOC( fhistx1(:), mask = ( fhistx1(:) <= histtol ) ) ) + tmpx2 = MAXVAL( MAXLOC( fhistx2(:), mask = ( fhistx2(:) <= histtol ) ) ) + tmpy1 = MAXVAL( MAXLOC( fhisty1(:), mask = ( fhisty1(:) <= histtol ) ) ) + tmpy2 = MAXVAL( MAXLOC( fhisty2(:), mask = ( fhisty2(:) <= histtol ) ) ) + + maxxdiff = MAXVAL( (/ tmpx1, tmpx2 /) ) + 1 + maxydiff = MAXVAL( (/ tmpy1, tmpy2 /) ) + 1 + + ! Write out data + + IF ( ( .NOT. ln_grid_global ) .OR. & + & ( ( ln_grid_global ) .AND. ( narea-1==0 ) ) ) THEN + + CALL chkerr( nf90_create (TRIM(cfname), nf90_clobber, idfile), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'title', & + & 'Mapping file from lon/lat to model grid point' ),& + & cpname,__LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'maxxdiff', & + & maxxdiff ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'maxydiff', & + & maxydiff ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'dlon', dlon ),& + & cpname,__LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'dlat', dlat ),& + & cpname,__LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'lonmin', & + & lonmin ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'latmin', & + & latmin ), & + & cpname,__LINE__ ) + + CALL chkerr( nf90_def_dim(idfile, 'nx' , nlons, idnx), & + & cpname,__LINE__ ) + CALL chkerr( nf90_def_dim(idfile, 'ny' , nlats, idny), & + & cpname,__LINE__ ) + + incdim(1) = idnx + incdim(2) = idny + + CALL chkerr( nf90_def_var( idfile, 'LON', nf90_float, incdim, & + & idlon ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, idlon, 'long_name', & + & 'longitude' ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_def_var( idfile, 'LAT', nf90_float, incdim, & + & idlat ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, idlat, 'long_name', & + & 'latitude' ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_def_var( idfile, 'XPOS', nf90_int, incdim, & + & idxpos ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, idxpos, 'long_name', & + & 'x position' ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, idxpos, '_FillValue', -1 ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_def_var( idfile, 'YPOS', nf90_int, incdim, & + & idypos ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, idypos, 'long_name', & + & 'y position' ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, idypos, '_FillValue', -1 ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_enddef( idfile ), cpname, __LINE__ ) + + CALL chkerr( nf90_put_var( idfile, idlon, lons), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idlat, lats), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idxpos, ixpos), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idypos, iypos), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_close( idfile ), cpname, __LINE__ ) + + ! should also output max i, max j spacing for use in + ! obs_grid_search_lookup + + ENDIF + + ENDIF + + ENDIF + + END SUBROUTINE obs_grid_setup + + SUBROUTINE obs_grid_deallocate( ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_grid_setup *** + !! + !! ** Purpose : Deallocate arrays setup by obs_grid_setup + !! + !! History : + !! ! 2007-12 (D. Lea) new routine + !!----------------------------------------------------------------------- + + IF (ln_grid_search_lookup) THEN + DEALLOCATE( lons, lats, ixpos, iypos, iprocn ) + ENDIF + + END SUBROUTINE obs_grid_deallocate + +#include "obs_level_search.h90" + +#include "linquad.h90" + +#include "maxdist.h90" + +#include "find_obs_proc.h90" + +END MODULE obs_grid \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_inter_h2d.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_inter_h2d.F90 new file mode 100644 index 0000000..1d5c65c --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_inter_h2d.F90 @@ -0,0 +1,58 @@ +MODULE obs_inter_h2d + !!====================================================================== + !! *** MODULE obs_inter_h2d *** + !! Observation diagnostics: Perform the horizontal interpolation + !! from model grid to observation location + !!===================================================================== + + !!---------------------------------------------------------------------- + !! obs_int_h2d : Horizontal interpolation to the observation point + !! obs_int_h2d_ds1 : Distance-weighted interpolation (n2dint=0) + !! obs_int_h2d_ds2 : Distance-weighted interpolation (small angle) (n2dint=1) + !! obs_int_h2d_bil : Bilinear interpolation (geographical grid) (n2dint=2) + !! obs_int_h2d_bir : Bilinear remapping interpolation (general grid) (n2dint=3) + !! obs_int_h2d_pol : Polynomial interpolation (n2dint=4) + !! bil_wgt : Compute weights for bilinear remapping + !! lu_invmat : Invert a matrix using LU decomposition + !! lu_decomp : LU decomposition + !! lu_backsb : LU decomposition - back substitution + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp + USE phycst, ONLY : & ! Physical constants + & rad, & + & rpi + USE in_out_manager + USE obs_const, ONLY : & + & obfillflt ! Fillvalue + USE obs_utils ! Utility functions + USE lib_mpp,ONLY : & + & ctl_warn, ctl_stop + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE obs_int_h2d_ds1, & ! Distance-weighted interpolation + & obs_int_h2d_ds2, & ! Distance-weighted interpolation (small angle) + & obs_int_h2d_bil, & ! Bilinear interpolation (geographical grid) + & obs_int_h2d_bir, & ! Bilinear remapping interpolation (general grid) + & obs_int_h2d_pol, & ! Polynomial interpolation + & lu_invmat, & ! Invert a matrix using LU decomposition + & lu_decomp, & ! LU decomposition + & lu_backsb, & ! LU decomposition - back substitution + & bil_wgt ! Compute weights for bilinear remapping + PUBLIC obs_int_h2d, & ! Horizontal interpolation to the observation point + & obs_int_h2d_init ! Set up weights and vertical mask + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_inter_h2d.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "obsinter_h2d.h90" + +END MODULE obs_inter_h2d \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_inter_sup.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_inter_sup.F90 new file mode 100644 index 0000000..128ae93 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_inter_sup.F90 @@ -0,0 +1,385 @@ +MODULE obs_inter_sup + !!===================================================================== + !! *** MODULE obs_inter_sup *** + !! Observation diagnostics: Support for interpolation + !!===================================================================== + + !!---------------------------------------------------------------------- + !! obs_int_comm_3d : Get 3D interpolation stencil + !! obs_int_comm_2d : Get 2D interpolation stencil + !!--------------------------------------------------------------------- + !! * Modules used + USE par_kind ! Precision variables + USE dom_oce ! Domain variables + USE mpp_map ! Map of processor points + USE lib_mpp ! MPP stuff + USE obs_mpp ! MPP stuff for observations + USE obs_grid ! Grid tools + USE in_out_manager ! I/O stuff + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_int_comm_3d, & ! Get 3D interpolation stencil + & obs_int_comm_2d ! Get 2D interpolation stencil + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_inter_sup.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & + & pval, pgval, kproc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_int_comm_3d *** + !! + !! ** Purpose : Get 3D interpolation stencil + !! + !! ** Method : Either on-demand communication with + !! obs_int_comm_3d_global + !! or local memory with + !! obs_int_comm_3D_local + !! depending on ln_global_grid + !! + !! ** Action : + !! + !! History : + !! ! 08-02 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN) :: kptsi ! Number of i horizontal points per stencil + INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil + INTEGER, INTENT(IN) :: kobs ! Local number of observations + INTEGER, INTENT(IN) :: kpi ! Number of points in i direction + INTEGER, INTENT(IN) :: kpj ! Number of points in j direction + INTEGER, INTENT(IN) :: kpk ! Number of levels + INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kgrdi, & ! i,j indicies for each stencil + & kgrdj + INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kproc ! Precomputed processor for each i,j,iobs points + REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& + & pval ! Local 3D array to extract data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point + !! * Local declarations + + IF (ln_grid_global) THEN + + IF (PRESENT(kproc)) THEN + + CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, & + & kgrdj, pval, pgval, kproc=kproc ) + + ELSE + + CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, & + & kgrdj, pval, pgval ) + + ENDIF + + ELSE + + CALL obs_int_comm_3d_local( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & + & pval, pgval ) + + ENDIF + + END SUBROUTINE obs_int_comm_3d + + SUBROUTINE obs_int_comm_2d( kptsi, kptsj, kobs, kpi, kpj, kgrdi, kgrdj, pval, pgval, & + & kproc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_int_comm_2d *** + !! + !! ** Purpose : Get 2D interpolation stencil + !! + !! ** Method : Call to obs_int_comm_3d + !! + !! ** Action : + !! + !! History : + !! ! 08-02 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! + !! * Arguments + INTEGER, INTENT(IN) :: kptsi ! Number of i horizontal points per stencil + INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil + INTEGER, INTENT(IN) :: kobs ! Local number of observations + INTEGER, INTENT(IN) :: kpi ! Number of model grid points in i direction + INTEGER, INTENT(IN) :: kpj ! Number of model grid points in j direction + INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kgrdi, & ! i,j indicies for each stencil + & kgrdj + INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kproc ! Precomputed processor for each i,j,iobs points + REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) ::& + & pval ! Local 3D array to extra data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point + !! * Local declarations + REAL(KIND=wp), DIMENSION(jpi,jpj,1) :: zval + REAL(KIND=wp), DIMENSION(kptsi,kptsj,1,kobs) ::& + & zgval + + ! Set up local "3D" buffer + + zval(:,:,1) = pval(:,:) + + ! Call the 3D version + + IF (PRESENT(kproc)) THEN + + CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, & + & zgval, kproc=kproc ) + ELSE + + CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, & + & zgval ) + + ENDIF + + ! Copy "3D" data back to 2D + + pgval(:,:,:) = zgval(:,:,1,:) + + END SUBROUTINE obs_int_comm_2d + + SUBROUTINE obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & + & pval, pgval, kproc ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_int_comm_3d_global *** + !! + !! ** Purpose : Get 3D interpolation stencil (global version) + !! + !! ** Method : On-demand communication where each processor send its + !! list of (i,j) of points to all processors and receive + !! the corresponding values + !! + !! ** Action : + !! + !! History : + !! ! 08-02 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN) :: kptsi ! Number of i horizontal points per stencil + INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil + INTEGER, INTENT(IN) :: kobs ! Local number of observations + INTEGER, INTENT(IN) :: kpi ! Number of model points in i direction + INTEGER, INTENT(IN) :: kpj ! Number of model points in j direction + INTEGER, INTENT(IN) :: kpk ! Number of levels + INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kgrdi, & ! i,j indicies for each stencil + & kgrdj + INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kproc ! Precomputed processor for each i,j,iobs points + REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& + & pval ! Local 3D array to extract data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point + !! * Local declarations + REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: & + & zsend, & + & zrecv + INTEGER, DIMENSION(:), ALLOCATABLE :: & + & igrdij_send, & + & igrdij_recv + INTEGER, DIMENSION(kptsi,kptsj,kobs) :: & + & iorder, & + & iproc + INTEGER :: nplocal(jpnij) + INTEGER :: npglobal(jpnij) + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jp + INTEGER :: jobs + INTEGER :: it + INTEGER :: itot + INTEGER :: ii + INTEGER :: ij + + ! Check valid points + + IF ( ( MAXVAL(kgrdi) > jpiglo ) .OR. ( MINVAL(kgrdi) < 1 ) .OR. & + & ( MAXVAL(kgrdj) > jpjglo ) .OR. ( MINVAL(kgrdj) < 1 ) ) THEN + + CALL ctl_stop( 'Error in obs_int_comm_3d_global', & + & 'Point outside global domain' ) + + ENDIF + + ! Count number of points on each processors + + nplocal(:) = 0 + IF (PRESENT(kproc)) THEN + iproc(:,:,:) = kproc(:,:,:) + DO jobs = 1, kobs + DO jj = 1, kptsj + DO ji = 1, kptsi + nplocal(iproc(ji,jj,jobs)) = nplocal(iproc(ji,jj,jobs)) + 1 + END DO + END DO + END DO + ELSE + DO jobs = 1, kobs + DO jj = 1, kptsj + DO ji = 1, kptsi + iproc(ji,jj,jobs) = mppmap(kgrdi(ji,jj,jobs),& + & kgrdj(ji,jj,jobs)) + nplocal(iproc(ji,jj,jobs)) = nplocal(iproc(ji,jj,jobs)) + 1 + END DO + END DO + END DO + ENDIF + + ! Send local number of points and receive points on current domain + + CALL mpp_alltoall_int( 1, nplocal, npglobal ) + + ! Allocate message parsing workspace + + itot = SUM(npglobal) + + ALLOCATE( & + & igrdij_send(kptsi*kptsj*kobs*2), & + & igrdij_recv(itot*2), & + & zsend(kpk,itot), & + & zrecv(kpk,kptsi*kptsj*kobs) & + & ) + + ! Pack buffers for list of points + + it = 0 + DO jp = 1, jpnij + DO jobs = 1, kobs + DO jj = 1, kptsj + DO ji = 1, kptsi + IF ( iproc(ji,jj,jobs) == jp ) THEN + it = it + 1 + iorder(ji,jj,jobs) = it + igrdij_send(2*it-1) = kgrdi(ji,jj,jobs) + igrdij_send(2*it ) = kgrdj(ji,jj,jobs) + ENDIF + END DO + END DO + END DO + END DO + + ! Send and recieve buffers for list of points + + CALL mpp_alltoallv_int( igrdij_send, kptsi*kptsj*kobs*2, nplocal(:)*2, & + & igrdij_recv, itot*2, npglobal(:)*2 ) + + ! Pack interpolation data to be sent + + DO ji = 1, itot + ii = mi1(igrdij_recv(2*ji-1)) + ij = mj1(igrdij_recv(2*ji)) + DO jk = 1, kpk + zsend(jk,ji) = pval(ii,ij,jk) + END DO + END DO + + ! Re-adjust sizes + + nplocal(:) = kpk*nplocal(:) + npglobal(:) = kpk*npglobal(:) + + + ! Send and receive data for interpolation stencil + + CALL mpp_alltoallv_real( zsend, kpk*itot, npglobal, & + & zrecv, kpk*kptsi*kptsj*kobs, nplocal ) + + ! Copy the received data into output data structure + + DO jobs = 1, kobs + DO jj = 1, kptsj + DO ji = 1, kptsi + it = iorder(ji,jj,jobs) + DO jk = 1, kpk + pgval(ji,jj,jk,jobs) = zrecv(jk,it) + END DO + END DO + END DO + END DO + + ! Deallocate message parsing workspace + + DEALLOCATE( & + & igrdij_send, & + & igrdij_recv, & + & zsend, & + & zrecv & + & ) + + END SUBROUTINE obs_int_comm_3d_global + + SUBROUTINE obs_int_comm_3d_local( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & + & pval, pgval ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_int_comm_3d_global *** + !! + !! ** Purpose : Get 3D interpolation stencil (global version) + !! + !! ** Method : On-demand communication where each processor send its + !! list of (i,j) of points to all processors and receive + !! the corresponding values + !! + !! ** Action : + !! + !! History : + !! ! 08-02 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN) :: kptsi ! Number of i horizontal points per stencil + INTEGER, INTENT(IN) :: kptsj ! Number of j horizontal points per stencil + INTEGER, INTENT(IN) :: kobs ! Local number of observations + INTEGER, INTENT(IN) :: kpi ! Number of model points in i direction + INTEGER, INTENT(IN) :: kpj ! Number of model points in j direction + INTEGER, INTENT(IN) :: kpk ! Number of levels + INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & + & kgrdi, & ! i,j indicies for each stencil + & kgrdj + REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& + & pval ! Local 3D array to extract data from + REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& + & pgval ! Stencil at each point + !! * Local declarations + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jobs + + ! Check valid points + + IF ( ( MAXVAL(kgrdi) > jpi ) .OR. ( MINVAL(kgrdi) < 1 ) .OR. & + & ( MAXVAL(kgrdj) > jpj ) .OR. ( MINVAL(kgrdj) < 1 ) ) THEN + + CALL ctl_stop( 'Error in obs_int_comm_3d_local', & + & 'Point outside local domain' ) + + ENDIF + + ! Copy local data + + DO jobs = 1, kobs + DO jj = 1, kptsj + DO ji = 1, kptsi + DO jk = 1, kpk + pgval(ji,jj,jk,jobs) = & + & pval(kgrdi(ji,jj,jobs),kgrdj(ji,jj,jobs),jk) + END DO + END DO + END DO + END DO + + END SUBROUTINE obs_int_comm_3d_local + +END MODULE obs_inter_sup \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_inter_z1d.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_inter_z1d.F90 new file mode 100644 index 0000000..a3f6485 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_inter_z1d.F90 @@ -0,0 +1,35 @@ +MODULE obs_inter_z1d + !!====================================================================== + !! *** MODULE obs_inter_z1d *** + !! Observation diagnostics: Perform the vertical interpolation + !! from model grid to observation location + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_int_z1d : Vertical interpolation to the observation point + !! obs_int_z1d_spl : Compute the vertical 2nd derivative of the + !! interpolating function for a cubic spline (n1dint=1) + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_int_z1d, & ! Vertical interpolation to the observation pt. + & obs_int_z1d_spl ! Compute the vertical 2nd derivative of the + ! interpolating function used with a cubic spline + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_inter_z1d.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "obsinter_z1d.h90" + +END MODULE obs_inter_z1d \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_level_search.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_level_search.h90 new file mode 100644 index 0000000..b79c1a4 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_level_search.h90 @@ -0,0 +1,51 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_level_search.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE obs_level_search( kgrd, pgrddep, kobs, pobsdep, kobsk ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_level_search *** + !! + !! ** Purpose : Search levels to find matching level to observed depth + !! + !! ** Method : Straightforward search + !! + !! ** Action : + !! + !! History : + !! ! 2001-11 (N. Daget, A. Weaver) + !! ! 2006-03 (A. Weaver) NEMOVAR migration. + !! ! 2006-05 (K. Mogensen) Moved to to separate routine. + !! ! 2006-10 (A. Weaver) Cleanup + !! ! 2008-10 (K. Mogensen) Remove assumptions on grid. + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kgrd ! Number of gridpoints + REAL(KIND=wp), DIMENSION(kgrd), INTENT(INOUT) :: & + & pgrddep ! Depths of gridpoints + INTEGER, INTENT(IN) :: & + & kobs ! Number of observations + REAL(KIND=wp), DIMENSION(kobs), INTENT(INOUT) :: & + & pobsdep ! Depths of observations + INTEGER ,DIMENSION(kobs), INTENT(OUT) :: & + & kobsk ! Level indices of observations + + !! * Local declarations + INTEGER :: ji + INTEGER :: jk + + !------------------------------------------------------------------------ + ! Search levels for each observations to find matching level + !------------------------------------------------------------------------ + DO ji = 1, kobs + kobsk(ji) = 1 + depk: DO jk = 2, kgrd + IF ( pgrddep(jk) >= pobsdep(ji) ) EXIT depk + END DO depk + kobsk(ji) = jk + END DO + + END SUBROUTINE obs_level_search \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_mpp.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_mpp.F90 new file mode 100644 index 0000000..dda28e1 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_mpp.F90 @@ -0,0 +1,444 @@ +MODULE obs_mpp + !!====================================================================== + !! *** MODULE obs_mpp *** + !! Observation diagnostics: Various MPP support routines + !!====================================================================== + !! History : 2.0 ! 2006-03 (K. Mogensen) Original code + !! - ! 2006-05 (K. Mogensen) Reformatted + !! - ! 2008-01 (K. Mogensen) add mpp_global_max + !! 3.6 ! 2015-01 (J. Waters) obs_mpp_find_obs_proc + !! rewritten to avoid global arrays + !!---------------------------------------------------------------------- +# define mpivar mpi_double_precision + !!---------------------------------------------------------------------- + !! obs_mpp_bcast_integer : Broadcast an integer array from a processor to all processors + !! obs_mpp_max_integer : Find maximum on all processors of each value in an integer on all processors + !! obs_mpp_find_obs_proc : Find processors which should hold the observations, avoiding global arrays + !! obs_mpp_sum_integers : Sum an integer array from all processors + !! obs_mpp_sum_integer : Sum an integer from all processors + !!---------------------------------------------------------------------- + USE mpp_map, ONLY : mppmap + USE in_out_manager +#if ! defined key_mpi_off + USE lib_mpp, ONLY : mpi_comm_oce ! MPP library +#endif + IMPLICIT NONE + PRIVATE + + PUBLIC obs_mpp_bcast_integer, & !: Broadcast an integer array from a proc to all procs + & obs_mpp_max_integer, & !: Find maximum across processors in an integer array + & obs_mpp_find_obs_proc, & !: Find processors which should hold the observations + & obs_mpp_sum_integers, & !: Sum an integer array from all processors + & obs_mpp_sum_integer, & !: Sum an integer from all processors + & mpp_alltoall_int, & + & mpp_alltoallv_int, & + & mpp_alltoallv_real, & + & mpp_global_max + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_mpp.F90 14275 2021-01-07 12:13:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE obs_mpp_bcast_integer( kvals, kno, kroot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_mpp_bcast_integer *** + !! + !! ** Purpose : Send array kvals to all processors + !! + !! ** Method : MPI broadcast + !! + !! ** Action : This does only work for MPI. + !! MPI_COMM_OCE needs to be replace for OASIS4.! + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kno ! Number of elements in array + INTEGER , INTENT(in ) :: kroot ! Processor to send data + INTEGER, DIMENSION(kno), INTENT(inout) :: kvals ! Array to send on kroot, receive for non-kroot + ! +#if ! defined key_mpi_off + ! + INTEGER :: ierr + ! +INCLUDE 'mpif.h' + !!---------------------------------------------------------------------- + + ! Call the MPI library to broadcast data + CALL mpi_bcast( kvals, kno, mpi_integer, & + & kroot, mpi_comm_oce, ierr ) +#else + ! no MPI: empty routine +#endif + ! + END SUBROUTINE obs_mpp_bcast_integer + + + SUBROUTINE obs_mpp_max_integer( kvals, kno ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_mpp_bcast_integer *** + !! + !! ** Purpose : Find maximum across processors in an integer array. + !! + !! ** Method : MPI all reduce. + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! MPI_COMM_OCE needs to be replace for OASIS4.! + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kno ! Number of elements in array + INTEGER, DIMENSION(kno), INTENT(inout) :: kvals ! Array to send on kroot, receive for non-kroot + ! +#if ! defined key_mpi_off + ! + INTEGER :: ierr + INTEGER, DIMENSION(kno) :: ivals + ! +INCLUDE 'mpif.h' + !!---------------------------------------------------------------------- + + ! Call the MPI library to find the maximum across processors + CALL mpi_allreduce( kvals, ivals, kno, mpi_integer, & + & mpi_max, mpi_comm_oce, ierr ) + kvals(:) = ivals(:) +#else + ! no MPI: empty routine +#endif + END SUBROUTINE obs_mpp_max_integer + + + SUBROUTINE obs_mpp_find_obs_proc( kobsp,kno ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_mpp_find_obs_proc *** + !! + !! ** Purpose : From the array kobsp containing the results of the + !! grid search on each processor the processor return a + !! decision of which processors should hold the observation. + !! + !! ** Method : Synchronize the processor number for each obs using + !! obs_mpp_max_integer. If an observation exists on two + !! processors it will be allocated to the lower numbered + !! processor. + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kno + INTEGER, DIMENSION(kno), INTENT(inout) :: kobsp + ! +#if ! defined key_mpi_off + ! + ! + INTEGER :: ji, isum + INTEGER, DIMENSION(kno) :: iobsp + !! + !! + + iobsp(:)=kobsp(:) + + WHERE( iobsp(:) == -1 ) + iobsp(:) = 9999999 + END WHERE + + iobsp(:)=-1*iobsp(:) + + CALL obs_mpp_max_integer( iobsp, kno ) + + kobsp(:)=-1*iobsp(:) + + isum=0 + DO ji = 1, kno + IF ( kobsp(ji) == 9999999 ) THEN + isum=isum+1 + kobsp(ji)=-1 + ENDIF + ENDDO + + + IF ( isum > 0 ) THEN + IF (lwp) WRITE(numout,*) isum, ' observations failed the grid search.' + IF (lwp) WRITE(numout,*)'If ln_grid_search_lookup=.TRUE., try reducing grid_search_res' + ENDIF + +#else + ! no MPI: empty routine +#endif + + END SUBROUTINE obs_mpp_find_obs_proc + + + SUBROUTINE obs_mpp_sum_integers( kvalsin, kvalsout, kno ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_mpp_sum_integers *** + !! + !! ** Purpose : Sum an integer array. + !! + !! ** Method : MPI all reduce. + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kno + INTEGER, DIMENSION(kno), INTENT(in ) :: kvalsin + INTEGER, DIMENSION(kno), INTENT( out) :: kvalsout + ! +#if ! defined key_mpi_off + ! + INTEGER :: ierr + ! +INCLUDE 'mpif.h' + !!---------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- + ! Call the MPI library to find the sum across processors + !----------------------------------------------------------------------- + CALL mpi_allreduce( kvalsin, kvalsout, kno, mpi_integer, & + & mpi_sum, mpi_comm_oce, ierr ) +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- + kvalsout(:) = kvalsin(:) +#endif + ! + END SUBROUTINE obs_mpp_sum_integers + + + SUBROUTINE obs_mpp_sum_integer( kvalin, kvalout ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_mpp_sum_integers *** + !! + !! ** Purpose : Sum a single integer + !! + !! ** Method : MPI all reduce. + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kvalin + INTEGER, INTENT( out) :: kvalout + ! +#if ! defined key_mpi_off + ! + INTEGER :: ierr + ! +INCLUDE 'mpif.h' + !!---------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- + ! Call the MPI library to find the sum across processors + !----------------------------------------------------------------------- + CALL mpi_allreduce( kvalin, kvalout, 1, mpi_integer, & + & mpi_sum, mpi_comm_oce, ierr ) +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- + kvalout = kvalin +#endif + ! + END SUBROUTINE obs_mpp_sum_integer + + + SUBROUTINE mpp_global_max( pval ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_global_or *** + !! + !! ** Purpose : Get the maximum value across processors for a global + !! real array + !! + !! ** Method : MPI allreduce + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + REAL(KIND=wp), DIMENSION(jpiglo,jpjglo), INTENT(inout) :: pval + ! + INTEGER :: ierr + ! +#if ! defined key_mpi_off + ! +INCLUDE 'mpif.h' + REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: zcp + !!---------------------------------------------------------------------- + + ! Copy data for input to MPI + + ALLOCATE( & + & zcp(jpiglo,jpjglo) & + & ) + zcp(:,:) = pval(:,:) + + ! Call the MPI library to find the coast lines globally + + CALL mpi_allreduce( zcp, pval, jpiglo*jpjglo, mpivar, & + & mpi_max, mpi_comm_oce, ierr ) + + DEALLOCATE( & + & zcp & + & ) + +#else + ! no MPI: empty routine +#endif + ! + END SUBROUTINE mpp_global_max + + + SUBROUTINE mpp_alltoall_int( kno, kvalsin, kvalsout ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_allgatherv *** + !! + !! ** Purpose : all to all. + !! + !! ** Method : MPI alltoall + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kno + INTEGER, DIMENSION(kno*jpnij), INTENT(in ) :: kvalsin + INTEGER, DIMENSION(kno*jpnij), INTENT( out) :: kvalsout + !! + INTEGER :: ierr + ! +#if ! defined key_mpi_off + ! +INCLUDE 'mpif.h' + !----------------------------------------------------------------------- + ! Call the MPI library to do the all to all operation of the data + !----------------------------------------------------------------------- + CALL mpi_alltoall( kvalsin, kno, mpi_integer, & + & kvalsout, kno, mpi_integer, & + & mpi_comm_oce, ierr ) +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- + kvalsout = kvalsin +#endif + ! + END SUBROUTINE mpp_alltoall_int + + + SUBROUTINE mpp_alltoallv_int( kvalsin, knoin , kinv , kvalsout, & + & knoout, koutv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_alltoallv_int *** + !! + !! ** Purpose : all to all (integer version). + !! + !! ** Method : MPI alltoall + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: knoin + INTEGER , INTENT(in) :: knoout + INTEGER, DIMENSION(jpnij), INTENT(IN) :: kinv, koutv + INTEGER, DIMENSION(knoin) , INTENT(in ) :: kvalsin + INTEGER, DIMENSION(knoout), INTENT( out) :: kvalsout + !! + INTEGER :: ierr + INTEGER :: jproc + ! +#if ! defined key_mpi_off + ! +INCLUDE 'mpif.h' + INTEGER, DIMENSION(jpnij) :: irdsp, isdsp + !----------------------------------------------------------------------- + ! Compute displacements + !----------------------------------------------------------------------- + irdsp(1) = 0 + isdsp(1) = 0 + DO jproc = 2, jpnij + isdsp(jproc) = isdsp(jproc-1) + kinv(jproc-1) + irdsp(jproc) = irdsp(jproc-1) + koutv(jproc-1) + END DO + !----------------------------------------------------------------------- + ! Call the MPI library to do the all to all operation of the data + !----------------------------------------------------------------------- + CALL mpi_alltoallv( kvalsin, kinv, isdsp, mpi_integer, & + & kvalsout, koutv, irdsp, mpi_integer, & + & mpi_comm_oce, ierr ) +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- + kvalsout = kvalsin +#endif + ! + END SUBROUTINE mpp_alltoallv_int + + + SUBROUTINE mpp_alltoallv_real( pvalsin, knoin , kinv , pvalsout, & + & knoout, koutv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_alltoallv_real *** + !! + !! ** Purpose : all to all (integer version). + !! + !! ** Method : MPI alltoall + !! + !! ** Action : This does only work for MPI. + !! It does not work for SHMEM. + !! + !! References : http://www.mpi-forum.org + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: knoin + INTEGER , INTENT(in ) :: knoout + INTEGER , DIMENSION(jpnij) :: kinv, koutv + REAL(wp), DIMENSION(knoin) , INTENT(in ) :: pvalsin + REAL(wp), DIMENSION(knoout), INTENT( out) :: pvalsout + !! + INTEGER :: ierr + INTEGER :: jproc + ! +#if ! defined key_mpi_off + ! +INCLUDE 'mpif.h' + INTEGER, DIMENSION(jpnij) :: irdsp, isdsp + !!---------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- + ! Compute displacements + !----------------------------------------------------------------------- + irdsp(1) = 0 + isdsp(1) = 0 + DO jproc = 2, jpnij + isdsp(jproc) = isdsp(jproc-1) + kinv(jproc-1) + irdsp(jproc) = irdsp(jproc-1) + koutv(jproc-1) + END DO + !----------------------------------------------------------------------- + ! Call the MPI library to do the all to all operation of the data + !----------------------------------------------------------------------- + CALL mpi_alltoallv( pvalsin, kinv, isdsp, mpivar, & + & pvalsout, koutv, irdsp, mpivar, & + & mpi_comm_oce, ierr ) +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- + pvalsout = pvalsin +#endif + ! + END SUBROUTINE mpp_alltoallv_real + + !!====================================================================== +END MODULE obs_mpp \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_oper.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_oper.F90 new file mode 100644 index 0000000..aeb0ae1 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_oper.F90 @@ -0,0 +1,780 @@ +MODULE obs_oper + !!====================================================================== + !! *** MODULE obs_oper *** + !! Observation diagnostics: Observation operators for various observation + !! types + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_prof_opt : Compute the model counterpart of profile data + !! obs_surf_opt : Compute the model counterpart of surface data + !!---------------------------------------------------------------------- + USE obs_inter_sup ! Interpolation support + USE obs_inter_h2d, ONLY : obs_int_h2d, obs_int_h2d_init ! Horizontal interpolation to the obs pt + USE obs_averg_h2d, ONLY : obs_avg_h2d, obs_avg_h2d_init, obs_max_fpsize ! Horizontal averaging to the obs footprint + USE obs_inter_z1d, ONLY : obs_int_z1d, obs_int_z1d_spl ! Vertical interpolation to the obs pt + USE obs_const , ONLY : obfillflt ! Obs fill value + USE dom_oce, ONLY : glamt, glamf, gphit, gphif ! lat/lon of ocean grid-points + USE lib_mpp, ONLY : ctl_warn, ctl_stop ! Warning and stopping routines + USE sbcdcy, ONLY : sbc_dcy, nday_qsr ! For calculation of where it is night-time + USE obs_grid, ONLY : obs_level_search + ! + USE par_kind , ONLY : wp ! Precision variables + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC obs_prof_opt !: Compute the model counterpart of profile obs + PUBLIC obs_surf_opt !: Compute the model counterpart of surface obs + + INTEGER, PARAMETER, PUBLIC :: imaxavtypes = 20 !: Max number of daily avgd obs types + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_oper.F90 14056 2020-12-03 14:08:29Z ayoung $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, & + & kit000, kdaystp, kvar, & + & pvar, pgdept, pgdepw, & + & pmask, & + & plam, pphi, & + & k1dint, k2dint, kdailyavtypes ) + !!----------------------------------------------------------------------- + !! *** ROUTINE obs_pro_opt *** + !! + !! ** Purpose : Compute the model counterpart of profiles + !! data by interpolating from the model grid to the + !! observation point. + !! + !! ** Method : Linearly interpolate to each observation point using + !! the model values at the corners of the surrounding grid box. + !! + !! First, a vertical profile of horizontally interpolated model + !! now values is computed at the obs (lon, lat) point. + !! Several horizontal interpolation schemes are available: + !! - distance-weighted (great circle) (k2dint = 0) + !! - distance-weighted (small angle) (k2dint = 1) + !! - bilinear (geographical grid) (k2dint = 2) + !! - bilinear (quadrilateral grid) (k2dint = 3) + !! - polynomial (quadrilateral grid) (k2dint = 4) + !! + !! Next, the vertical profile is interpolated to the + !! data depth points. Two vertical interpolation schemes are + !! available: + !! - linear (k1dint = 0) + !! - Cubic spline (k1dint = 1) + !! + !! For the cubic spline the 2nd derivative of the interpolating + !! polynomial is computed before entering the vertical interpolation + !! routine. + !! + !! If the logical is switched on, the model equivalent is + !! a daily mean model temperature field. So, we first compute + !! the mean, then interpolate only at the end of the day. + !! + !! Note: in situ temperature observations must be converted + !! to potential temperature (the model variable) prior to + !! assimilation. + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, S. Ricci, N. Daget) + !! ! 06-03 (G. Smith) NEMOVAR migration + !! ! 06-10 (A. Weaver) Cleanup + !! ! 07-01 (K. Mogensen) Merge of temperature and salinity + !! ! 07-03 (K. Mogensen) General handling of profiles + !! ! 15-02 (M. Martin) Combined routine for all profile types + !! ! 17-02 (M. Martin) Include generalised vertical coordinate changes + !!----------------------------------------------------------------------- + USE obs_profiles_def ! Definition of storage space for profile obs. + + IMPLICIT NONE + + TYPE(obs_prof), INTENT(inout) :: prodatqc ! Subset of profile data passing QC + INTEGER , INTENT(in ) :: kt ! Time step + INTEGER , INTENT(in ) :: kpi, kpj, kpk ! Model grid parameters + INTEGER , INTENT(in ) :: kit000 ! Number of the first time step (kit000-1 = restart time) + INTEGER , INTENT(in ) :: k1dint ! Vertical interpolation type (see header) + INTEGER , INTENT(in ) :: k2dint ! Horizontal interpolation type (see header) + INTEGER , INTENT(in ) :: kdaystp ! Number of time steps per day + INTEGER , INTENT(in ) :: kvar ! Number of variables in prodatqc + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pvar ! Model field + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pmask ! Land-sea mask + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: plam ! Model longitude + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: pphi ! Model latitudes + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pgdept, pgdepw ! depth of T and W levels + INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: kdailyavtypes ! Types for daily averages + + !! * Local declarations + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jobs + INTEGER :: inrc + INTEGER :: ipro + INTEGER :: idayend + INTEGER :: ista + INTEGER :: iend + INTEGER :: iobs + INTEGER :: iin, ijn, ikn, ik ! looping indices over interpolation nodes + INTEGER :: inum_obs + INTEGER, DIMENSION(imaxavtypes) :: & + & idailyavtypes + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & + & igrdi, & + & igrdj + INTEGER, ALLOCATABLE, DIMENSION(:) :: iv_indic + + REAL(KIND=wp) :: zlam + REAL(KIND=wp) :: zphi + REAL(KIND=wp) :: zdaystp + REAL(KIND=wp), DIMENSION(kpk) :: & + & zobsk, & + & zobs2k + REAL(KIND=wp), DIMENSION(2,2,1) :: & + & zweig1, & + & zweig + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & + & zmask, & + & zint, & + & zinm, & + & zgdept, & + & zgdepw + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zglam, & + & zgphi + REAL(KIND=wp), DIMENSION(1) :: zmsk + REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner + + LOGICAL :: ld_dailyav + + !------------------------------------------------------------------------ + ! Local initialization + !------------------------------------------------------------------------ + ! Record and data counters + inrc = kt - kit000 + 2 + ipro = prodatqc%npstp(inrc) + + ! Daily average types + ld_dailyav = .FALSE. + IF ( PRESENT(kdailyavtypes) ) THEN + idailyavtypes(:) = kdailyavtypes(:) + IF ( ANY (idailyavtypes(:) /= -1) ) ld_dailyav = .TRUE. + ELSE + idailyavtypes(:) = -1 + ENDIF + + ! Daily means are calculated for values over timesteps: + ! [1 <= kt <= kdaystp], [kdaystp+1 <= kt <= 2*kdaystp], ... + idayend = MOD( kt - kit000 + 1, kdaystp ) + + IF ( ld_dailyav ) THEN + + ! Initialize daily mean for first timestep of the day + IF ( idayend == 1 .OR. kt == 0 ) THEN + DO_3D( 1, 1, 1, 1, 1, jpk ) + prodatqc%vdmean(ji,jj,jk,kvar) = 0.0 + END_3D + ENDIF + + DO_3D( 1, 1, 1, 1, 1, jpk ) + ! Increment field 1 for computing daily mean + prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & + & + pvar(ji,jj,jk) + END_3D + + ! Compute the daily mean at the end of day + zdaystp = 1.0 / REAL( kdaystp ) + IF ( idayend == 0 ) THEN + IF (lwp) WRITE(numout,*) 'Calculating prodatqc%vdmean on time-step: ',kt + CALL FLUSH(numout) + DO_3D( 1, 1, 1, 1, 1, jpk ) + prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & + & * zdaystp + END_3D + ENDIF + + ENDIF + + ! Get the data for interpolation + ALLOCATE( & + & igrdi(2,2,ipro), & + & igrdj(2,2,ipro), & + & zglam(2,2,ipro), & + & zgphi(2,2,ipro), & + & zmask(2,2,kpk,ipro), & + & zint(2,2,kpk,ipro), & + & zgdept(2,2,kpk,ipro), & + & zgdepw(2,2,kpk,ipro) & + & ) + + DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro + iobs = jobs - prodatqc%nprofup + igrdi(1,1,iobs) = prodatqc%mi(jobs,kvar)-1 + igrdj(1,1,iobs) = prodatqc%mj(jobs,kvar)-1 + igrdi(1,2,iobs) = prodatqc%mi(jobs,kvar)-1 + igrdj(1,2,iobs) = prodatqc%mj(jobs,kvar) + igrdi(2,1,iobs) = prodatqc%mi(jobs,kvar) + igrdj(2,1,iobs) = prodatqc%mj(jobs,kvar)-1 + igrdi(2,2,iobs) = prodatqc%mi(jobs,kvar) + igrdj(2,2,iobs) = prodatqc%mj(jobs,kvar) + END DO + + ! Initialise depth arrays + zgdept(:,:,:,:) = 0.0 + zgdepw(:,:,:,:) = 0.0 + + CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, plam, zglam ) + CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, pphi, zgphi ) + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pmask, zmask ) + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pvar, zint ) + + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdept, zgdept ) + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdepw, zgdepw ) + + ! At the end of the day also get interpolated means + IF ( ld_dailyav .AND. idayend == 0 ) THEN + + ALLOCATE( zinm(2,2,kpk,ipro) ) + + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, & + & prodatqc%vdmean(:,:,:,kvar), zinm ) + + ENDIF + + ! Return if no observations to process + ! Has to be done after comm commands to ensure processors + ! stay in sync + IF ( ipro == 0 ) RETURN + + DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro + + iobs = jobs - prodatqc%nprofup + + IF ( kt /= prodatqc%mstp(jobs) ) THEN + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' E R R O R : Observation', & + & ' time step is not consistent with the', & + & ' model time step' + WRITE(numout,*) ' =========' + WRITE(numout,*) + WRITE(numout,*) ' Record = ', jobs, & + & ' kt = ', kt, & + & ' mstp = ', prodatqc%mstp(jobs), & + & ' ntyp = ', prodatqc%ntyp(jobs) + ENDIF + CALL ctl_stop( 'obs_pro_opt', 'Inconsistent time' ) + ENDIF + + zlam = prodatqc%rlam(jobs) + zphi = prodatqc%rphi(jobs) + + ! Horizontal weights + ! Masked values are calculated later. + IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN + + CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & + & zglam(:,:,iobs), zgphi(:,:,iobs), & + & zmask(:,:,1,iobs), zweig1, zmsk ) + + ENDIF + + IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN + + zobsk(:) = obfillflt + + IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN + + IF ( idayend == 0 ) THEN + ! Daily averaged data + + ! vertically interpolate all 4 corners + ista = prodatqc%npvsta(jobs,kvar) + iend = prodatqc%npvend(jobs,kvar) + inum_obs = iend - ista + 1 + ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) + + DO iin=1,2 + DO ijn=1,2 + + IF ( k1dint == 1 ) THEN + CALL obs_int_z1d_spl( kpk, & + & zinm(iin,ijn,:,iobs), & + & zobs2k, zgdept(iin,ijn,:,iobs), & + & zmask(iin,ijn,:,iobs)) + ENDIF + + CALL obs_level_search(kpk, & + & zgdept(iin,ijn,:,iobs), & + & inum_obs, prodatqc%var(kvar)%vdep(ista:iend), & + & iv_indic) + + CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & + & prodatqc%var(kvar)%vdep(ista:iend), & + & zinm(iin,ijn,:,iobs), & + & zobs2k, interp_corner(iin,ijn,:), & + & zgdept(iin,ijn,:,iobs), & + & zmask(iin,ijn,:,iobs)) + + ENDDO + ENDDO + + ENDIF !idayend + + ELSE + + ! Point data + + ! vertically interpolate all 4 corners + ista = prodatqc%npvsta(jobs,kvar) + iend = prodatqc%npvend(jobs,kvar) + inum_obs = iend - ista + 1 + ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) + DO iin=1,2 + DO ijn=1,2 + + IF ( k1dint == 1 ) THEN + CALL obs_int_z1d_spl( kpk, & + & zint(iin,ijn,:,iobs),& + & zobs2k, zgdept(iin,ijn,:,iobs), & + & zmask(iin,ijn,:,iobs)) + + ENDIF + + CALL obs_level_search(kpk, & + & zgdept(iin,ijn,:,iobs),& + & inum_obs, prodatqc%var(kvar)%vdep(ista:iend), & + & iv_indic) + + CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & + & prodatqc%var(kvar)%vdep(ista:iend), & + & zint(iin,ijn,:,iobs), & + & zobs2k,interp_corner(iin,ijn,:), & + & zgdept(iin,ijn,:,iobs), & + & zmask(iin,ijn,:,iobs) ) + + ENDDO + ENDDO + + ENDIF + + !------------------------------------------------------------- + ! Compute the horizontal interpolation for every profile level + !------------------------------------------------------------- + + DO ikn=1,inum_obs + iend=ista+ikn-1 + + zweig(:,:,1) = 0._wp + + ! This code forces the horizontal weights to be + ! zero IF the observation is below the bottom of the + ! corners of the interpolation nodes, Or if it is in + ! the mask. This is important for observations near + ! steep bathymetry + DO iin=1,2 + DO ijn=1,2 + + depth_loop: DO ik=kpk,2,-1 + IF(zmask(iin,ijn,ik-1,iobs ) > 0.9 )THEN + + zweig(iin,ijn,1) = & + & zweig1(iin,ijn,1) * & + & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & + & - prodatqc%var(kvar)%vdep(iend)),0._wp) + + EXIT depth_loop + + ENDIF + + ENDDO depth_loop + + ENDDO + ENDDO + + CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & + & prodatqc%var(kvar)%vmod(iend:iend) ) + + ! Set QC flag for any observations found below the bottom + ! needed as the check here is more strict than that in obs_prep + IF (sum(zweig) == 0.0_wp) prodatqc%var(kvar)%nvqc(iend:iend)=4 + + ENDDO + + DEALLOCATE(interp_corner,iv_indic) + + ENDIF + + ENDDO + + ! Deallocate the data for interpolation + DEALLOCATE( & + & igrdi, & + & igrdj, & + & zglam, & + & zgphi, & + & zmask, & + & zint, & + & zgdept, & + & zgdepw & + & ) + + ! At the end of the day also get interpolated means + IF ( ld_dailyav .AND. idayend == 0 ) THEN + DEALLOCATE( zinm ) + ENDIF + + IF ( kvar == prodatqc%nvar ) THEN + prodatqc%nprofup = prodatqc%nprofup + ipro + ENDIF + + END SUBROUTINE obs_prof_opt + + SUBROUTINE obs_surf_opt( surfdataqc, kt, kpi, kpj, & + & kit000, kdaystp, psurf, psurfmask, & + & k2dint, ldnightav, plamscl, pphiscl, & + & lindegrees ) + + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_surf_opt *** + !! + !! ** Purpose : Compute the model counterpart of surface + !! data by interpolating from the model grid to the + !! observation point. + !! + !! ** Method : Linearly interpolate to each observation point using + !! the model values at the corners of the surrounding grid box. + !! + !! The new model value is first computed at the obs (lon, lat) point. + !! + !! Several horizontal interpolation schemes are available: + !! - distance-weighted (great circle) (k2dint = 0) + !! - distance-weighted (small angle) (k2dint = 1) + !! - bilinear (geographical grid) (k2dint = 2) + !! - bilinear (quadrilateral grid) (k2dint = 3) + !! - polynomial (quadrilateral grid) (k2dint = 4) + !! + !! Two horizontal averaging schemes are also available: + !! - weighted radial footprint (k2dint = 5) + !! - weighted rectangular footprint (k2dint = 6) + !! + !! + !! ** Action : + !! + !! History : + !! ! 07-03 (A. Weaver) + !! ! 15-02 (M. Martin) Combined routine for surface types + !! ! 17-03 (M. Martin) Added horizontal averaging options + !!----------------------------------------------------------------------- + USE obs_surf_def ! Definition of storage space for surface observations + + IMPLICIT NONE + + TYPE(obs_surf), INTENT(INOUT) :: & + & surfdataqc ! Subset of surface data passing QC + INTEGER, INTENT(IN) :: kt ! Time step + INTEGER, INTENT(IN) :: kpi ! Model grid parameters + INTEGER, INTENT(IN) :: kpj + INTEGER, INTENT(IN) :: kit000 ! Number of the first time step + ! (kit000-1 = restart time) + INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day + INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation type (see header) + REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & + & psurf, & ! Model surface field + & psurfmask ! Land-sea mask + LOGICAL, INTENT(IN) :: ldnightav ! Logical for averaging night-time data + REAL(KIND=wp), INTENT(IN) :: & + & plamscl, & ! Diameter in metres of obs footprint in E/W, N/S directions + & pphiscl ! This is the full width (rather than half-width) + LOGICAL, INTENT(IN) :: & + & lindegrees ! T=> plamscl and pphiscl are specified in degrees, F=> in metres + + !! * Local declarations + INTEGER :: ji + INTEGER :: jj + INTEGER :: jobs + INTEGER :: inrc + INTEGER :: isurf + INTEGER :: iobs + INTEGER :: imaxifp, imaxjfp + INTEGER :: imodi, imodj + INTEGER :: idayend + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & + & igrdi, & + & igrdj, & + & igrdip1, & + & igrdjp1 + INTEGER, DIMENSION(:,:), SAVE, ALLOCATABLE :: & + & icount_night, & + & imask_night + REAL(wp) :: zlam + REAL(wp) :: zphi + REAL(wp), DIMENSION(1) :: zext, zobsmask + REAL(wp) :: zdaystp + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zweig, & + & zmask, & + & zsurf, & + & zsurfm, & + & zsurftmp, & + & zglam, & + & zgphi, & + & zglamf, & + & zgphif + + REAL(wp), DIMENSION(:,:), SAVE, ALLOCATABLE :: & + & zintmp, & + & zouttmp, & + & zmeanday ! to compute model sst in region of 24h daylight (pole) + + !------------------------------------------------------------------------ + ! Local initialization + !------------------------------------------------------------------------ + ! Record and data counters + inrc = kt - kit000 + 2 + isurf = surfdataqc%nsstp(inrc) + + ! Work out the maximum footprint size for the + ! interpolation/averaging in model grid-points - has to be even. + + CALL obs_max_fpsize( k2dint, plamscl, pphiscl, lindegrees, psurfmask, imaxifp, imaxjfp ) + + + IF ( ldnightav ) THEN + + ! Initialize array for night mean + IF ( kt == 0 ) THEN + ALLOCATE ( icount_night(kpi,kpj) ) + ALLOCATE ( imask_night(kpi,kpj) ) + ALLOCATE ( zintmp(kpi,kpj) ) + ALLOCATE ( zouttmp(kpi,kpj) ) + ALLOCATE ( zmeanday(kpi,kpj) ) + nday_qsr = -1 ! initialisation flag for nbc_dcy + ENDIF + + ! Night-time means are calculated for night-time values over timesteps: + ! [1 <= kt <= kdaystp], [kdaystp+1 <= kt <= 2*kdaystp], ..... + idayend = MOD( kt - kit000 + 1, kdaystp ) + + ! Initialize night-time mean for first timestep of the day + IF ( idayend == 1 .OR. kt == 0 ) THEN + DO_2D( 1, 1, 1, 1 ) + surfdataqc%vdmean(ji,jj) = 0.0 + zmeanday(ji,jj) = 0.0 + icount_night(ji,jj) = 0 + END_2D + ENDIF + + zintmp(:,:) = 0.0 + zouttmp(:,:) = sbc_dcy( zintmp(:,:), .TRUE. ) + imask_night(:,:) = INT( zouttmp(:,:) ) + + DO_2D( 1, 1, 1, 1 ) + ! Increment the temperature field for computing night mean and counter + surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj) & + & + psurf(ji,jj) * REAL( imask_night(ji,jj) ) + zmeanday(ji,jj) = zmeanday(ji,jj) + psurf(ji,jj) + icount_night(ji,jj) = icount_night(ji,jj) + imask_night(ji,jj) + END_2D + + ! Compute the night-time mean at the end of the day + zdaystp = 1.0 / REAL( kdaystp ) + IF ( idayend == 0 ) THEN + IF (lwp) WRITE(numout,*) 'Calculating surfdataqc%vdmean on time-step: ',kt + DO_2D( 1, 1, 1, 1 ) + ! Test if "no night" point + IF ( icount_night(ji,jj) > 0 ) THEN + surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj) & + & / REAL( icount_night(ji,jj) ) + ELSE + !At locations where there is no night (e.g. poles), + ! calculate daily mean instead of night-time mean. + surfdataqc%vdmean(ji,jj) = zmeanday(ji,jj) * zdaystp + ENDIF + END_2D + ENDIF + + ENDIF + + ! Get the data for interpolation + + ALLOCATE( & + & zweig(imaxifp,imaxjfp,1), & + & igrdi(imaxifp,imaxjfp,isurf), & + & igrdj(imaxifp,imaxjfp,isurf), & + & zglam(imaxifp,imaxjfp,isurf), & + & zgphi(imaxifp,imaxjfp,isurf), & + & zmask(imaxifp,imaxjfp,isurf), & + & zsurf(imaxifp,imaxjfp,isurf), & + & zsurftmp(imaxifp,imaxjfp,isurf), & + & zglamf(imaxifp+1,imaxjfp+1,isurf), & + & zgphif(imaxifp+1,imaxjfp+1,isurf), & + & igrdip1(imaxifp+1,imaxjfp+1,isurf), & + & igrdjp1(imaxifp+1,imaxjfp+1,isurf) & + & ) + + DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf + iobs = jobs - surfdataqc%nsurfup + DO ji = 0, imaxifp + imodi = surfdataqc%mi(jobs) - int(imaxifp/2) + ji - 1 + ! + !Deal with wrap around in longitude + IF ( imodi < 1 ) imodi = imodi + jpiglo + IF ( imodi > jpiglo ) imodi = imodi - jpiglo + ! + DO jj = 0, imaxjfp + imodj = surfdataqc%mj(jobs) - int(imaxjfp/2) + jj - 1 + !If model values are out of the domain to the north/south then + !set them to be the edge of the domain + IF ( imodj < 1 ) imodj = 1 + IF ( imodj > jpjglo ) imodj = jpjglo + ! + igrdip1(ji+1,jj+1,iobs) = imodi + igrdjp1(ji+1,jj+1,iobs) = imodj + ! + IF ( ji >= 1 .AND. jj >= 1 ) THEN + igrdi(ji,jj,iobs) = imodi + igrdj(ji,jj,iobs) = imodj + ENDIF + ! + END DO + END DO + END DO + + CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & + & igrdi, igrdj, glamt, zglam ) + CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & + & igrdi, igrdj, gphit, zgphi ) + CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & + & igrdi, igrdj, psurfmask, zmask ) + CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & + & igrdi, igrdj, psurf, zsurf ) + CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, & + & igrdip1, igrdjp1, glamf, zglamf ) + CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, & + & igrdip1, igrdjp1, gphif, zgphif ) + + ! At the end of the day get interpolated means + IF ( idayend == 0 .AND. ldnightav ) THEN + + ALLOCATE( & + & zsurfm(imaxifp,imaxjfp,isurf) & + & ) + + CALL obs_int_comm_2d( imaxifp,imaxjfp, isurf, kpi, kpj, igrdi, igrdj, & + & surfdataqc%vdmean(:,:), zsurfm ) + + ENDIF + + ! Loop over observations + DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf + + iobs = jobs - surfdataqc%nsurfup + + IF ( kt /= surfdataqc%mstp(jobs) ) THEN + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' E R R O R : Observation', & + & ' time step is not consistent with the', & + & ' model time step' + WRITE(numout,*) ' =========' + WRITE(numout,*) + WRITE(numout,*) ' Record = ', jobs, & + & ' kt = ', kt, & + & ' mstp = ', surfdataqc%mstp(jobs), & + & ' ntyp = ', surfdataqc%ntyp(jobs) + ENDIF + CALL ctl_stop( 'obs_surf_opt', 'Inconsistent time' ) + + ENDIF + + zlam = surfdataqc%rlam(jobs) + zphi = surfdataqc%rphi(jobs) + + IF ( ldnightav .AND. idayend == 0 ) THEN + ! Night-time averaged data + zsurftmp(:,:,iobs) = zsurfm(:,:,iobs) + ELSE + zsurftmp(:,:,iobs) = zsurf(:,:,iobs) + ENDIF + + IF ( k2dint <= 4 ) THEN + + ! Get weights to interpolate the model value to the observation point + CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & + & zglam(:,:,iobs), zgphi(:,:,iobs), & + & zmask(:,:,iobs), zweig, zobsmask ) + + ! Interpolate the model value to the observation point + CALL obs_int_h2d( 1, 1, zweig, zsurftmp(:,:,iobs), zext ) + + ELSE + + ! Get weights to average the model SLA to the observation footprint + CALL obs_avg_h2d_init( 1, 1, imaxifp, imaxjfp, k2dint, zlam, zphi, & + & zglam(:,:,iobs), zgphi(:,:,iobs), & + & zglamf(:,:,iobs), zgphif(:,:,iobs), & + & zmask(:,:,iobs), plamscl, pphiscl, & + & lindegrees, zweig ) + + ! Average the model SST to the observation footprint + CALL obs_avg_h2d( 1, 1, imaxifp, imaxjfp, & + & zweig, zsurftmp(:,:,iobs), zext ) + + ENDIF + + IF ( TRIM(surfdataqc%cvars(1)) == 'SLA' .AND. surfdataqc%nextra == 2 ) THEN + ! ... Remove the MDT from the SSH at the observation point to get the SLA + surfdataqc%rext(jobs,1) = zext(1) + surfdataqc%rmod(jobs,1) = surfdataqc%rext(jobs,1) - surfdataqc%rext(jobs,2) + ELSE + surfdataqc%rmod(jobs,1) = zext(1) + ENDIF + + IF ( zext(1) == obfillflt ) THEN + ! If the observation value is a fill value, set QC flag to bad + surfdataqc%nqc(jobs) = 4 + ENDIF + + END DO + + ! Deallocate the data for interpolation + DEALLOCATE( & + & zweig, & + & igrdi, & + & igrdj, & + & zglam, & + & zgphi, & + & zmask, & + & zsurf, & + & zsurftmp, & + & zglamf, & + & zgphif, & + & igrdip1,& + & igrdjp1 & + & ) + + ! At the end of the day also deallocate night-time mean array + IF ( idayend == 0 .AND. ldnightav ) THEN + DEALLOCATE( & + & zsurfm & + & ) + ENDIF + ! + surfdataqc%nsurfup = surfdataqc%nsurfup + isurf + ! + END SUBROUTINE obs_surf_opt + + !!====================================================================== +END MODULE obs_oper \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_prep.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_prep.F90 new file mode 100644 index 0000000..ee2f9a9 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_prep.F90 @@ -0,0 +1,1405 @@ +MODULE obs_prep + !!===================================================================== + !! *** MODULE obs_prep *** + !! Observation diagnostics: Prepare observation arrays: screening, + !! sorting, coordinate search + !!===================================================================== + + !!--------------------------------------------------------------------- + !! obs_pre_prof : First level check and screening of profile observations + !! obs_pre_surf : First level check and screening of surface observations + !! obs_scr : Basic screening of the observations + !! obs_coo_tim : Compute number of time steps to the observation time + !! obs_sor : Sort the observation arrays + !!--------------------------------------------------------------------- + USE par_kind, ONLY : wp ! Precision variables + USE in_out_manager ! I/O manager + USE obs_profiles_def ! Definitions for storage arrays for profiles + USE obs_surf_def ! Definitions for storage arrays for surface data + USE obs_mpp, ONLY : & ! MPP support routines for observation diagnostics + & obs_mpp_sum_integer, & + & obs_mpp_sum_integers + USE obs_inter_sup ! Interpolation support + USE obs_oper ! Observation operators + USE lib_mpp, ONLY : ctl_warn, ctl_stop + USE bdy_oce, ONLY : & ! Boundary information + idx_bdy, nb_bdy, ln_bdy + + IMPLICIT NONE + PRIVATE + + PUBLIC obs_pre_prof ! First level check and screening of profile obs + PUBLIC obs_pre_surf ! First level check and screening of surface obs + PUBLIC calc_month_len ! Calculate the number of days in the months of a year + +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_prep.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + +CONTAINS + + SUBROUTINE obs_pre_surf( surfdata, surfdataqc, ld_nea, ld_bound_reject, & + kqc_cutoff ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_pre_sla *** + !! + !! ** Purpose : First level check and screening of surface observations + !! + !! ** Method : First level check and screening of surface observations + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 2007-03 (A. Weaver, K. Mogensen) Original + !! ! 2007-06 (K. Mogensen et al) Reject obs. near land. + !! ! 2015-02 (M. Martin) Combined routine for surface types. + !!---------------------------------------------------------------------- + !! * Modules used + USE par_oce ! Ocean parameters + USE dom_oce, ONLY : glamt, gphit, tmask ! Geographical information + !! * Arguments + TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data + TYPE(obs_surf), INTENT(INOUT) :: surfdataqc ! Subset of surface data not failing screening + LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land + LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting obs near the boundary + INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value + !! * Local declarations + INTEGER :: iqc_cutoff = 255 ! cut off for QC value + INTEGER :: iyea0 ! Initial date + INTEGER :: imon0 ! - (year, month, day, hour, minute) + INTEGER :: iday0 + INTEGER :: ihou0 + INTEGER :: imin0 + INTEGER :: icycle ! Current assimilation cycle + ! Counters for observations that + INTEGER :: iotdobs ! - outside time domain + INTEGER :: iosdsobs ! - outside space domain + INTEGER :: ilansobs ! - within a model land cell + INTEGER :: inlasobs ! - close to land + INTEGER :: igrdobs ! - fail the grid search + INTEGER :: ibdysobs ! - close to open boundary + ! Global counters for observations that + INTEGER :: iotdobsmpp ! - outside time domain + INTEGER :: iosdsobsmpp ! - outside space domain + INTEGER :: ilansobsmpp ! - within a model land cell + INTEGER :: inlasobsmpp ! - close to land + INTEGER :: igrdobsmpp ! - fail the grid search + INTEGER :: ibdysobsmpp ! - close to open boundary + LOGICAL, DIMENSION(:), ALLOCATABLE :: & + & llvalid ! SLA data selection + INTEGER :: jobs ! Obs. loop variable + INTEGER :: jstp ! Time loop variable + INTEGER :: inrc ! Time index variable + !!---------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*) 'obs_pre_surf : Preparing the surface observations...' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + + ! Initial date initialization (year, month, day, hour, minute) + iyea0 = ndate0 / 10000 + imon0 = ( ndate0 - iyea0 * 10000 ) / 100 + iday0 = ndate0 - iyea0 * 10000 - imon0 * 100 + ihou0 = nn_time0 / 100 + imin0 = ( nn_time0 - ihou0 * 100 ) + + icycle = nn_no ! Assimilation cycle + + ! Diagnotics counters for various failures. + + iotdobs = 0 + igrdobs = 0 + iosdsobs = 0 + ilansobs = 0 + inlasobs = 0 + ibdysobs = 0 + + ! Set QC cutoff to optional value if provided + IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff + + ! ----------------------------------------------------------------------- + ! Find time coordinate for surface data + ! ----------------------------------------------------------------------- + + CALL obs_coo_tim( icycle, & + & iyea0, imon0, iday0, ihou0, imin0, & + & surfdata%nsurf, surfdata%nyea, surfdata%nmon, & + & surfdata%nday, surfdata%nhou, surfdata%nmin, & + & surfdata%nqc, surfdata%mstp, iotdobs ) + + CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) + + ! ----------------------------------------------------------------------- + ! Check for surface data failing the grid search + ! ----------------------------------------------------------------------- + + CALL obs_coo_grd( surfdata%nsurf, surfdata%mi, surfdata%mj, & + & surfdata%nqc, igrdobs ) + + CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) + + ! ----------------------------------------------------------------------- + ! Check for land points. + ! ----------------------------------------------------------------------- + + CALL obs_coo_spc_2d( surfdata%nsurf, & + & jpi, jpj, & + & surfdata%mi, surfdata%mj, & + & surfdata%rlam, surfdata%rphi, & + & glamt, gphit, & + & tmask(:,:,1), surfdata%nqc, & + & iosdsobs, ilansobs, & + & inlasobs, ld_nea, & + & ibdysobs, ld_bound_reject, & + & iqc_cutoff ) + + CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) + CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) + CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) + CALL obs_mpp_sum_integer( ibdysobs, ibdysobsmpp ) + + ! ----------------------------------------------------------------------- + ! Copy useful data from the surfdata data structure to + ! the surfdataqc data structure + ! ----------------------------------------------------------------------- + + ! Allocate the selection arrays + + ALLOCATE( llvalid(surfdata%nsurf) ) + + ! We want all data which has qc flags <= iqc_cutoff + + llvalid(:) = ( surfdata%nqc(:) <= iqc_cutoff ) + + ! The actual copying + + CALL obs_surf_compress( surfdata, surfdataqc, .TRUE., numout, & + & lvalid=llvalid ) + + ! Dellocate the selection arrays + DEALLOCATE( llvalid ) + + ! ----------------------------------------------------------------------- + ! Print information about what observations are left after qc + ! ----------------------------------------------------------------------- + + ! Update the total observation counter array + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data outside time domain = ', & + & iotdobsmpp + WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data that failed grid search = ', & + & igrdobsmpp + WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data outside space domain = ', & + & iosdsobsmpp + WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data at land points = ', & + & ilansobsmpp + IF (ld_nea) THEN + WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (removed) = ', & + & inlasobsmpp + ELSE + WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (kept) = ', & + & inlasobsmpp + ENDIF + WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near open boundary (removed) = ', & + & ibdysobsmpp + WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data accepted = ', & + & surfdataqc%nsurfmpp + + WRITE(numout,*) + WRITE(numout,*) ' Number of observations per time step :' + WRITE(numout,*) + WRITE(numout,'(10X,A,10X,A)')'Time step',surfdataqc%cvars(1) + WRITE(numout,'(10X,A,5X,A)')'---------','-----------------' + CALL FLUSH(numout) + ENDIF + + DO jobs = 1, surfdataqc%nsurf + inrc = surfdataqc%mstp(jobs) + 2 - nit000 + surfdataqc%nsstp(inrc) = surfdataqc%nsstp(inrc) + 1 + END DO + + CALL obs_mpp_sum_integers( surfdataqc%nsstp, surfdataqc%nsstpmpp, & + & nitend - nit000 + 2 ) + + IF ( lwp ) THEN + DO jstp = nit000 - 1, nitend + inrc = jstp - nit000 + 2 + WRITE(numout,1999) jstp, surfdataqc%nsstpmpp(inrc) + CALL FLUSH(numout) + END DO + ENDIF + +1999 FORMAT(10X,I9,5X,I17) + + END SUBROUTINE obs_pre_surf + + + SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var, & + & kpi, kpj, kpk, & + & zmask, pglam, pgphi, & + & ld_nea, ld_bound_reject, Kmm, kdailyavtypes, kqc_cutoff ) + +!!---------------------------------------------------------------------- + !! *** ROUTINE obs_pre_prof *** + !! + !! ** Purpose : First level check and screening of profiles + !! + !! ** Method : First level check and screening of profiles + !! + !! History : + !! ! 2007-06 (K. Mogensen) original : T and S profile data + !! ! 2008-09 (M. Valdivieso) : TAO velocity data + !! ! 2009-01 (K. Mogensen) : New feedback stricture + !! ! 2015-02 (M. Martin) : Combined profile routine. + !! + !!---------------------------------------------------------------------- + !! * Modules used + USE par_oce ! Ocean parameters + USE dom_oce, ONLY : & ! Geographical information + & gdept_1d + + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data + TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening + LOGICAL, DIMENSION(profdata%nvar), INTENT(IN) :: & + & ld_var ! Observed variables switches + LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land + LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting observations near the boundary + INTEGER, INTENT(IN) :: kpi, kpj, kpk ! Local domain sizes + INTEGER, INTENT(IN) :: Kmm ! time-level index + INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & + & kdailyavtypes ! Types for daily averages + REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: & + & zmask + REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: & + & pglam, & + & pgphi + INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value + + !! * Local declarations + INTEGER :: iqc_cutoff = 255 ! cut off for QC value + INTEGER :: iyea0 ! Initial date + INTEGER :: imon0 ! - (year, month, day, hour, minute) + INTEGER :: iday0 + INTEGER :: ihou0 + INTEGER :: imin0 + INTEGER :: icycle ! Current assimilation cycle + ! Counters for observations that are + INTEGER :: iotdobs ! - outside time domain + INTEGER, DIMENSION(profdata%nvar) :: iosdvobs ! - outside space domain + INTEGER, DIMENSION(profdata%nvar) :: ilanvobs ! - within a model land cell + INTEGER, DIMENSION(profdata%nvar) :: inlavobs ! - close to land + INTEGER, DIMENSION(profdata%nvar) :: ibdyvobs ! - boundary + INTEGER :: igrdobs ! - fail the grid search + INTEGER :: iuvchku ! - reject UVEL if VVEL rejected + INTEGER :: iuvchkv ! - reject VVEL if UVEL rejected + ! Global counters for observations that are + INTEGER :: iotdobsmpp ! - outside time domain + INTEGER, DIMENSION(profdata%nvar) :: iosdvobsmpp ! - outside space domain + INTEGER, DIMENSION(profdata%nvar) :: ilanvobsmpp ! - within a model land cell + INTEGER, DIMENSION(profdata%nvar) :: inlavobsmpp ! - close to land + INTEGER, DIMENSION(profdata%nvar) :: ibdyvobsmpp ! - boundary + INTEGER :: igrdobsmpp ! - fail the grid search + INTEGER :: iuvchkumpp ! - reject UVEL if VVEL rejected + INTEGER :: iuvchkvmpp ! - reject VVEL if UVEL rejected + TYPE(obs_prof_valid) :: llvalid ! Profile selection + TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & + & llvvalid ! var selection + INTEGER :: jvar ! Variable loop variable + INTEGER :: jobs ! Obs. loop variable + INTEGER :: jstp ! Time loop variable + INTEGER :: inrc ! Time index variable + CHARACTER(LEN=256) :: cout1 ! Diagnostic output line + CHARACTER(LEN=256) :: cout2 ! Diagnostic output line + !!---------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*)'obs_pre_prof: Preparing the profile data...' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + + ! Initial date initialization (year, month, day, hour, minute) + iyea0 = ndate0 / 10000 + imon0 = ( ndate0 - iyea0 * 10000 ) / 100 + iday0 = ndate0 - iyea0 * 10000 - imon0 * 100 + ihou0 = nn_time0 / 100 + imin0 = ( nn_time0 - ihou0 * 100 ) + + icycle = nn_no ! Assimilation cycle + + ! Diagnostic counters for various failures. + + iotdobs = 0 + igrdobs = 0 + iosdvobs(:) = 0 + ilanvobs(:) = 0 + inlavobs(:) = 0 + ibdyvobs(:) = 0 + iuvchku = 0 + iuvchkv = 0 + + + ! Set QC cutoff to optional value if provided + IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff + + ! ----------------------------------------------------------------------- + ! Find time coordinate for profiles + ! ----------------------------------------------------------------------- + + IF ( PRESENT(kdailyavtypes) ) THEN + CALL obs_coo_tim_prof( icycle, & + & iyea0, imon0, iday0, ihou0, imin0, & + & profdata%nprof, profdata%nyea, profdata%nmon, & + & profdata%nday, profdata%nhou, profdata%nmin, & + & profdata%ntyp, profdata%nqc, profdata%mstp, & + & iotdobs, kdailyavtypes = kdailyavtypes, & + & kqc_cutoff = iqc_cutoff ) + ELSE + CALL obs_coo_tim_prof( icycle, & + & iyea0, imon0, iday0, ihou0, imin0, & + & profdata%nprof, profdata%nyea, profdata%nmon, & + & profdata%nday, profdata%nhou, profdata%nmin, & + & profdata%ntyp, profdata%nqc, profdata%mstp, & + & iotdobs, kqc_cutoff = iqc_cutoff ) + ENDIF + + CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) + + ! ----------------------------------------------------------------------- + ! Check for profiles failing the grid search + ! ----------------------------------------------------------------------- + + DO jvar = 1, profdata%nvar + CALL obs_coo_grd( profdata%nprof, profdata%mi(:,jvar), profdata%mj(:,jvar), & + & profdata%nqc, igrdobs ) + END DO + + CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) + + ! ----------------------------------------------------------------------- + ! Reject all observations for profiles with nqc > iqc_cutoff + ! ----------------------------------------------------------------------- + + CALL obs_pro_rej( profdata, kqc_cutoff = iqc_cutoff ) + + ! ----------------------------------------------------------------------- + ! Check for land points. This includes points below the model + ! bathymetry so this is done for every point in the profile + ! ----------------------------------------------------------------------- + + DO jvar = 1, profdata%nvar + CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(jvar), & + & profdata%npvsta(:,jvar), profdata%npvend(:,jvar), & + & jpi, jpj, & + & jpk, & + & profdata%mi, profdata%mj, & + & profdata%var(jvar)%mvk, & + & profdata%rlam, profdata%rphi, & + & profdata%var(jvar)%vdep, & + & pglam(:,:,jvar), pgphi(:,:,jvar), & + & gdept_1d, zmask(:,:,:,jvar), & + & profdata%nqc, profdata%var(jvar)%nvqc, & + & iosdvobs(jvar), ilanvobs(jvar), & + & inlavobs(jvar), ld_nea, & + & ibdyvobs(jvar), ld_bound_reject, & + & iqc_cutoff, Kmm ) + + CALL obs_mpp_sum_integer( iosdvobs(jvar), iosdvobsmpp(jvar) ) + CALL obs_mpp_sum_integer( ilanvobs(jvar), ilanvobsmpp(jvar) ) + CALL obs_mpp_sum_integer( inlavobs(jvar), inlavobsmpp(jvar) ) + CALL obs_mpp_sum_integer( ibdyvobs(jvar), ibdyvobsmpp(jvar) ) + END DO + + ! ----------------------------------------------------------------------- + ! Reject u if v is rejected and vice versa + ! ----------------------------------------------------------------------- + + IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN + CALL obs_uv_rej( profdata, iuvchku, iuvchkv, iqc_cutoff ) + CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp ) + CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp ) + ENDIF + + ! ----------------------------------------------------------------------- + ! Copy useful data from the profdata data structure to + ! the prodatqc data structure + ! ----------------------------------------------------------------------- + + ! Allocate the selection arrays + + ALLOCATE( llvalid%luse(profdata%nprof) ) + DO jvar = 1,profdata%nvar + ALLOCATE( llvvalid(jvar)%luse(profdata%nvprot(jvar)) ) + END DO + + ! We want all data which has qc flags <= iqc_cutoff + + llvalid%luse(:) = ( profdata%nqc(:) <= iqc_cutoff ) + DO jvar = 1,profdata%nvar + llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= iqc_cutoff ) + END DO + + ! The actual copying + + CALL obs_prof_compress( profdata, prodatqc, .TRUE., numout, & + & lvalid=llvalid, lvvalid=llvvalid ) + + ! Dellocate the selection arrays + DEALLOCATE( llvalid%luse ) + DO jvar = 1,profdata%nvar + DEALLOCATE( llvvalid(jvar)%luse ) + END DO + + ! ----------------------------------------------------------------------- + ! Print information about what observations are left after qc + ! ----------------------------------------------------------------------- + + ! Update the total observation counter array + + IF(lwp) THEN + + WRITE(numout,*) + WRITE(numout,*) ' Profiles outside time domain = ', & + & iotdobsmpp + WRITE(numout,*) ' Remaining profiles that failed grid search = ', & + & igrdobsmpp + DO jvar = 1, profdata%nvar + WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data outside space domain = ', & + & iosdvobsmpp(jvar) + WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data at land points = ', & + & ilanvobsmpp(jvar) + IF (ld_nea) THEN + WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (removed) = ',& + & inlavobsmpp(jvar) + ELSE + WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (kept) = ',& + & inlavobsmpp(jvar) + ENDIF + IF ( TRIM(profdata%cvars(jvar)) == 'UVEL' ) THEN + WRITE(numout,*) ' U observation rejected since V rejected = ', & + & iuvchku + ELSE IF ( TRIM(profdata%cvars(jvar)) == 'VVEL' ) THEN + WRITE(numout,*) ' V observation rejected since U rejected = ', & + & iuvchkv + ENDIF + WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near open boundary (removed) = ',& + & ibdyvobsmpp(jvar) + WRITE(numout,*) ' '//prodatqc%cvars(jvar)//' data accepted = ', & + & prodatqc%nvprotmpp(jvar) + END DO + + WRITE(numout,*) + WRITE(numout,*) ' Number of observations per time step :' + WRITE(numout,*) + WRITE(cout1,'(10X,A9,5X,A8)') 'Time step', 'Profiles' + WRITE(cout2,'(10X,A9,5X,A8)') '---------', '--------' + DO jvar = 1, prodatqc%nvar + WRITE(cout1,'(A,5X,A11)') TRIM(cout1), TRIM(prodatqc%cvars(jvar)) + WRITE(cout2,'(A,5X,A11)') TRIM(cout2), '-----------' + END DO + WRITE(numout,*) cout1 + WRITE(numout,*) cout2 + ENDIF + + DO jobs = 1, prodatqc%nprof + inrc = prodatqc%mstp(jobs) + 2 - nit000 + prodatqc%npstp(inrc) = prodatqc%npstp(inrc) + 1 + DO jvar = 1, prodatqc%nvar + IF ( prodatqc%npvend(jobs,jvar) > 0 ) THEN + prodatqc%nvstp(inrc,jvar) = prodatqc%nvstp(inrc,jvar) + & + & ( prodatqc%npvend(jobs,jvar) - & + & prodatqc%npvsta(jobs,jvar) + 1 ) + ENDIF + END DO + END DO + + + CALL obs_mpp_sum_integers( prodatqc%npstp, prodatqc%npstpmpp, & + & nitend - nit000 + 2 ) + DO jvar = 1, prodatqc%nvar + CALL obs_mpp_sum_integers( prodatqc%nvstp(:,jvar), & + & prodatqc%nvstpmpp(:,jvar), & + & nitend - nit000 + 2 ) + END DO + + IF ( lwp ) THEN + DO jstp = nit000 - 1, nitend + inrc = jstp - nit000 + 2 + WRITE(cout1,'(10X,I9,5X,I8)') jstp, prodatqc%npstpmpp(inrc) + DO jvar = 1, prodatqc%nvar + WRITE(cout1,'(A,5X,I11)') TRIM(cout1), prodatqc%nvstpmpp(inrc,jvar) + END DO + WRITE(numout,*) cout1 + END DO + ENDIF + + END SUBROUTINE obs_pre_prof + + SUBROUTINE obs_coo_tim( kcycle, & + & kyea0, kmon0, kday0, khou0, kmin0, & + & kobsno, & + & kobsyea, kobsmon, kobsday, kobshou, kobsmin, & + & kobsqc, kobsstp, kotdobs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_coo_tim *** + !! + !! ** Purpose : Compute the number of time steps to the observation time. + !! + !! ** Method : For time coordinates ( yea_obs, mon_obs, day_obs, + !! hou_obs, min_obs ), this routine locates the time step + !! that is closest to this time. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 1997-07 (A. Weaver) Original + !! ! 2006-08 (A. Weaver) NEMOVAR migration + !! ! 2006-10 (A. Weaver) Cleanup + !! ! 2007-01 (K. Mogensen) Rewritten with loop + !! ! 2010-05 (D. Lea) Fix in leap year calculation for NEMO vn3.2 + !!---------------------------------------------------------------------- + !! * Modules used + USE dom_oce, ONLY : & ! Geographical information + & rn_Dt + USE phycst, ONLY : & ! Physical constants + & rday, & + & rmmss, & + & rhhmm + !! * Arguments + INTEGER, INTENT(IN) :: kcycle ! Current cycle + INTEGER, INTENT(IN) :: kyea0 ! Initial date coordinates + INTEGER, INTENT(IN) :: kmon0 + INTEGER, INTENT(IN) :: kday0 + INTEGER, INTENT(IN) :: khou0 + INTEGER, INTENT(IN) :: kmin0 + INTEGER, INTENT(IN) :: kobsno ! Number of observations + INTEGER, INTENT(INOUT) :: kotdobs ! Number of observations failing time check + INTEGER, DIMENSION(kobsno), INTENT(IN ) :: & + & kobsyea, & ! Observation time coordinates + & kobsmon, & + & kobsday, & + & kobshou, & + & kobsmin + INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & + & kobsqc ! Quality control flag + INTEGER, DIMENSION(kobsno), INTENT(OUT) :: & + & kobsstp ! Number of time steps up to the + ! observation time + + !! * Local declarations + INTEGER :: jyea + INTEGER :: jmon + INTEGER :: jday + INTEGER :: jobs + INTEGER :: iyeastr + INTEGER :: iyeaend + INTEGER :: imonstr + INTEGER :: imonend + INTEGER :: idaystr + INTEGER :: idayend + INTEGER :: iskip + INTEGER :: idaystp + REAL(KIND=wp) :: zminstp + REAL(KIND=wp) :: zhoustp + REAL(KIND=wp) :: zobsstp + INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year + + !----------------------------------------------------------------------- + ! Initialization + !----------------------------------------------------------------------- + + ! Intialize the number of time steps per day + idaystp = NINT( rday / rn_Dt ) + + !--------------------------------------------------------------------- + ! Locate the model time coordinates for interpolation + !--------------------------------------------------------------------- + + DO jobs = 1, kobsno + + ! Initialize the time step counter + kobsstp(jobs) = nit000 - 1 + + ! Flag if observation date is less than the initial date + + IF ( ( kobsyea(jobs) < kyea0 ) & + & .OR. ( ( kobsyea(jobs) == kyea0 ) & + & .AND. ( kobsmon(jobs) < kmon0 ) ) & + & .OR. ( ( kobsyea(jobs) == kyea0 ) & + & .AND. ( kobsmon(jobs) == kmon0 ) & + & .AND. ( kobsday(jobs) < kday0 ) ) & + & .OR. ( ( kobsyea(jobs) == kyea0 ) & + & .AND. ( kobsmon(jobs) == kmon0 ) & + & .AND. ( kobsday(jobs) == kday0 ) & + & .AND. ( kobshou(jobs) < khou0 ) ) & + & .OR. ( ( kobsyea(jobs) == kyea0 ) & + & .AND. ( kobsmon(jobs) == kmon0 ) & + & .AND. ( kobsday(jobs) == kday0 ) & + & .AND. ( kobshou(jobs) == khou0 ) & + & .AND. ( kobsmin(jobs) <= kmin0 ) ) ) THEN + kobsstp(jobs) = -1 + kobsqc(jobs) = IBSET(kobsqc(jobs),13) + kotdobs = kotdobs + 1 + CYCLE + ENDIF + + ! Compute the number of time steps to the observation day + iyeastr = kyea0 + iyeaend = kobsyea(jobs) + + !--------------------------------------------------------------------- + ! Year loop + !--------------------------------------------------------------------- + DO jyea = iyeastr, iyeaend + + CALL calc_month_len( jyea, imonth_len ) + + imonstr = 1 + IF ( jyea == kyea0 ) imonstr = kmon0 + imonend = 12 + IF ( jyea == kobsyea(jobs) ) imonend = kobsmon(jobs) + + ! Month loop + DO jmon = imonstr, imonend + + idaystr = 1 + IF ( ( jmon == kmon0 ) & + & .AND. ( jyea == kyea0 ) ) idaystr = kday0 + idayend = imonth_len(jmon) + IF ( ( jmon == kobsmon(jobs) ) & + & .AND. ( jyea == kobsyea(jobs) ) ) idayend = kobsday(jobs) - 1 + + ! Day loop + DO jday = idaystr, idayend + kobsstp(jobs) = kobsstp(jobs) + idaystp + END DO + + END DO + + END DO + + ! Add in the number of time steps to the observation minute + zminstp = rmmss / rn_Dt + zhoustp = rhhmm * zminstp + + zobsstp = REAL( kobsmin(jobs) - kmin0, KIND=wp ) * zminstp & + & + REAL( kobshou(jobs) - khou0, KIND=wp ) * zhoustp + kobsstp(jobs) = kobsstp(jobs) + NINT( zobsstp ) + + ! Flag if observation step outside the time window + IF ( ( kobsstp(jobs) < ( nit000 - 1 ) ) & + & .OR.( kobsstp(jobs) > nitend ) ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),13) + kotdobs = kotdobs + 1 + CYCLE + ENDIF + + END DO + + END SUBROUTINE obs_coo_tim + + SUBROUTINE calc_month_len( iyear, imonth_len ) + !!---------------------------------------------------------------------- + !! *** ROUTINE calc_month_len *** + !! + !! ** Purpose : Compute the number of days in a months given a year. + !! + !! ** Method : + !! + !! ** Action : + !! + !! History : + !! ! 10-05 (D. Lea) New routine based on day_init + !!---------------------------------------------------------------------- + + INTEGER, DIMENSION(12) :: imonth_len !: length in days of the months of the current year + INTEGER :: iyear !: year + + ! length of the month of the current year (from nleapy, read in namelist) + IF ( nleapy < 2 ) THEN + imonth_len(:) = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) + IF ( nleapy == 1 ) THEN ! we are using calendar with leap years + IF ( MOD(iyear, 4) == 0 .AND. ( MOD(iyear, 400) == 0 .OR. MOD(iyear, 100) /= 0 ) ) THEN + imonth_len(2) = 29 + ENDIF + ENDIF + ELSE + imonth_len(:) = nleapy ! all months with nleapy days per year + ENDIF + + END SUBROUTINE calc_month_len + + SUBROUTINE obs_coo_tim_prof( kcycle, & + & kyea0, kmon0, kday0, khou0, kmin0, & + & kobsno, & + & kobsyea, kobsmon, kobsday, kobshou, kobsmin, & + & ktyp, kobsqc, kobsstp, kotdobs, kdailyavtypes, & + & kqc_cutoff ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_coo_tim *** + !! + !! ** Purpose : Compute the number of time steps to the observation time. + !! + !! ** Method : For time coordinates ( yea_obs, mon_obs, day_obs, + !! hou_obs, min_obs ), this routine locates the time step + !! that is closest to this time. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 1997-07 (A. Weaver) Original + !! ! 2006-08 (A. Weaver) NEMOVAR migration + !! ! 2006-10 (A. Weaver) Cleanup + !! ! 2007-01 (K. Mogensen) Rewritten with loop + !!---------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER, INTENT(IN) :: kcycle ! Current cycle + INTEGER, INTENT(IN) :: kyea0 ! Initial date coordinates + INTEGER, INTENT(IN) :: kmon0 + INTEGER, INTENT(IN) :: kday0 + INTEGER, INTENT(IN) :: khou0 + INTEGER, INTENT(IN) :: kmin0 + INTEGER, INTENT(IN) :: kobsno ! Number of observations + INTEGER, INTENT(INOUT) :: kotdobs ! Number of observations failing time check + INTEGER, DIMENSION(kobsno), INTENT(IN ) :: & + & kobsyea, & ! Observation time coordinates + & kobsmon, & + & kobsday, & + & kobshou, & + & kobsmin, & + & ktyp ! Observation type. + INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & + & kobsqc ! Quality control flag + INTEGER, DIMENSION(kobsno), INTENT(OUT) :: & + & kobsstp ! Number of time steps up to the + ! observation time + INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & + & kdailyavtypes ! Types for daily averages + INTEGER, OPTIONAL, INTENT(IN) :: kqc_cutoff ! QC cutoff value + + !! * Local declarations + INTEGER :: jobs + INTEGER :: iqc_cutoff=255 + + !----------------------------------------------------------------------- + ! Call standard obs_coo_tim + !----------------------------------------------------------------------- + + CALL obs_coo_tim( kcycle, & + & kyea0, kmon0, kday0, khou0, kmin0, & + & kobsno, & + & kobsyea, kobsmon, kobsday, kobshou, kobsmin, & + & kobsqc, kobsstp, kotdobs ) + + !------------------------------------------------------------------------ + ! Always reject daily averaged data (e.g. MRB data (820)) at initial time + !------------------------------------------------------------------------ + + IF ( PRESENT(kdailyavtypes) ) THEN + DO jobs = 1, kobsno + + IF ( kobsqc(jobs) <= iqc_cutoff ) THEN + + IF ( ( kobsstp(jobs) == (nit000 - 1) ).AND.& + & ( ANY (kdailyavtypes(:) == ktyp(jobs)) ) ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),13) + kotdobs = kotdobs + 1 + CYCLE + ENDIF + + ENDIF + END DO + ENDIF + + + END SUBROUTINE obs_coo_tim_prof + + SUBROUTINE obs_coo_grd( kobsno, kobsi, kobsj, kobsqc, kgrdobs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_coo_grd *** + !! + !! ** Purpose : Verify that the grid search has not failed + !! + !! ** Method : The previously computed i,j indeces are checked + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 2007-01 (K. Mogensen) Original + !!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: kobsno ! Number of observations + INTEGER, DIMENSION(kobsno), INTENT(IN ) :: & + & kobsi, & ! i,j indeces previously computed + & kobsj + INTEGER, INTENT(INOUT) :: kgrdobs ! Number of observations failing the check + INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & + & kobsqc ! Quality control flag + + !! * Local declarations + INTEGER :: jobs ! Loop variable + + ! Flag if the grid search failed + + DO jobs = 1, kobsno + IF ( ( kobsi(jobs) <= 0 ) .AND. ( kobsj(jobs) <= 0 ) ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),12) + kgrdobs = kgrdobs + 1 + ENDIF + END DO + + END SUBROUTINE obs_coo_grd + + SUBROUTINE obs_coo_spc_2d( kobsno, kpi, kpj, & + & kobsi, kobsj, pobslam, pobsphi, & + & plam, pphi, pmask, & + & kobsqc, kosdobs, klanobs, & + & knlaobs,ld_nea, & + & kbdyobs,ld_bound_reject, & + & kqc_cutoff ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_coo_spc_2d *** + !! + !! ** Purpose : Check for points outside the domain and land points + !! + !! ** Method : Remove the observations that are outside the model space + !! and time domain or located within model land cells. + !! + !! ** Action : + !! + !! History : 2007-03 (A. Weaver, K. Mogensen) Original + !! ! 2007-06 (K. Mogensen et al) Reject obs. near land. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kobsno ! Total number of observations + INTEGER , INTENT(in ) :: kpi , kpj ! Number of grid points in (i,j) + INTEGER , INTENT(in ), DIMENSION(kobsno) :: kobsi , kobsj ! Observation (i,j) coordinates + REAL(wp), INTENT(in ), DIMENSION(kobsno) :: pobslam, pobsphi ! Observation (lon,lat) coordinates + REAL(wp), INTENT(in ), DIMENSION(kpi,kpj) :: plam , pphi ! Model (lon,lat) coordinates + REAL(wp), INTENT(in ), DIMENSION(kpi,kpj) :: pmask ! Land mask array + INTEGER , INTENT(inout), DIMENSION(kobsno) :: kobsqc ! Observation quality control + INTEGER , INTENT(inout) :: kosdobs ! Observations outside space domain + INTEGER , INTENT(inout) :: klanobs ! Observations within a model land cell + INTEGER , INTENT(inout) :: knlaobs ! Observations near land + INTEGER , INTENT(inout) :: kbdyobs ! Observations near boundary + LOGICAL , INTENT(in ) :: ld_nea ! Flag observations near land + LOGICAL , INTENT(in ) :: ld_bound_reject ! Flag observations near open boundary + INTEGER , INTENT(in ) :: kqc_cutoff ! Cutoff QC value + ! + REAL(KIND=wp), DIMENSION(2,2,kobsno) :: zgmsk ! Grid mask + REAL(KIND=wp), DIMENSION(2,2,kobsno) :: zbmsk ! Boundary mask + REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask + REAL(KIND=wp), DIMENSION(2,2,kobsno) :: zglam, zgphi ! Model Lon/lat at grid points + INTEGER , DIMENSION(2,2,kobsno) :: igrdi, igrdj ! Grid i,j + LOGICAL :: lgridobs ! Is observation on a model grid point. + INTEGER :: iig, ijg ! i,j of observation on model grid point. + INTEGER :: jobs, ji, jj + !!---------------------------------------------------------------------- + + ! Get grid point indices + + DO jobs = 1, kobsno + + ! For invalid points use 2,2 + + IF ( kobsqc(jobs) >= kqc_cutoff ) THEN + + igrdi(1,1,jobs) = 1 + igrdj(1,1,jobs) = 1 + igrdi(1,2,jobs) = 1 + igrdj(1,2,jobs) = 2 + igrdi(2,1,jobs) = 2 + igrdj(2,1,jobs) = 1 + igrdi(2,2,jobs) = 2 + igrdj(2,2,jobs) = 2 + + ELSE + + igrdi(1,1,jobs) = kobsi(jobs)-1 + igrdj(1,1,jobs) = kobsj(jobs)-1 + igrdi(1,2,jobs) = kobsi(jobs)-1 + igrdj(1,2,jobs) = kobsj(jobs) + igrdi(2,1,jobs) = kobsi(jobs) + igrdj(2,1,jobs) = kobsj(jobs)-1 + igrdi(2,2,jobs) = kobsi(jobs) + igrdj(2,2,jobs) = kobsj(jobs) + + ENDIF + + END DO + + IF (ln_bdy) THEN + ! Create a mask grid points in boundary rim + IF (ld_bound_reject) THEN + zbdymask(:,:) = 1.0_wp + DO ji = 1, nb_bdy + DO jj = 1, idx_bdy(ji)%nblen(1) + zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp + ENDDO + ENDDO + + CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk ) + ENDIF + ENDIF + + + CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pmask, zgmsk ) + CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, plam, zglam ) + CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) + + DO jobs = 1, kobsno + + ! Skip bad observations + IF ( kobsqc(jobs) >= kqc_cutoff ) CYCLE + + ! Flag if the observation falls outside the model spatial domain + IF ( ( pobslam(jobs) < -180. ) & + & .OR. ( pobslam(jobs) > 180. ) & + & .OR. ( pobsphi(jobs) < -90. ) & + & .OR. ( pobsphi(jobs) > 90. ) ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),11) + kosdobs = kosdobs + 1 + CYCLE + ENDIF + + ! Flag if the observation falls with a model land cell + IF ( SUM( zgmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),10) + klanobs = klanobs + 1 + CYCLE + ENDIF + + ! Check if this observation is on a grid point + + lgridobs = .FALSE. + iig = -1 + ijg = -1 + DO jj = 1, 2 + DO ji = 1, 2 + IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) & + & .AND. & + & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) ) & + & < 1.0e-6_wp ) ) THEN + lgridobs = .TRUE. + iig = ji + ijg = jj + ENDIF + END DO + END DO + + ! For observations on the grid reject them if their are at + ! a masked point + + IF (lgridobs) THEN + IF (zgmsk(iig,ijg,jobs) == 0.0_wp ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),10) + klanobs = klanobs + 1 + CYCLE + ENDIF + ENDIF + + ! Flag if the observation falls is close to land + IF ( MINVAL( zgmsk(1:2,1:2,jobs) ) == 0.0_wp) THEN + knlaobs = knlaobs + 1 + IF (ld_nea) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),9) + CYCLE + ENDIF + ENDIF + + IF (ln_bdy) THEN + ! Flag if the observation falls close to the boundary rim + IF (ld_bound_reject) THEN + IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),8) + kbdyobs = kbdyobs + 1 + CYCLE + ENDIF + ! for observations on the grid... + IF (lgridobs) THEN + IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN + kobsqc(jobs) = IBSET(kobsqc(jobs),8) + kbdyobs = kbdyobs + 1 + CYCLE + ENDIF + ENDIF + ENDIF + ENDIF + ! + END DO + ! + END SUBROUTINE obs_coo_spc_2d + + + SUBROUTINE obs_coo_spc_3d( kprofno, kobsno, kpstart, kpend, & + & kpi, kpj, kpk, & + & kobsi, kobsj, kobsk, & + & pobslam, pobsphi, pobsdep, & + & plam, pphi, pdep, pmask, & + & kpobsqc, kobsqc, kosdobs, & + & klanobs, knlaobs, ld_nea, & + & kbdyobs, ld_bound_reject, & + & kqc_cutoff, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_coo_spc_3d *** + !! + !! ** Purpose : Check for points outside the domain and land points + !! Reset depth of observation above highest model level + !! to the value of highest model level + !! + !! ** Method : Remove the observations that are outside the model space + !! and time domain or located within model land cells. + !! + !! NB. T and S profile observations lying between the ocean + !! surface and the depth of the first model T point are + !! assigned a depth equal to that of the first model T pt. + !! + !! ** Action : + !! + !! History : + !! ! 2007-01 (K. Mogensen) Rewrite of parts of obs_scr + !! ! 2007-06 (K. Mogensen et al) Reject obs. near land. + !!---------------------------------------------------------------------- + !! * Modules used + USE dom_oce ! Geographical information + + !! * Arguments + INTEGER, INTENT(IN) :: kprofno ! Number of profiles + INTEGER, INTENT(IN) :: kobsno ! Total number of observations + INTEGER, INTENT(IN) :: kpi ! Number of grid points in (i,j,k) + INTEGER, INTENT(IN) :: kpj + INTEGER, INTENT(IN) :: kpk + INTEGER, DIMENSION(kprofno), INTENT(IN) :: & + & kpstart, & ! Start of individual profiles + & kpend ! End of individual profiles + INTEGER, DIMENSION(kprofno), INTENT(IN) :: & + & kobsi, & ! Observation (i,j) coordinates + & kobsj + INTEGER, DIMENSION(kobsno), INTENT(IN) :: & + & kobsk ! Observation k coordinate + REAL(KIND=wp), DIMENSION(kprofno), INTENT(IN) :: & + & pobslam, & ! Observation (lon,lat) coordinates + & pobsphi + REAL(KIND=wp), DIMENSION(kobsno), INTENT(INOUT) :: & + & pobsdep ! Observation depths + REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) :: & + & plam, pphi ! Model (lon,lat) coordinates + REAL(KIND=wp), DIMENSION(kpk), INTENT(IN) :: & + & pdep ! Model depth coordinates + REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) :: & + & pmask ! Land mask array + INTEGER, DIMENSION(kprofno), INTENT(INOUT) :: & + & kpobsqc ! Profile quality control + INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & + & kobsqc ! Observation quality control + INTEGER, INTENT(INOUT) :: kosdobs ! Observations outside space domain + INTEGER, INTENT(INOUT) :: klanobs ! Observations within a model land cell + INTEGER, INTENT(INOUT) :: knlaobs ! Observations near land + INTEGER, INTENT(INOUT) :: kbdyobs ! Observations near boundary + LOGICAL, INTENT(IN) :: ld_nea ! Flag observations near land + LOGICAL, INTENT(IN) :: ld_bound_reject ! Flag observations near open boundary + INTEGER, INTENT(IN) :: kqc_cutoff ! Cutoff QC value + INTEGER, INTENT(IN) :: Kmm ! time-level index + + !! * Local declarations + REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & + & zgmsk ! Grid mask + REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & + & zbmsk ! Boundary mask + REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask + REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & + & zgdepw + REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & + & zglam, & ! Model longitude at grid points + & zgphi ! Model latitude at grid points + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepw + INTEGER, DIMENSION(2,2,kprofno) :: & + & igrdi, & ! Grid i,j + & igrdj + LOGICAL :: lgridobs ! Is observation on a model grid point. + LOGICAL :: ll_next_to_land ! Is a profile next to land + INTEGER :: iig, ijg ! i,j of observation on model grid point. + INTEGER :: jobs, jobsp, jk, ji, jj + !!---------------------------------------------------------------------- + + ! Get grid point indices + + DO jobs = 1, kprofno + + ! For invalid points use 2,2 + + IF ( kpobsqc(jobs) >= kqc_cutoff ) THEN + + igrdi(1,1,jobs) = 1 + igrdj(1,1,jobs) = 1 + igrdi(1,2,jobs) = 1 + igrdj(1,2,jobs) = 2 + igrdi(2,1,jobs) = 2 + igrdj(2,1,jobs) = 1 + igrdi(2,2,jobs) = 2 + igrdj(2,2,jobs) = 2 + + ELSE + + igrdi(1,1,jobs) = kobsi(jobs)-1 + igrdj(1,1,jobs) = kobsj(jobs)-1 + igrdi(1,2,jobs) = kobsi(jobs)-1 + igrdj(1,2,jobs) = kobsj(jobs) + igrdi(2,1,jobs) = kobsi(jobs) + igrdj(2,1,jobs) = kobsj(jobs)-1 + igrdi(2,2,jobs) = kobsi(jobs) + igrdj(2,2,jobs) = kobsj(jobs) + + ENDIF + + END DO + + IF (ln_bdy) THEN + ! Create a mask grid points in boundary rim + IF (ld_bound_reject) THEN + zbdymask(:,:) = 1.0_wp + DO ji = 1, nb_bdy + DO jj = 1, idx_bdy(ji)%nblen(1) + zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp + ENDDO + ENDDO + ENDIF + + CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk ) + ENDIF + + CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, pmask, zgmsk ) + CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, plam, zglam ) + CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) + DO jk = 1, jpk + zdepw(:,:,jk) = gdepw(:,:,jk,Kmm) + END DO + CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, zdepw(:,:,:), zgdepw ) + + DO jobs = 1, kprofno + + ! Skip bad profiles + IF ( kpobsqc(jobs) >= kqc_cutoff ) CYCLE + + ! Check if this observation is on a grid point + + lgridobs = .FALSE. + iig = -1 + ijg = -1 + DO jj = 1, 2 + DO ji = 1, 2 + IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) & + & .AND. & + & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) ) < 1.0e-6_wp ) & + & ) THEN + lgridobs = .TRUE. + iig = ji + ijg = jj + ENDIF + END DO + END DO + + ! Check if next to land + IF ( ANY( zgmsk(1:2,1:2,1,jobs) == 0.0_wp ) ) THEN + ll_next_to_land=.TRUE. + ELSE + ll_next_to_land=.FALSE. + ENDIF + + ! Reject observations + + DO jobsp = kpstart(jobs), kpend(jobs) + + ! Flag if the observation falls outside the model spatial domain + IF ( ( pobslam(jobs) < -180. ) & + & .OR. ( pobslam(jobs) > 180. ) & + & .OR. ( pobsphi(jobs) < -90. ) & + & .OR. ( pobsphi(jobs) > 90. ) & + & .OR. ( pobsdep(jobsp) < 0.0 ) & + & .OR. ( pobsdep(jobsp) > gdepw_1d(kpk)) ) THEN + kobsqc(jobsp) = IBSET(kobsqc(jobsp),11) + kosdobs = kosdobs + 1 + CYCLE + ENDIF + + ! To check if an observations falls within land: + + ! Flag if the observation is deeper than the bathymetry + ! Or if it is within the mask + IF ( ALL( zgdepw(1:2,1:2,kpk,jobs) < pobsdep(jobsp) ) & + & .OR. & + & ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & + & == 0.0_wp) ) THEN + kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) + klanobs = klanobs + 1 + CYCLE + ENDIF + + ! Flag if the observation is close to land + IF ( ll_next_to_land ) THEN + knlaobs = knlaobs + 1 + IF (ld_nea) THEN + kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) + ENDIF + ENDIF + + ! For observations on the grid reject them if their are at + ! a masked point + + IF (lgridobs) THEN + IF (zgmsk(iig,ijg,kobsk(jobsp)-1,jobs) == 0.0_wp ) THEN + kobsqc(jobsp) = IBSET(kobsqc(jobs),10) + klanobs = klanobs + 1 + CYCLE + ENDIF + ENDIF + + ! Flag if the observation falls is close to land + IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == & + & 0.0_wp) THEN + IF (ld_nea) kobsqc(jobsp) = kobsqc(jobsp) + 14 + knlaobs = knlaobs + 1 + ENDIF + + ! Set observation depth equal to that of the first model depth + IF ( pobsdep(jobsp) <= pdep(1) ) THEN + pobsdep(jobsp) = pdep(1) + ENDIF + + IF (ln_bdy) THEN + ! Flag if the observation falls close to the boundary rim + IF (ld_bound_reject) THEN + IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN + kobsqc(jobsp) = IBSET(kobsqc(jobs),8) + kbdyobs = kbdyobs + 1 + CYCLE + ENDIF + ! for observations on the grid... + IF (lgridobs) THEN + IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN + kobsqc(jobsp) = IBSET(kobsqc(jobs),8) + kbdyobs = kbdyobs + 1 + CYCLE + ENDIF + ENDIF + ENDIF + ENDIF + ! + END DO + END DO + ! + END SUBROUTINE obs_coo_spc_3d + + + SUBROUTINE obs_pro_rej( profdata, kqc_cutoff ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_pro_rej *** + !! + !! ** Purpose : Reject all data within a rejected profile + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History : 2007-10 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + TYPE(obs_prof), INTENT(inout) :: profdata ! Profile data + INTEGER , INTENT(in ) :: kqc_cutoff ! QC cutoff value + ! + INTEGER :: jprof + INTEGER :: jvar + INTEGER :: jobs + !!---------------------------------------------------------------------- + + ! Loop over profiles + + DO jprof = 1, profdata%nprof + + IF ( profdata%nqc(jprof) > kqc_cutoff ) THEN + + DO jvar = 1, profdata%nvar + + DO jobs = profdata%npvsta(jprof,jvar), & + & profdata%npvend(jprof,jvar) + + profdata%var(jvar)%nvqc(jobs) = & + & IBSET(profdata%var(jvar)%nvqc(jobs),14) + + END DO + + END DO + + ENDIF + + END DO + ! + END SUBROUTINE obs_pro_rej + + + SUBROUTINE obs_uv_rej( profdata, knumu, knumv, kqc_cutoff ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_uv_rej *** + !! + !! ** Purpose : Reject u if v is rejected and vice versa + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History : 2009-2 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + TYPE(obs_prof), INTENT(INOUT) :: profdata ! Profile data + INTEGER, INTENT(INOUT) :: knumu ! Number of u rejected + INTEGER, INTENT(INOUT) :: knumv ! Number of v rejected + INTEGER, INTENT(IN) :: kqc_cutoff ! QC cutoff value + ! + INTEGER :: jprof + INTEGER :: jvar + INTEGER :: jobs + !!---------------------------------------------------------------------- + + DO jprof = 1, profdata%nprof !== Loop over profiles ==! + ! + IF ( ( profdata%npvsta(jprof,1) /= profdata%npvsta(jprof,2) ) .OR. & + & ( profdata%npvend(jprof,1) /= profdata%npvend(jprof,2) ) ) THEN + ! + CALL ctl_stop('U,V profiles inconsistent in obs_uv_rej') + RETURN + ! + ENDIF + ! + DO jobs = profdata%npvsta(jprof,1), profdata%npvend(jprof,1) + ! + IF ( ( profdata%var(1)%nvqc(jobs) > kqc_cutoff ) .AND. & + & ( profdata%var(2)%nvqc(jobs) <= kqc_cutoff) ) THEN + profdata%var(2)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15) + knumv = knumv + 1 + ENDIF + IF ( ( profdata%var(2)%nvqc(jobs) > kqc_cutoff ) .AND. & + & ( profdata%var(1)%nvqc(jobs) <= kqc_cutoff) ) THEN + profdata%var(1)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15) + knumu = knumu + 1 + ENDIF + ! + END DO + ! + END DO + ! + END SUBROUTINE obs_uv_rej + + !!===================================================================== +END MODULE obs_prep \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_profiles.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_profiles.F90 new file mode 100644 index 0000000..7246820 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_profiles.F90 @@ -0,0 +1,39 @@ +MODULE obs_profiles + !!===================================================================== + !! *** MODULE obs_profiles *** + !! Observation diagnostics: Storage space for profile observations + !! arrays and additional flags etc. + !!===================================================================== + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_profiles.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + + !! * Modules used + USE obs_profiles_def ! Definition of profile data types and tools + + IMPLICIT NONE + + SAVE + + !! * Routine accessibility + PRIVATE + + PUBLIC nprofsets, nprofvars, nprofextr, profdata, prodatqc + PUBLIC nvelosets, nvelovars, nveloextr, velodata, veldatqc + + !! * Shared Module variables + INTEGER :: nprofsets ! Total number of profile data sets + INTEGER :: nprofvars ! Total number of variables for profiles + INTEGER :: nprofextr ! Extra fields for each variable + TYPE(obs_prof), POINTER :: profdata(:) ! Initial profile data + TYPE(obs_prof), POINTER :: prodatqc(:) ! Profile data after quality control + + INTEGER :: nvelosets ! Total number of velocity profile data sets + INTEGER :: nvelovars ! Total number of variables for profiles + INTEGER :: nveloextr ! Extra fields for each variable + TYPE(obs_prof), POINTER :: velodata(:) ! Initial velocity profile data + TYPE(obs_prof), POINTER :: veldatqc(:) ! Velocity profile data after quality control +END MODULE obs_profiles \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_profiles_def.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_profiles_def.F90 new file mode 100644 index 0000000..24532a7 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_profiles_def.F90 @@ -0,0 +1,927 @@ +MODULE obs_profiles_def + !!===================================================================== + !! *** MODULE obs_profiles_def *** + !! Observation diagnostics: Storage handling for T,S profiles + !! arrays and additional flags etc. + !! This module only defines the data type and + !! operations on the data type. There is no + !! actual data in the module. + !!===================================================================== + + !!---------------------------------------------------------------------- + !! obs_prof : F90 type containing the profile information + !! obs_prof_var : F90 type containing the variable definition + !! obs_prof_valid : F90 type containing the valid obs. definition + !! obs_prof_alloc : Allocates profile arrays + !! obs_prof_dealloc : Deallocates profile arrays + !! obs_prof_compress : Extract sub-information from a obs_prof type + !! to a new obs_prof type + !! obs_prof_decompress : Reinsert sub-information from a obs_prof type + !! into the original obs_prof type + !! obs_prof_staend : Set npvsta and npvend of a variable within an + !! obs_prof_var type + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp + USE in_out_manager ! I/O manager + USE obs_mpp, ONLY : & ! MPP tools + obs_mpp_sum_integers + USE obs_fbm ! Obs feedback format + USE lib_mpp, ONLY : & + & ctl_warn, ctl_stop + + IMPLICIT NONE + + !! * Routine/type accessibility + PRIVATE + + PUBLIC & + & obs_prof, & + & obs_prof_var, & + & obs_prof_valid, & + & obs_prof_alloc, & + & obs_prof_alloc_var, & + & obs_prof_dealloc, & + & obs_prof_compress, & + & obs_prof_decompress,& + & obs_prof_staend + + !! * Type definition for valid observations + + TYPE obs_prof_valid + + LOGICAL, POINTER, DIMENSION(:) :: luse + + END TYPE obs_prof_valid + + !! * Type definition for each variable + + TYPE obs_prof_var + + ! Arrays with size equal to the number of observations + + INTEGER, POINTER, DIMENSION(:) :: & + & mvk, & !: k-th grid coord. for interpolating to profile data + & nvpidx,& !: Profile number + & nvlidx,& !: Level number in profile + & nvqc, & !: Variable QC flags + & idqc !: Depth QC flag + + REAL(KIND=wp), POINTER, DIMENSION(:) :: & + & vdep, & !: Depth coordinate of profile data + & vobs, & !: Profile data + & vmod !: Model counterpart of the profile data vector + + REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & + & vext !: Extra variables + + INTEGER, POINTER, DIMENSION(:) :: & + & nvind !: Source indices of temp. data in compressed data + + ! Arrays with size equal to idefnqcf times the number of observations + INTEGER, POINTER, DIMENSION(:,:) :: & + & idqcf, & !: Depth QC flags + & nvqcf !: Variable QC flags + + END TYPE obs_prof_var + + !! * Type definition for profile observation type + + TYPE obs_prof + + ! Bookkeeping + + INTEGER :: nvar !: Number of variables + INTEGER :: next !: Number of extra fields + INTEGER :: nprof !: Total number of profiles within window. + INTEGER :: nstp !: Number of time steps + INTEGER :: npi !: Number of 3D grid points + INTEGER :: npj + INTEGER :: npk + INTEGER :: nprofup !: Observation counter used in obs_oper + + ! Bookkeeping arrays with sizes equal to number of variables + + CHARACTER(len=8), POINTER, DIMENSION(:) :: & + & cvars !: Variable names + + INTEGER, POINTER, DIMENSION(:) :: & + & nvprot, & !: Local total number of profile T data + & nvprotmpp !: Global total number of profile T data + + ! Arrays with size equal to the number of profiles + + INTEGER, POINTER, DIMENSION(:) :: & + & npidx,& !: Profile number + & npfil,& !: Profile number in file + & nyea, & !: Year of profile + & nmon, & !: Month of profile + & nday, & !: Day of profile + & nhou, & !: Hour of profile + & nmin, & !: Minute of profile + & mstp, & !: Time step nearest to profile + & nqc, & !: Profile QC + & ntyp, & !: Type of profile product (WMO table 1770) + & ipqc, & !: Position QC + & itqc !: Time QC + + REAL(KIND=wp), POINTER, DIMENSION(:) :: & + & rlam, & !: Longitude coordinate of profile data + & rphi !: Latitude coordinate of profile data + + CHARACTER(LEN=8), POINTER, DIMENSION(:) :: & + & cwmo !: Profile WMO indentifier + + ! Arrays with size equal to the number of profiles times + ! number of variables + + INTEGER, POINTER, DIMENSION(:,:) :: & + & npvsta, & !: Start of each variable profile in full arrays + & npvend, & !: End of each variable profile in full arrays + & mi, & !: i-th grid coord. for interpolating to profile T data + & mj, & !: j-th grid coord. for interpolating to profile T data + & ivqc !: QC flags for all levels for a variable + + ! Arrays with size equal to idefnqcf + ! the number of profiles times number of variables + INTEGER, POINTER, DIMENSION(:,:) :: & + & nqcf, & !: Observation QC flags + & ipqcf, & !: Position QC flags + & itqcf !: Time QC flags + + ! Arrays with size equal to idefnqcf + ! the number of profiles times number of variables + INTEGER, POINTER, DIMENSION(:,:,:) :: & + & ivqcf + + ! Arrays of variables + + TYPE(obs_prof_var), POINTER, DIMENSION(:) :: var + + ! Arrays with size equal to the number of time steps in the window + + INTEGER, POINTER, DIMENSION(:) :: & + & npstp, & !: Total number of profiles + & npstpmpp !: Total number of profiles + + ! Arrays with size equal to the number of time steps in the window times + ! number of variables + + INTEGER, POINTER, DIMENSION(:,:) :: & + & nvstp, & !: Local total num. of profile data each time step + & nvstpmpp !: Global total num. of profile data each time step + + ! Arrays with size equal to the number of grid points times number of + ! variables + + REAL(KIND=wp), POINTER, DIMENSION(:,:,:,:) :: & + & vdmean !: Daily averaged model field + + ! Arrays used to store source indices when + ! compressing obs_prof derived types + + ! Array with size nprof + + INTEGER, POINTER, DIMENSION(:) :: & + & npind !: Source indices of profile data in compressed data + + END TYPE obs_prof + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_profiles_def.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_prof_alloc( prof, kvar, kext, kprof, & + & ko3dt, kstp, kpi, kpj, kpk ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_alloc *** + !! + !! ** Purpose : - Allocate data for profile arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-01 (K. Mogensen) Original code + !! ! 07-03 (K. Mogensen) Generalized profiles + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated + INTEGER, INTENT(IN) :: kprof ! Number of profiles + INTEGER, INTENT(IN) :: kvar ! Number of variables + INTEGER, INTENT(IN) :: kext ! Number of extra fields within each variable + INTEGER, INTENT(IN), DIMENSION(kvar) :: & + & ko3dt ! Number of observations per variables + INTEGER, INTENT(IN) :: kstp ! Number of time steps + INTEGER, INTENT(IN) :: kpi ! Number of 3D grid points + INTEGER, INTENT(IN) :: kpj + INTEGER, INTENT(IN) :: kpk + + !!* Local variables + INTEGER :: jvar + INTEGER :: ji + + ! Set bookkeeping variables + + prof%nvar = kvar + prof%next = kext + prof%nprof = kprof + + prof%nstp = kstp + prof%npi = kpi + prof%npj = kpj + prof%npk = kpk + + ! Allocate arrays of size number of variables + + ALLOCATE( & + & prof%cvars(kvar), & + & prof%nvprot(kvar), & + & prof%nvprotmpp(kvar) & + ) + + DO jvar = 1, kvar + prof%cvars (jvar) = "NotSet" + prof%nvprot (jvar) = ko3dt(jvar) + prof%nvprotmpp(jvar) = 0 + END DO + + ! Allocate arrays of size number of profiles + ! times number of variables + + ALLOCATE( & + & prof%npvsta(kprof,kvar), & + & prof%npvend(kprof,kvar), & + & prof%mi(kprof,kvar), & + & prof%mj(kprof,kvar), & + & prof%ivqc(kprof,kvar) & + ) + + ! Allocate arrays of size iqcfdef times number of profiles + ! times number of variables + + ALLOCATE( & + & prof%ivqcf(idefnqcf,kprof,kvar) & + & ) + + ! Allocate arrays of size number of profiles + + ALLOCATE( & + & prof%npidx(kprof), & + & prof%npfil(kprof), & + & prof%nyea(kprof), & + & prof%nmon(kprof), & + & prof%nday(kprof), & + & prof%nhou(kprof), & + & prof%nmin(kprof), & + & prof%mstp(kprof), & + & prof%nqc(kprof), & + & prof%ipqc(kprof), & + & prof%itqc(kprof), & + & prof%ntyp(kprof), & + & prof%rlam(kprof), & + & prof%rphi(kprof), & + & prof%cwmo(kprof), & + & prof%npind(kprof) & + & ) + + ! Allocate arrays of size idefnqcf times number of profiles + + ALLOCATE( & + & prof%nqcf(idefnqcf,kprof), & + & prof%ipqcf(idefnqcf,kprof), & + & prof%itqcf(idefnqcf,kprof) & + & ) + + ! Allocate obs_prof_var type + ALLOCATE( & + & prof%var(kvar) & + & ) + + ! For each variables allocate arrays of size number of observations + + DO jvar = 1, kvar + + IF ( ko3dt(jvar) >= 0 ) THEN + CALL obs_prof_alloc_var( prof, jvar, kext, ko3dt(jvar) ) + ENDIF + + END DO + + ! Allocate arrays of size number of time step size + + ALLOCATE( & + & prof%npstp(kstp), & + & prof%npstpmpp(kstp) & + & ) + + ! Allocate arrays of size number of time step size times + ! number of variables + + ALLOCATE( & + & prof%nvstp(kstp,kvar), & + & prof%nvstpmpp(kstp,kvar) & + & ) + + ! Allocate arrays of size number of grid points size times + ! number of variables + + ALLOCATE( & + & prof%vdmean(kpi,kpj,kpk,kvar) & + & ) + + ! Set defaults for compression indices + + DO ji = 1, kprof + prof%npind(ji) = ji + END DO + + DO jvar = 1, kvar + DO ji = 1, ko3dt(jvar) + prof%var(jvar)%nvind(ji) = ji + END DO + END DO + + ! Set defaults for number of observations per time step + + prof%npstp(:) = 0 + prof%npstpmpp(:) = 0 + prof%nvstp(:,:) = 0 + prof%nvstpmpp(:,:) = 0 + + ! Set the observation counter used in obs_oper + + prof%nprofup = 0 + + END SUBROUTINE obs_prof_alloc + + SUBROUTINE obs_prof_dealloc( prof ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_dealloc *** + !! + !! ** Purpose : - Deallocate data for profile arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-01 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: & + & prof ! Profile data to be deallocated + + !!* Local variables + INTEGER :: & + & jvar + + ! Deallocate arrays of size number of profiles + ! times number of variables + + DEALLOCATE( & + & prof%npvsta, & + & prof%npvend & + ) + + ! Dellocate arrays of size number of profiles size + + DEALLOCATE( & + & prof%mi, & + & prof%mj, & + & prof%ivqc, & + & prof%ivqcf, & + & prof%npidx, & + & prof%npfil, & + & prof%nyea, & + & prof%nmon, & + & prof%nday, & + & prof%nhou, & + & prof%nmin, & + & prof%mstp, & + & prof%nqc, & + & prof%ipqc, & + & prof%itqc, & + & prof%nqcf, & + & prof%ipqcf, & + & prof%itqcf, & + & prof%ntyp, & + & prof%rlam, & + & prof%rphi, & + & prof%cwmo, & + & prof%npind & + & ) + + ! For each variables allocate arrays of size number of observations + + DO jvar = 1, prof%nvar + + IF ( prof%nvprot(jvar) >= 0 ) THEN + + CALL obs_prof_dealloc_var( prof, jvar ) + + ENDIF + + END DO + + ! Dellocate obs_prof_var type + DEALLOCATE( & + & prof%var & + & ) + + ! Deallocate arrays of size number of time step size + + DEALLOCATE( & + & prof%npstp, & + & prof%npstpmpp & + & ) + + ! Deallocate arrays of size number of time step size times + ! number of variables + + DEALLOCATE( & + & prof%nvstp, & + & prof%nvstpmpp & + & ) + + ! Deallocate arrays of size number of grid points size times + ! number of variables + + DEALLOCATE( & + & prof%vdmean & + & ) + + ! Dellocate arrays of size number of variables + + DEALLOCATE( & + & prof%cvars, & + & prof%nvprot, & + & prof%nvprotmpp & + ) + + + END SUBROUTINE obs_prof_dealloc + + + SUBROUTINE obs_prof_alloc_var( prof, kvar, kext, kobs ) + + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_alloc_var *** + !! + !! ** Purpose : - Allocate data for variable data in profile arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-03 (K. Mogensen) Original code + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated + INTEGER, INTENT(IN) :: kvar ! Variable number + INTEGER, INTENT(IN) :: kext ! Number of extra fields within each variable + INTEGER, INTENT(IN) :: kobs ! Number of observations + + ALLOCATE( & + & prof%var(kvar)%mvk(kobs), & + & prof%var(kvar)%nvpidx(kobs), & + & prof%var(kvar)%nvlidx(kobs), & + & prof%var(kvar)%nvqc(kobs), & + & prof%var(kvar)%idqc(kobs), & + & prof%var(kvar)%vdep(kobs), & + & prof%var(kvar)%vobs(kobs), & + & prof%var(kvar)%vmod(kobs), & + & prof%var(kvar)%nvind(kobs) & + & ) + ALLOCATE( & + & prof%var(kvar)%idqcf(idefnqcf,kobs), & + & prof%var(kvar)%nvqcf(idefnqcf,kobs) & + & ) + IF (kext>0) THEN + ALLOCATE( & + & prof%var(kvar)%vext(kobs,kext) & + & ) + ENDIF + + END SUBROUTINE obs_prof_alloc_var + + SUBROUTINE obs_prof_dealloc_var( prof, kvar ) + + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_alloc_var *** + !! + !! ** Purpose : - Allocate data for variable data in profile arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-03 (K. Mogensen) Original code + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated + INTEGER, INTENT(IN) :: kvar ! Variable number + + DEALLOCATE( & + & prof%var(kvar)%mvk, & + & prof%var(kvar)%nvpidx, & + & prof%var(kvar)%nvlidx, & + & prof%var(kvar)%nvqc, & + & prof%var(kvar)%idqc, & + & prof%var(kvar)%vdep, & + & prof%var(kvar)%vobs, & + & prof%var(kvar)%vmod, & + & prof%var(kvar)%nvind, & + & prof%var(kvar)%idqcf, & + & prof%var(kvar)%nvqcf & + & ) + IF (prof%next>0) THEN + DEALLOCATE( & + & prof%var(kvar)%vext & + & ) + ENDIF + + END SUBROUTINE obs_prof_dealloc_var + + SUBROUTINE obs_prof_compress( prof, newprof, lallocate, & + & kumout, lvalid, lvvalid ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_compress *** + !! + !! ** Purpose : - Extract sub-information from a obs_prof type + !! into a new obs_prof type + !! + !! ** Method : - The data is copied from prof to new prof. + !! In the case of lvalid and lvvalid both being + !! present only the selected data will be copied. + !! If lallocate is true the data in the newprof is + !! allocated either with the same number of elements + !! as prof or with only the subset of elements defined + !! by the optional selection in lvalid and lvvalid + !! + !! History : + !! ! 07-01 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_prof), INTENT(IN) :: prof ! Original profile + TYPE(obs_prof), INTENT(INOUT) :: newprof ! New profile with the copy of the data + LOGICAL, INTENT(IN) :: lallocate ! Allocate newprof data + INTEGER,INTENT(IN) :: kumout ! Fortran unit for messages + TYPE(obs_prof_valid), OPTIONAL, INTENT(in) :: & + & lvalid ! Valid profiles + TYPE(obs_prof_valid), OPTIONAL, INTENT(in), DIMENSION(prof%nvar) :: & + & lvvalid ! Valid data within the profiles + + !!* Local variables + INTEGER :: inprof + INTEGER, DIMENSION(prof%nvar) :: & + & invpro + INTEGER :: jvar + INTEGER :: jext + INTEGER :: ji + INTEGER :: jj + LOGICAL :: lfirst + TYPE(obs_prof_valid) :: & + & llvalid + TYPE(obs_prof_valid), DIMENSION(prof%nvar) :: & + & llvvalid + LOGICAL :: lallpresent + LOGICAL :: lnonepresent + + ! Check that either all or none of the masks are persent. + + lallpresent = .FALSE. + lnonepresent = .FALSE. + IF ( PRESENT(lvalid) .AND. PRESENT(lvvalid) ) THEN + lallpresent = .TRUE. + ELSEIF ( ( .NOT. PRESENT(lvalid) ) .AND. & + & ( .NOT. PRESENT(lvvalid) ) ) THEN + lnonepresent = .TRUE. + ELSE + CALL ctl_stop('Error in obs_prof_compress:', & + & 'Either all selection variables should be set', & + & 'or no selection variable should be set' ) + ENDIF + + ! Count how many elements there should be in the new data structure + + IF ( lallpresent ) THEN + inprof = 0 + invpro(:) = 0 + DO ji = 1, prof%nprof + IF ( lvalid%luse(ji) ) THEN + inprof=inprof+1 + DO jvar = 1, prof%nvar + DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar) + IF ( lvvalid(jvar)%luse(jj) ) & + & invpro(jvar) = invpro(jvar) +1 + END DO + END DO + ENDIF + END DO + ELSE + inprof = prof%nprof + invpro(:) = prof%nvprot(:) + ENDIF + + ! Optionally allocate data in the new data structure + + IF ( lallocate ) THEN + CALL obs_prof_alloc( newprof, prof%nvar, & + & prof%next, & + & inprof, invpro, & + & prof%nstp, prof%npi, & + & prof%npj, prof%npk ) + ENDIF + + ! Allocate temporary mask array to unify the code for both cases + + ALLOCATE( llvalid%luse(prof%nprof) ) + DO jvar = 1, prof%nvar + ALLOCATE( llvvalid(jvar)%luse(prof%nvprot(jvar)) ) + END DO + IF ( lallpresent ) THEN + llvalid%luse(:) = lvalid%luse(:) + DO jvar = 1, prof%nvar + llvvalid(jvar)%luse(:) = lvvalid(jvar)%luse(:) + END DO + ELSE + llvalid%luse(:) = .TRUE. + DO jvar = 1, prof%nvar + llvvalid(jvar)%luse(:) = .TRUE. + END DO + ENDIF + + ! Setup bookkeeping variables + + inprof = 0 + invpro(:) = 0 + + newprof%npvsta(:,:) = 0 + newprof%npvend(:,:) = -1 + + ! Loop over source profiles + + DO ji = 1, prof%nprof + + IF ( llvalid%luse(ji) ) THEN + + ! Copy the header information + + inprof = inprof + 1 + + newprof%mi(inprof,:) = prof%mi(ji,:) + newprof%mj(inprof,:) = prof%mj(ji,:) + newprof%npidx(inprof) = prof%npidx(ji) + newprof%npfil(inprof) = prof%npfil(ji) + newprof%nyea(inprof) = prof%nyea(ji) + newprof%nmon(inprof) = prof%nmon(ji) + newprof%nday(inprof) = prof%nday(ji) + newprof%nhou(inprof) = prof%nhou(ji) + newprof%nmin(inprof) = prof%nmin(ji) + newprof%mstp(inprof) = prof%mstp(ji) + newprof%nqc(inprof) = prof%nqc(ji) + newprof%ipqc(inprof) = prof%ipqc(ji) + newprof%itqc(inprof) = prof%itqc(ji) + newprof%ivqc(inprof,:)= prof%ivqc(ji,:) + newprof%ntyp(inprof) = prof%ntyp(ji) + newprof%rlam(inprof) = prof%rlam(ji) + newprof%rphi(inprof) = prof%rphi(ji) + newprof%cwmo(inprof) = prof%cwmo(ji) + + ! QC info + + newprof%nqcf(:,inprof) = prof%nqcf(:,ji) + newprof%ipqcf(:,inprof) = prof%ipqcf(:,ji) + newprof%itqcf(:,inprof) = prof%itqcf(:,ji) + newprof%ivqcf(:,inprof,:) = prof%ivqcf(:,ji,:) + + ! npind is the index of the original profile + + newprof%npind(inprof) = ji + + ! Copy the variable information + + DO jvar = 1, prof%nvar + + lfirst = .TRUE. + + DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar) + + IF ( llvvalid(jvar)%luse(jj) ) THEN + + invpro(jvar) = invpro(jvar) + 1 + + ! Book keeping information + + IF ( lfirst ) THEN + lfirst = .FALSE. + newprof%npvsta(inprof,jvar) = invpro(jvar) + ENDIF + newprof%npvend(inprof,jvar) = invpro(jvar) + + ! Variable data + + newprof%var(jvar)%mvk(invpro(jvar)) = & + & prof%var(jvar)%mvk(jj) + newprof%var(jvar)%nvpidx(invpro(jvar)) = & + & prof%var(jvar)%nvpidx(jj) + newprof%var(jvar)%nvlidx(invpro(jvar)) = & + & prof%var(jvar)%nvlidx(jj) + newprof%var(jvar)%nvqc(invpro(jvar)) = & + & prof%var(jvar)%nvqc(jj) + newprof%var(jvar)%idqc(invpro(jvar)) = & + & prof%var(jvar)%idqc(jj) + newprof%var(jvar)%idqcf(:,invpro(jvar))= & + & prof%var(jvar)%idqcf(:,jj) + newprof%var(jvar)%nvqcf(:,invpro(jvar))= & + & prof%var(jvar)%nvqcf(:,jj) + newprof%var(jvar)%vdep(invpro(jvar)) = & + & prof%var(jvar)%vdep(jj) + newprof%var(jvar)%vobs(invpro(jvar)) = & + & prof%var(jvar)%vobs(jj) + newprof%var(jvar)%vmod(invpro(jvar)) = & + & prof%var(jvar)%vmod(jj) + DO jext = 1, prof%next + newprof%var(jvar)%vext(invpro(jvar),jext) = & + & prof%var(jvar)%vext(jj,jext) + END DO + + ! nvind is the index of the original variable data + + newprof%var(jvar)%nvind(invpro(jvar)) = jj + + ENDIF + + END DO + + END DO + + ENDIF + + END DO + + ! Update MPP counters + + DO jvar = 1, prof%nvar + newprof%nvprot(jvar) = invpro(jvar) + END DO + CALL obs_mpp_sum_integers ( newprof%nvprot, newprof%nvprotmpp,& + & prof%nvar ) + + ! Set book keeping variables which do not depend on number of obs. + + newprof%nvar = prof%nvar + newprof%next = prof%next + newprof%nstp = prof%nstp + newprof%npi = prof%npi + newprof%npj = prof%npj + newprof%npk = prof%npk + newprof%cvars(:) = prof%cvars(:) + + ! Deallocate temporary data + + DO jvar = 1, prof%nvar + DEALLOCATE( llvvalid(jvar)%luse ) + END DO + + DEALLOCATE( llvalid%luse ) + + END SUBROUTINE obs_prof_compress + + SUBROUTINE obs_prof_decompress( prof, oldprof, ldeallocate, kumout ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_decompress *** + !! + !! ** Purpose : - Copy back information to original profile type + !! + !! ** Method : - Reinsert updated information from a previous + !! copied/compressed profile type into the original + !! profile data and optionally deallocate the prof + !! data input + !! + !! History : + !! ! 07-01 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_prof),INTENT(INOUT) :: prof ! Updated profile data + TYPE(obs_prof),INTENT(INOUT) :: oldprof ! Original profile data + LOGICAL, INTENT(IN) :: ldeallocate ! Deallocate the updated data of insertion + INTEGER,INTENT(in) :: kumout ! Output unit + + !!* Local variables + INTEGER :: jvar + INTEGER :: jext + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: jl + + DO ji = 1, prof%nprof + + ! Copy header information + + jk = prof%npind(ji) + + oldprof%mi(jk,:) = prof%mi(ji,:) + oldprof%mj(jk,:) = prof%mj(ji,:) + oldprof%npidx(jk) = prof%npidx(ji) + oldprof%npfil(jk) = prof%npfil(ji) + oldprof%nyea(jk) = prof%nyea(ji) + oldprof%nmon(jk) = prof%nmon(ji) + oldprof%nday(jk) = prof%nday(ji) + oldprof%nhou(jk) = prof%nhou(ji) + oldprof%nmin(jk) = prof%nmin(ji) + oldprof%mstp(jk) = prof%mstp(ji) + oldprof%nqc(jk) = prof%nqc(ji) + oldprof%ipqc(jk) = prof%ipqc(ji) + oldprof%itqc(jk) = prof%itqc(ji) + oldprof%ivqc(jk,:)= prof%ivqc(ji,:) + oldprof%ntyp(jk) = prof%ntyp(ji) + oldprof%rlam(jk) = prof%rlam(ji) + oldprof%rphi(jk) = prof%rphi(ji) + oldprof%cwmo(jk) = prof%cwmo(ji) + + ! QC info + + oldprof%nqcf(:,jk) = prof%nqcf(:,ji) + oldprof%ipqcf(:,jk) = prof%ipqcf(:,ji) + oldprof%itqcf(:,jk) = prof%itqcf(:,ji) + oldprof%ivqcf(:,jk,:) = prof%ivqcf(:,ji,:) + + ! Copy the variable information + + DO jvar = 1, prof%nvar + + DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar) + + jl = prof%var(jvar)%nvind(jj) + + oldprof%var(jvar)%mvk(jl) = prof%var(jvar)%mvk(jj) + oldprof%var(jvar)%nvpidx(jl) = prof%var(jvar)%nvpidx(jj) + oldprof%var(jvar)%nvlidx(jl) = prof%var(jvar)%nvlidx(jj) + oldprof%var(jvar)%nvqc(jl) = prof%var(jvar)%nvqc(jj) + oldprof%var(jvar)%idqc(jl) = prof%var(jvar)%idqc(jj) + oldprof%var(jvar)%vdep(jl) = prof%var(jvar)%vdep(jj) + oldprof%var(jvar)%vobs(jl) = prof%var(jvar)%vobs(jj) + oldprof%var(jvar)%vmod(jl) = prof%var(jvar)%vmod(jj) + oldprof%var(jvar)%idqcf(:,jl) = prof%var(jvar)%idqcf(:,jj) + oldprof%var(jvar)%nvqcf(:,jl) = prof%var(jvar)%nvqcf(:,jj) + DO jext = 1, prof%next + oldprof%var(jvar)%vext(jl,jext) = & + & prof%var(jvar)%vext(jj,jext) + END DO + + END DO + + END DO + + END DO + + ! Optionally deallocate the updated profile data + + IF ( ldeallocate ) CALL obs_prof_dealloc( prof ) + + END SUBROUTINE obs_prof_decompress + + SUBROUTINE obs_prof_staend( prof, kvarno ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_prof_decompress *** + !! + !! ** Purpose : - Set npvsta and npvend of a variable within + !! an obs_prof_var type + !! + !! ** Method : - Find the start and stop of a profile by searching + !! through the data + !! + !! History : + !! ! 07-04 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_prof),INTENT(INOUT) :: prof ! Profile data + INTEGER,INTENT(IN) :: kvarno ! Variable number + + !!* Local variables + INTEGER :: ji + INTEGER :: iprofno + + !----------------------------------------------------------------------- + ! Compute start and end bookkeeping arrays + !----------------------------------------------------------------------- + + prof%npvsta(:,kvarno) = prof%nvprot(kvarno) + 1 + prof%npvend(:,kvarno) = -1 + DO ji = 1, prof%nvprot(kvarno) + iprofno = prof%var(kvarno)%nvpidx(ji) + prof%npvsta(iprofno,kvarno) = & + & MIN( ji, prof%npvsta(iprofno,kvarno) ) + prof%npvend(iprofno,kvarno) = & + & MAX( ji, prof%npvend(iprofno,kvarno) ) + END DO + + DO ji = 1, prof%nprof + IF ( prof%npvsta(ji,kvarno) == ( prof%nvprot(kvarno) + 1 ) ) & + & prof%npvsta(ji,kvarno) = 0 + END DO + + END SUBROUTINE obs_prof_staend + +END MODULE obs_profiles_def \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_read_altbias.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_read_altbias.F90 new file mode 100644 index 0000000..07196c2 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_read_altbias.F90 @@ -0,0 +1,203 @@ +MODULE obs_read_altbias + !!====================================================================== + !! *** MODULE obs_readaltbias *** + !! Observation diagnostics: Read the bias for SLA data + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_rea_altbias : Driver for reading altimeter bias + !!---------------------------------------------------------------------- + + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp, & + & dp, & + & sp + USE par_oce, ONLY : & ! Domain parameters + & jpi, & + & jpj + USE in_out_manager, ONLY : & ! I/O manager + & lwp, & + & numout + USE obs_surf_def ! Surface observation definitions + USE dom_oce, ONLY : & ! Domain variables + & tmask, & + & tmask_i, & + & e1t, & + & e2t, & + & gphit + USE oce, ONLY : & ! Model variables + & ssh + USE obs_inter_h2d + USE obs_utils ! Various observation tools + USE obs_inter_sup + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_rea_altbias ! Read the altimeter bias + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_read_altbias.F90 15033 2021-06-21 10:24:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_rea_altbias( sladata, k2dint, bias_file ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_rea_altbias *** + !! + !! ** Purpose : Read from file the bias data + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! : 2008-02 (D. Lea) Initial version + !!---------------------------------------------------------------------- + !! * Modules used + USE iom + ! + !! * Arguments + TYPE(obs_surf), INTENT(INOUT) :: & + & sladata ! SLA data + INTEGER, INTENT(IN) :: k2dint + CHARACTER(LEN=128) :: bias_file + + !! * Local declarations + + CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_rea_altbias' + + INTEGER :: jobs ! Obs loop variable + INTEGER :: jpialtbias ! Number of grid point in latitude for the bias + INTEGER :: jpjaltbias ! Number of grid point in longitude for the bias + INTEGER :: iico ! Grid point indicies + INTEGER :: ijco + INTEGER :: i_nx_id ! Index to read the NetCDF file + INTEGER :: i_ny_id ! + INTEGER :: i_file_id ! + INTEGER :: i_var_id + + REAL(wp), DIMENSION(1) :: & + & zext, & + & zobsmask + REAL(wp), DIMENSION(2,2,1) :: & + & zweig + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zmask, & + & zbias, & + & zglam, & + & zgphi + REAL(wp), DIMENSION(jpi,jpj) :: z_altbias + REAL(wp) :: zlam + REAL(wp) :: zphi + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & + & igrdi, & + & igrdj + INTEGER :: numaltbias + + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*) ' obs_rea_altbias : ' + IF(lwp)WRITE(numout,*) ' ------------- ' + IF(lwp)WRITE(numout,*) ' Read altimeter bias' + + ! Open the file + + z_altbias(:,:)=0.0_wp + numaltbias=0 + + IF(lwp)WRITE(numout,*) 'Opening ',bias_file + + CALL iom_open( bias_file, numaltbias, ldstop=.FALSE. ) + + + IF (numaltbias .GT. 0) THEN + + ! Get the Alt bias data + + CALL iom_get( numaltbias, jpdom_global, 'altbias', z_altbias(:,:) ) + + ! Close the file + + CALL iom_close(numaltbias) + + ELSE + + IF(lwp)WRITE(numout,*) 'no file found' + + ENDIF + + ! Intepolate the bias already on the model grid at the observation point + + ALLOCATE( & + & igrdi(2,2,sladata%nsurf), & + & igrdj(2,2,sladata%nsurf), & + & zglam(2,2,sladata%nsurf), & + & zgphi(2,2,sladata%nsurf), & + & zmask(2,2,sladata%nsurf), & + & zbias(2,2,sladata%nsurf) & + & ) + + DO jobs = 1, sladata%nsurf + + igrdi(1,1,jobs) = sladata%mi(jobs)-1 + igrdj(1,1,jobs) = sladata%mj(jobs)-1 + igrdi(1,2,jobs) = sladata%mi(jobs)-1 + igrdj(1,2,jobs) = sladata%mj(jobs) + igrdi(2,1,jobs) = sladata%mi(jobs) + igrdj(2,1,jobs) = sladata%mj(jobs)-1 + igrdi(2,2,jobs) = sladata%mi(jobs) + igrdj(2,2,jobs) = sladata%mj(jobs) + + END DO + + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & + & igrdi, igrdj, glamt, zglam ) + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & + & igrdi, igrdj, gphit, zgphi ) + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & + & igrdi, igrdj, tmask(:,:,1), zmask ) + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & + & igrdi, igrdj, z_altbias, zbias ) + + DO jobs = 1, sladata%nsurf + + zlam = sladata%rlam(jobs) + zphi = sladata%rphi(jobs) + iico = sladata%mi(jobs) + ijco = sladata%mj(jobs) + + CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & + & zglam(:,:,jobs), zgphi(:,:,jobs), & + & zmask(:,:,jobs), zweig, zobsmask ) + + CALL obs_int_h2d( 1, 1, & + & zweig, zbias(:,:,jobs), zext ) + + ! adjust mdt with bias field + sladata%rext(jobs,2) = sladata%rext(jobs,2) - zext(1) + + END DO + + DEALLOCATE( & + & igrdi, & + & igrdj, & + & zglam, & + & zgphi, & + & zmask, & + & zbias & + & ) + + END SUBROUTINE obs_rea_altbias + + + +END MODULE obs_read_altbias \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_read_prof.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_read_prof.F90 new file mode 100644 index 0000000..22fefe1 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_read_prof.F90 @@ -0,0 +1,824 @@ +MODULE obs_read_prof + !!====================================================================== + !! *** MODULE obs_read_prof *** + !! Observation diagnostics: Read the T and S profile observations + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_rea_pro_dri : Driver for reading profile obs + !!---------------------------------------------------------------------- + + !! * Modules used + USE par_kind ! Precision variables + USE par_oce ! Ocean parameters + USE in_out_manager ! I/O manager + USE dom_oce ! Ocean space and time domain variables + USE obs_mpp ! MPP support routines for observation diagnostics + USE julian ! Julian date routines + USE obs_utils ! Observation operator utility functions + USE obs_prep ! Prepare observation arrays + USE obs_grid ! Grid search + USE obs_sort ! Sorting observation arrays + USE obs_profiles_def ! Profile definitions + USE obs_conv ! Various conversion routines + USE obs_types ! Observation type definitions + USE netcdf ! NetCDF library + USE obs_oper ! Observation operators + USE lib_mpp ! For ctl_warn/stop + USE obs_fbm ! Feedback routines + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_rea_prof ! Read the profile observations + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_read_prof.F90 14275 2021-01-07 12:13:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_rea_prof( profdata, knumfiles, cdfilenames, & + & kvars, kextr, kstp, ddobsini, ddobsend, & + & ldvar, ldignmis, ldsatt, & + & ldmod, cdvars, kdailyavtypes ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_rea_prof *** + !! + !! ** Purpose : Read from file the profile observations + !! + !! ** Method : Read feedback data in and transform to NEMO internal + !! profile data structure + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! : 2009-09 (K. Mogensen) : New merged version of old routines + !! ! : 2015-08 (M. Martin) : Merged profile and velocity routines + !!---------------------------------------------------------------------- + + !! * Arguments + TYPE(obs_prof), INTENT(OUT) :: & + & profdata ! Profile data to be read + INTEGER, INTENT(IN) :: knumfiles ! Number of files to read + CHARACTER(LEN=128), INTENT(IN) :: & + & cdfilenames(knumfiles) ! File names to read in + INTEGER, INTENT(IN) :: kvars ! Number of variables in profdata + INTEGER, INTENT(IN) :: kextr ! Number of extra fields for each var + INTEGER, INTENT(IN) :: kstp ! Ocean time-step index + LOGICAL, DIMENSION(kvars), INTENT(IN) :: ldvar ! Observed variables switches + LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files + LOGICAL, INTENT(IN) :: ldsatt ! Compute salinity at all temperature points + LOGICAL, INTENT(IN) :: ldmod ! Initialize model from input data + REAL(wp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS + REAL(wp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS + CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars + INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & + & kdailyavtypes ! Types of daily average observations + + !! * Local declarations + CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_prof' + CHARACTER(len=8) :: clrefdate + CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvarsin + INTEGER :: jvar + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: ij + INTEGER :: iflag + INTEGER :: inobf + INTEGER :: i_file_id + INTEGER :: inowin + INTEGER :: iyea + INTEGER :: imon + INTEGER :: iday + INTEGER :: ihou + INTEGER :: imin + INTEGER :: isec + INTEGER :: iprof + INTEGER :: iproftot + INTEGER, DIMENSION(kvars) :: ivart0 + INTEGER, DIMENSION(kvars) :: ivart + INTEGER :: ip3dt + INTEGER :: ios + INTEGER :: ioserrcount + INTEGER, DIMENSION(kvars) :: ivartmpp + INTEGER :: ip3dtmpp + INTEGER :: itype + INTEGER, DIMENSION(knumfiles) :: & + & irefdate + INTEGER, DIMENSION(ntyp1770+1,kvars) :: & + & itypvar, & + & itypvarmpp + INTEGER, DIMENSION(:,:), ALLOCATABLE :: & + & iobsi, & + & iobsj, & + & iproc + INTEGER, DIMENSION(:), ALLOCATABLE :: & + & iindx, & + & ifileidx, & + & iprofidx + INTEGER, DIMENSION(imaxavtypes) :: & + & idailyavtypes + INTEGER, DIMENSION(kvars) :: & + & iv3dt + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zphi, & + & zlam + REAL(dp), DIMENSION(:), ALLOCATABLE :: & + & zdat + REAL(dp), DIMENSION(knumfiles) :: & + & djulini, & + & djulend + LOGICAL :: llvalprof + LOGICAL :: lldavtimset + LOGICAL :: llcycle + TYPE(obfbdata), POINTER, DIMENSION(:) :: & + & inpfiles + + ! Local initialization + iprof = 0 + ivart0(:) = 0 + ip3dt = 0 + + ! Daily average types + lldavtimset = .FALSE. + IF ( PRESENT(kdailyavtypes) ) THEN + idailyavtypes(:) = kdailyavtypes(:) + IF ( ANY (idailyavtypes(:) /= -1) ) lldavtimset = .TRUE. + ELSE + idailyavtypes(:) = -1 + ENDIF + + !----------------------------------------------------------------------- + ! Count the number of files needed and allocate the obfbdata type + !----------------------------------------------------------------------- + + inobf = knumfiles + + ALLOCATE( inpfiles(inobf) ) + + prof_files : DO jj = 1, inobf + + !--------------------------------------------------------------------- + ! Prints + !--------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' obs_rea_pro_dri : Reading from file = ', & + & TRIM( TRIM( cdfilenames(jj) ) ) + WRITE(numout,*) ' ~~~~~~~~~~~~~~~' + WRITE(numout,*) + ENDIF + + !--------------------------------------------------------------------- + ! Initialization: Open file and get dimensions only + !--------------------------------------------------------------------- + + iflag = nf90_open( TRIM( cdfilenames(jj) ), nf90_nowrite, & + & i_file_id ) + + IF ( iflag /= nf90_noerr ) THEN + + IF ( ldignmis ) THEN + inpfiles(jj)%nobs = 0 + CALL ctl_warn( 'File ' // TRIM( cdfilenames(jj) ) // & + & ' not found' ) + ELSE + CALL ctl_stop( 'File ' // TRIM( cdfilenames(jj) ) // & + & ' not found' ) + ENDIF + + ELSE + + !------------------------------------------------------------------ + ! Close the file since it is opened in read_obfbdata + !------------------------------------------------------------------ + + iflag = nf90_close( i_file_id ) + + !------------------------------------------------------------------ + ! Read the profile file into inpfiles + !------------------------------------------------------------------ + CALL init_obfbdata( inpfiles(jj) ) + CALL read_obfbdata( TRIM( cdfilenames(jj) ), inpfiles(jj), & + & ldgrid = .TRUE. ) + + IF ( inpfiles(jj)%nvar /= kvars ) THEN + CALL ctl_stop( 'Feedback format error: ', & + & ' unexpected number of vars in profile file' ) + ENDIF + + IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN + CALL ctl_stop( 'Model not in input data' ) + ENDIF + + IF ( jj == 1 ) THEN + ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) + DO ji = 1, inpfiles(jj)%nvar + clvarsin(ji) = inpfiles(jj)%cname(ji) + IF ( clvarsin(ji) /= cdvars(ji) ) THEN + CALL ctl_stop( 'Feedback file variables do not match', & + & ' expected variable names for this type' ) + ENDIF + END DO + ELSE + DO ji = 1, inpfiles(jj)%nvar + IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN + CALL ctl_stop( 'Feedback file variables not consistent', & + & ' with previous files for this type' ) + ENDIF + END DO + ENDIF + + !------------------------------------------------------------------ + ! Change longitude (-180,180) + !------------------------------------------------------------------ + + DO ji = 1, inpfiles(jj)%nobs + + IF ( inpfiles(jj)%plam(ji) < -180. ) & + & inpfiles(jj)%plam(ji) = inpfiles(jj)%plam(ji) + 360. + + IF ( inpfiles(jj)%plam(ji) > 180. ) & + & inpfiles(jj)%plam(ji) = inpfiles(jj)%plam(ji) - 360. + + END DO + + !------------------------------------------------------------------ + ! Calculate the date (change eventually) + !------------------------------------------------------------------ + clrefdate=inpfiles(jj)%cdjuldref(1:8) + READ(clrefdate,'(I8)') irefdate(jj) + + CALL ddatetoymdhms( ddobsini, iyea, imon, iday, ihou, imin, isec ) + CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulini(jj), & + & krefdate = irefdate(jj) ) + CALL ddatetoymdhms( ddobsend, iyea, imon, iday, ihou, imin, isec ) + CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulend(jj), & + & krefdate = irefdate(jj) ) + + ioserrcount=0 + IF ( lldavtimset ) THEN + + IF ( ANY ( idailyavtypes(:) /= -1 ) .AND. lwp) THEN + WRITE(numout,*)' Resetting time of daily averaged', & + & ' observations to the end of the day' + ENDIF + + DO ji = 1, inpfiles(jj)%nobs + READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 900 ) itype +900 IF ( ios /= 0 ) THEN + ! Set type to zero if there is a problem in the string conversion + itype = 0 + ENDIF + + IF ( ANY ( idailyavtypes(:) == itype ) ) THEN + ! for daily averaged data force the time + ! to be the last time-step of the day, but still within the day. + IF ( inpfiles(jj)%ptim(ji) >= 0. ) THEN + inpfiles(jj)%ptim(ji) = & + & INT(inpfiles(jj)%ptim(ji)) + 0.9999 + ELSE + inpfiles(jj)%ptim(ji) = & + & INT(inpfiles(jj)%ptim(ji)) - 0.0001 + ENDIF + ENDIF + + END DO + + ENDIF + + IF ( inpfiles(jj)%nobs > 0 ) THEN + inpfiles(jj)%iproc(:,:) = -1 + inpfiles(jj)%iobsi(:,:) = -1 + inpfiles(jj)%iobsj(:,:) = -1 + ENDIF + inowin = 0 + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + inowin = inowin + 1 + ENDIF + END DO + ALLOCATE( zlam(inowin) ) + ALLOCATE( zphi(inowin) ) + ALLOCATE( iobsi(inowin,kvars) ) + ALLOCATE( iobsj(inowin,kvars) ) + ALLOCATE( iproc(inowin,kvars) ) + inowin = 0 + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + inowin = inowin + 1 + zlam(inowin) = inpfiles(jj)%plam(ji) + zphi(inowin) = inpfiles(jj)%pphi(ji) + ENDIF + END DO + + ! Assume anything other than velocity is on T grid + IF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN + CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & + & iproc(:,1), 'U' ) + CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,2), iobsj(:,2), & + & iproc(:,2), 'V' ) + ELSE + CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & + & iproc(:,1), 'T' ) + IF ( kvars > 1 ) THEN + DO jvar = 2, kvars + iobsi(:,jvar) = iobsi(:,1) + iobsj(:,jvar) = iobsj(:,1) + iproc(:,jvar) = iproc(:,1) + END DO + ENDIF + ENDIF + + inowin = 0 + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + inowin = inowin + 1 + DO jvar = 1, kvars + inpfiles(jj)%iproc(ji,jvar) = iproc(inowin,jvar) + inpfiles(jj)%iobsi(ji,jvar) = iobsi(inowin,jvar) + inpfiles(jj)%iobsj(ji,jvar) = iobsj(inowin,jvar) + END DO + IF ( kvars > 1 ) THEN + DO jvar = 2, kvars + IF ( inpfiles(jj)%iproc(ji,jvar) /= & + & inpfiles(jj)%iproc(ji,1) ) THEN + CALL ctl_stop( 'Error in obs_read_prof:', & + & 'observation on different processors for different vars') + ENDIF + END DO + ENDIF + ENDIF + END DO + DEALLOCATE( zlam, zphi, iobsi, iobsj, iproc ) + + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + IF ( narea == 1 ) THEN + IF ( inpfiles(jj)%iproc(ji,1) > narea-1 ) CYCLE + ELSE + IF ( inpfiles(jj)%iproc(ji,1) /= narea-1 ) CYCLE + ENDIF + llvalprof = .FALSE. + DO jvar = 1, kvars + IF ( ldvar(jvar) ) THEN + DO ij = 1,inpfiles(jj)%nlev + IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & + & CYCLE + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN + ivart0(jvar) = ivart0(jvar) + 1 + ENDIF + END DO + ENDIF + END DO + DO ij = 1,inpfiles(jj)%nlev + IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & + & CYCLE + DO jvar = 1, kvars + IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & + & ldvar(jvar) ) ) THEN + ip3dt = ip3dt + 1 + llvalprof = .TRUE. + EXIT + ENDIF + END DO + END DO + + IF ( llvalprof ) iprof = iprof + 1 + + ENDIF + END DO + + ENDIF + + END DO prof_files + + !----------------------------------------------------------------------- + ! Get the time ordered indices of the input data + !----------------------------------------------------------------------- + + !--------------------------------------------------------------------- + ! Loop over input data files to count total number of profiles + !--------------------------------------------------------------------- + iproftot = 0 + DO jj = 1, inobf + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + iproftot = iproftot + 1 + ENDIF + END DO + END DO + + ALLOCATE( iindx(iproftot), ifileidx(iproftot), & + & iprofidx(iproftot), zdat(iproftot) ) + jk = 0 + DO jj = 1, inobf + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + jk = jk + 1 + ifileidx(jk) = jj + iprofidx(jk) = ji + zdat(jk) = inpfiles(jj)%ptim(ji) + ENDIF + END DO + END DO + CALL sort_dp_indx( iproftot, & + & zdat, & + & iindx ) + + iv3dt(:) = -1 + IF (ldsatt) THEN + iv3dt(:) = ip3dt + ELSE + iv3dt(:) = ivart0(:) + ENDIF + CALL obs_prof_alloc( profdata, kvars, kextr, iprof, iv3dt, & + & kstp, jpi, jpj, jpk ) + + ! * Read obs/positions, QC, all variable and assign to profdata + + profdata%nprof = 0 + profdata%nvprot(:) = 0 + profdata%cvars(:) = clvarsin(:) + iprof = 0 + + ip3dt = 0 + ivart(:) = 0 + itypvar (:,:) = 0 + itypvarmpp(:,:) = 0 + + ioserrcount = 0 + DO jk = 1, iproftot + + jj = ifileidx(iindx(jk)) + ji = iprofidx(iindx(jk)) + + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + + IF ( narea == 1 ) THEN + IF ( inpfiles(jj)%iproc(ji,1) > narea-1 ) CYCLE + ELSE + IF ( inpfiles(jj)%iproc(ji,1) /= narea-1 ) CYCLE + ENDIF + + llvalprof = .FALSE. + + IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE + + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + llcycle = .TRUE. + DO jvar = 1, kvars + IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN + llcycle = .FALSE. + EXIT + ENDIF + END DO + IF ( llcycle ) CYCLE + + loop_prof : DO ij = 1, inpfiles(jj)%nlev + + IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & + & CYCLE + + DO jvar = 1, kvars + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN + + llvalprof = .TRUE. + EXIT loop_prof + + ENDIF + END DO + + END DO loop_prof + + ! Set profile information + + IF ( llvalprof ) THEN + + iprof = iprof + 1 + + CALL jul2greg( isec, & + & imin, & + & ihou, & + & iday, & + & imon, & + & iyea, & + & inpfiles(jj)%ptim(ji), & + & irefdate(jj) ) + + + ! Profile time coordinates + profdata%nyea(iprof) = iyea + profdata%nmon(iprof) = imon + profdata%nday(iprof) = iday + profdata%nhou(iprof) = ihou + profdata%nmin(iprof) = imin + + ! Profile space coordinates + profdata%rlam(iprof) = inpfiles(jj)%plam(ji) + profdata%rphi(iprof) = inpfiles(jj)%pphi(ji) + + ! Coordinate search parameters + DO jvar = 1, kvars + profdata%mi (iprof,jvar) = inpfiles(jj)%iobsi(ji,jvar) + profdata%mj (iprof,jvar) = inpfiles(jj)%iobsj(ji,jvar) + END DO + + ! Profile WMO number + profdata%cwmo(iprof) = inpfiles(jj)%cdwmo(ji) + + ! Instrument type + READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 901 ) itype +901 IF ( ios /= 0 ) THEN + IF (ioserrcount == 0) CALL ctl_warn ( 'Problem converting an instrument type to integer. Setting type to zero' ) + ioserrcount = ioserrcount + 1 + itype = 0 + ENDIF + + profdata%ntyp(iprof) = itype + + ! QC stuff + + profdata%nqc(iprof) = inpfiles(jj)%ioqc(ji) + profdata%nqcf(:,iprof) = inpfiles(jj)%ioqcf(:,ji) + profdata%ipqc(iprof) = inpfiles(jj)%ipqc(ji) + profdata%ipqcf(:,iprof) = inpfiles(jj)%ipqcf(:,ji) + profdata%itqc(iprof) = inpfiles(jj)%itqc(ji) + profdata%itqcf(:,iprof) = inpfiles(jj)%itqcf(:,ji) + profdata%ivqc(iprof,:) = inpfiles(jj)%ivqc(ji,:) + profdata%ivqcf(:,iprof,:) = inpfiles(jj)%ivqcf(:,ji,:) + + ! Bookkeeping data to match profiles + profdata%npidx(iprof) = iprof + profdata%npfil(iprof) = iindx(jk) + + ! Observation QC flag (whole profile) + profdata%nqc(iprof) = 0 !TODO + + loop_p : DO ij = 1, inpfiles(jj)%nlev + + IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & + & CYCLE + + IF (ldsatt) THEN + + DO jvar = 1, kvars + IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & + & ldvar(jvar) ) ) THEN + ip3dt = ip3dt + 1 + EXIT + ELSE IF ( jvar == kvars ) THEN + CYCLE loop_p + ENDIF + END DO + + ENDIF + + DO jvar = 1, kvars + + IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & + & ldvar(jvar) ) .OR. ldsatt ) THEN + + IF (ldsatt) THEN + + ivart(jvar) = ip3dt + + ELSE + + ivart(jvar) = ivart(jvar) + 1 + + ENDIF + + ! Depth of jvar observation + profdata%var(jvar)%vdep(ivart(jvar)) = & + & inpfiles(jj)%pdep(ij,ji) + + ! Depth of jvar observation QC + profdata%var(jvar)%idqc(ivart(jvar)) = & + & inpfiles(jj)%idqc(ij,ji) + + ! Depth of jvar observation QC flags + profdata%var(jvar)%idqcf(:,ivart(jvar)) = & + & inpfiles(jj)%idqcf(:,ij,ji) + + ! Profile index + profdata%var(jvar)%nvpidx(ivart(jvar)) = iprof + + ! Vertical index in original profile + profdata%var(jvar)%nvlidx(ivart(jvar)) = ij + + ! Profile jvar value + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN + profdata%var(jvar)%vobs(ivart(jvar)) = & + & inpfiles(jj)%pob(ij,ji,jvar) + IF ( ldmod ) THEN + profdata%var(jvar)%vmod(ivart(jvar)) = & + & inpfiles(jj)%padd(ij,ji,1,jvar) + ENDIF + ! Count number of profile var1 data as function of type + itypvar( profdata%ntyp(iprof) + 1, jvar ) = & + & itypvar( profdata%ntyp(iprof) + 1, jvar ) + 1 + ELSE + profdata%var(jvar)%vobs(ivart(jvar)) = fbrmdi + ENDIF + + ! Profile jvar qc + profdata%var(jvar)%nvqc(ivart(jvar)) = & + & inpfiles(jj)%ivlqc(ij,ji,jvar) + + ! Profile jvar qc flags + profdata%var(jvar)%nvqcf(:,ivart(jvar)) = & + & inpfiles(jj)%ivlqcf(:,ij,ji,jvar) + + ! Profile insitu T value + IF ( TRIM( inpfiles(jj)%cname(jvar) ) == 'POTM' ) THEN + profdata%var(jvar)%vext(ivart(jvar),1) = & + & inpfiles(jj)%pext(ij,ji,1) + ENDIF + + ENDIF + + END DO + + END DO loop_p + + ENDIF + + ENDIF + + END DO + + !----------------------------------------------------------------------- + ! Sum up over processors + !----------------------------------------------------------------------- + + DO jvar = 1, kvars + CALL obs_mpp_sum_integer ( ivart0(jvar), ivartmpp(jvar) ) + END DO + CALL obs_mpp_sum_integer ( ip3dt, ip3dtmpp ) + + DO jvar = 1, kvars + CALL obs_mpp_sum_integers( itypvar(:,jvar), itypvarmpp(:,jvar), ntyp1770 + 1 ) + END DO + + !----------------------------------------------------------------------- + ! Output number of observations. + !----------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,'(A)') ' Profile data' + WRITE(numout,'(1X,A)') '------------' + WRITE(numout,*) + DO jvar = 1, kvars + WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(jvar) ) + WRITE(numout,'(1X,A)') '------------------------' + DO ji = 0, ntyp1770 + IF ( itypvarmpp(ji+1,jvar) > 0 ) THEN + WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & + & cwmonam1770(ji)(1:52),' = ', & + & itypvarmpp(ji+1,jvar) + ENDIF + END DO + WRITE(numout,'(1X,A)') & + & '---------------------------------------------------------------' + WRITE(numout,'(1X,A55,I8)') & + & 'Total profile data for variable '//TRIM( profdata%cvars(jvar) )// & + & ' = ', ivartmpp(jvar) + WRITE(numout,'(1X,A)') & + & '---------------------------------------------------------------' + WRITE(numout,*) + END DO + ENDIF + + IF (ldsatt) THEN + profdata%nvprot(:) = ip3dt + profdata%nvprotmpp(:) = ip3dtmpp + ELSE + DO jvar = 1, kvars + profdata%nvprot(jvar) = ivart(jvar) + profdata%nvprotmpp(jvar) = ivartmpp(jvar) + END DO + ENDIF + profdata%nprof = iprof + + !----------------------------------------------------------------------- + ! Model level search + !----------------------------------------------------------------------- + DO jvar = 1, kvars + IF ( ldvar(jvar) ) THEN + CALL obs_level_search( jpk, gdept_1d, & + & profdata%nvprot(jvar), profdata%var(jvar)%vdep, & + & profdata%var(jvar)%mvk ) + ENDIF + END DO + + !----------------------------------------------------------------------- + ! Set model equivalent to 99999 + !----------------------------------------------------------------------- + IF ( .NOT. ldmod ) THEN + DO jvar = 1, kvars + profdata%var(jvar)%vmod(:) = fbrmdi + END DO + ENDIF + !----------------------------------------------------------------------- + ! Deallocate temporary data + !----------------------------------------------------------------------- + DEALLOCATE( ifileidx, iprofidx, zdat, clvarsin ) + + !----------------------------------------------------------------------- + ! Deallocate input data + !----------------------------------------------------------------------- + DO jj = 1, inobf + CALL dealloc_obfbdata( inpfiles(jj) ) + END DO + DEALLOCATE( inpfiles ) + + END SUBROUTINE obs_rea_prof + +END MODULE obs_read_prof \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_read_surf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_read_surf.F90 new file mode 100644 index 0000000..82b4992 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_read_surf.F90 @@ -0,0 +1,506 @@ +MODULE obs_read_surf + !!====================================================================== + !! *** MODULE obs_read_surf *** + !! Observation diagnostics: Read the surface data from feedback files + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_rea_surf : Driver for reading surface data from feedback files + !!---------------------------------------------------------------------- + + !! * Modules used + USE par_kind ! Precision variables + USE in_out_manager ! I/O manager + USE dom_oce ! Ocean space and time domain variables + USE obs_mpp ! MPP support routines for observation diagnostics + USE julian ! Julian date routines + USE obs_utils ! Observation operator utility functions + USE obs_grid ! Grid search + USE obs_sort ! Sorting observation arrays + USE obs_surf_def ! Surface observation definitions + USE obs_types ! Observation type definitions + USE obs_fbm ! Feedback routines + USE netcdf ! NetCDF library + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_rea_surf ! Read the surface observations from the point data + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_read_surf.F90 14275 2021-01-07 12:13:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_rea_surf( surfdata, knumfiles, cdfilenames, & + & kvars, kextr, kstp, ddobsini, ddobsend, & + & ldignmis, ldmod, ldnightav, cdvars ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_rea_surf *** + !! + !! ** Purpose : Read from file the surface data + !! + !! ** Method : Read in the data from feedback format files and + !! put into the NEMO internal surface data structure + !! + !! ** Action : + !! + !! + !! History : + !! ! : 2009-01 (K. Mogensen) Initial version based on old versions + !! ! : 2015-02 (M. Martin) Unify the different surface data type reading. + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + TYPE(obs_surf), INTENT(INOUT) :: & + & surfdata ! Surface data to be read + INTEGER, INTENT(IN) :: knumfiles ! Number of corio format files to read + CHARACTER(LEN=128), INTENT(IN) :: & + & cdfilenames(knumfiles) ! File names to read in + INTEGER, INTENT(IN) :: kvars ! Number of variables in surfdata + INTEGER, INTENT(IN) :: kextr ! Number of extra fields for each var + INTEGER, INTENT(IN) :: kstp ! Ocean time-step index + LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files + LOGICAL, INTENT(IN) :: ldmod ! Initialize model from input data + LOGICAL, INTENT(IN) :: ldnightav ! Observations represent a night-time average + REAL(wp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS + REAL(wp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS + CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars + + !! * Local declarations + CHARACTER(LEN=11), PARAMETER :: cpname='obs_rea_surf' + CHARACTER(len=8) :: clrefdate + CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvarsin + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + INTEGER :: iflag + INTEGER :: inobf + INTEGER :: i_file_id + INTEGER :: inowin + INTEGER :: iyea + INTEGER :: imon + INTEGER :: iday + INTEGER :: ihou + INTEGER :: imin + INTEGER :: isec + INTEGER :: itype + INTEGER :: iobsmpp + INTEGER :: iobs + INTEGER :: iobstot + INTEGER :: ios + INTEGER :: ioserrcount + INTEGER, PARAMETER :: jpsurfmaxtype = 1024 + INTEGER, DIMENSION(knumfiles) :: irefdate + INTEGER, DIMENSION(jpsurfmaxtype+1) :: & + & ityp, & + & itypmpp + INTEGER, DIMENSION(:), ALLOCATABLE :: & + & iobsi, & + & iobsj, & + & iproc, & + & iindx, & + & ifileidx, & + & isurfidx + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zphi, & + & zlam + REAL(dp), DIMENSION(:), ALLOCATABLE :: & + & zdat + REAL(dp), DIMENSION(knumfiles) :: & + & djulini, & + & djulend + LOGICAL :: llvalprof + TYPE(obfbdata), POINTER, DIMENSION(:) :: & + & inpfiles + + ! Local initialization + iobs = 0 + + !----------------------------------------------------------------------- + ! Count the number of files needed and allocate the obfbdata type + !----------------------------------------------------------------------- + + inobf = knumfiles + + ALLOCATE( inpfiles(inobf) ) + + surf_files : DO jj = 1, inobf + + !--------------------------------------------------------------------- + ! Prints + !--------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' obs_rea_surf : Reading from file = ', & + & TRIM( TRIM( cdfilenames(jj) ) ) + WRITE(numout,*) ' ~~~~~~~~~~~' + WRITE(numout,*) + ENDIF + + !--------------------------------------------------------------------- + ! Initialization: Open file and get dimensions only + !--------------------------------------------------------------------- + + iflag = nf90_open( TRIM( TRIM( cdfilenames(jj) ) ), nf90_nowrite, & + & i_file_id ) + + IF ( iflag /= nf90_noerr ) THEN + + IF ( ldignmis ) THEN + inpfiles(jj)%nobs = 0 + CALL ctl_warn( 'File ' // TRIM( TRIM( cdfilenames(jj) ) ) // & + & ' not found' ) + ELSE + CALL ctl_stop( 'File ' // TRIM( TRIM( cdfilenames(jj) ) ) // & + & ' not found' ) + ENDIF + + ELSE + + !------------------------------------------------------------------ + ! Close the file since it is opened in read_obfbdata + !------------------------------------------------------------------ + + iflag = nf90_close( i_file_id ) + + !------------------------------------------------------------------ + ! Read the surface file into inpfiles + !------------------------------------------------------------------ + CALL init_obfbdata( inpfiles(jj) ) + CALL read_obfbdata( TRIM( cdfilenames(jj) ), inpfiles(jj), & + & ldgrid = .TRUE. ) + + IF ( inpfiles(jj)%nvar /= kvars ) THEN + CALL ctl_stop( 'Feedback format error: ', & + & ' unexpected number of vars in feedback file' ) + ENDIF + + IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN + CALL ctl_stop( 'Model not in input data' ) + RETURN + ENDIF + + IF ( jj == 1 ) THEN + ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) + DO ji = 1, inpfiles(jj)%nvar + clvarsin(ji) = inpfiles(jj)%cname(ji) + IF ( clvarsin(ji) /= cdvars(ji) ) THEN + CALL ctl_stop( 'Feedback file variables do not match', & + & ' expected variable names for this type' ) + ENDIF + END DO + ELSE + DO ji = 1, inpfiles(jj)%nvar + IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN + CALL ctl_stop( 'Feedback file variables not consistent', & + & ' with previous files for this type' ) + ENDIF + END DO + ENDIF + + IF (lwp) WRITE(numout,*)'Observation file contains ',inpfiles(jj)%nobs,' observations' + + !------------------------------------------------------------------ + ! Change longitude (-180,180) + !------------------------------------------------------------------ + + DO ji = 1, inpfiles(jj)%nobs + + IF ( inpfiles(jj)%plam(ji) < -180. ) & + & inpfiles(jj)%plam(ji) = inpfiles(jj)%plam(ji) + 360. + + IF ( inpfiles(jj)%plam(ji) > 180. ) & + & inpfiles(jj)%plam(ji) = inpfiles(jj)%plam(ji) - 360. + + END DO + + !------------------------------------------------------------------ + ! Calculate the date (change eventually) + !------------------------------------------------------------------ + clrefdate=inpfiles(jj)%cdjuldref(1:8) + READ(clrefdate,'(I8)') irefdate(jj) + + CALL ddatetoymdhms( ddobsini, iyea, imon, iday, ihou, imin, isec ) + CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulini(jj), & + & krefdate = irefdate(jj) ) + CALL ddatetoymdhms( ddobsend, iyea, imon, iday, ihou, imin, isec ) + CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulend(jj), & + & krefdate = irefdate(jj) ) + + IF ( ldnightav ) THEN + + IF ( lwp ) THEN + WRITE(numout,*)'Resetting time of night-time averaged observations', & + & ' to the end of the day' + ENDIF + + DO ji = 1, inpfiles(jj)%nobs + ! for night-time averaged data force the time + ! to be the last time-step of the day, but still within the day. + IF ( inpfiles(jj)%ptim(ji) >= 0. ) THEN + inpfiles(jj)%ptim(ji) = & + & INT(inpfiles(jj)%ptim(ji)) + 0.9999 + ELSE + inpfiles(jj)%ptim(ji) = & + & INT(inpfiles(jj)%ptim(ji)) - 0.0001 + ENDIF + END DO + ENDIF + + IF ( inpfiles(jj)%nobs > 0 ) THEN + inpfiles(jj)%iproc = -1 + inpfiles(jj)%iobsi = -1 + inpfiles(jj)%iobsj = -1 + ENDIF + inowin = 0 + DO ji = 1, inpfiles(jj)%nobs + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + inowin = inowin + 1 + ENDIF + END DO + ALLOCATE( zlam(inowin) ) + ALLOCATE( zphi(inowin) ) + ALLOCATE( iobsi(inowin) ) + ALLOCATE( iobsj(inowin) ) + ALLOCATE( iproc(inowin) ) + inowin = 0 + DO ji = 1, inpfiles(jj)%nobs + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + inowin = inowin + 1 + zlam(inowin) = inpfiles(jj)%plam(ji) + zphi(inowin) = inpfiles(jj)%pphi(ji) + ENDIF + END DO + + CALL obs_grid_search( inowin, zlam, zphi, iobsi, iobsj, iproc, 'T' ) + + inowin = 0 + DO ji = 1, inpfiles(jj)%nobs + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + inowin = inowin + 1 + inpfiles(jj)%iproc(ji,1) = iproc(inowin) + inpfiles(jj)%iobsi(ji,1) = iobsi(inowin) + inpfiles(jj)%iobsj(ji,1) = iobsj(inowin) + ENDIF + END DO + DEALLOCATE( zlam, zphi, iobsi, iobsj, iproc ) + + DO ji = 1, inpfiles(jj)%nobs + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + IF ( narea == 1 ) THEN + IF ( inpfiles(jj)%iproc(ji,1) > narea-1 ) CYCLE + ELSE + IF ( inpfiles(jj)%iproc(ji,1) /= narea-1 ) CYCLE + ENDIF + llvalprof = .FALSE. + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(1,ji,1),2) ) THEN + iobs = iobs + 1 + ENDIF + ENDIF + END DO + + ENDIF + + END DO surf_files + + !----------------------------------------------------------------------- + ! Get the time ordered indices of the input data + !----------------------------------------------------------------------- + + !--------------------------------------------------------------------- + ! Loop over input data files to count total number of profiles + !--------------------------------------------------------------------- + iobstot = 0 + DO jj = 1, inobf + DO ji = 1, inpfiles(jj)%nobs + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + iobstot = iobstot + 1 + ENDIF + END DO + END DO + + ALLOCATE( iindx(iobstot), ifileidx(iobstot), & + & isurfidx(iobstot), zdat(iobstot) ) + jk = 0 + DO jj = 1, inobf + DO ji = 1, inpfiles(jj)%nobs + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + jk = jk + 1 + ifileidx(jk) = jj + isurfidx(jk) = ji + zdat(jk) = inpfiles(jj)%ptim(ji) + ENDIF + END DO + END DO + CALL sort_dp_indx( iobstot, & + & zdat, & + & iindx ) + + CALL obs_surf_alloc( surfdata, iobs, kvars, kextr, kstp, jpi, jpj ) + + ! Read obs/positions, QC, all variable and assign to surfdata + + iobs = 0 + + surfdata%cvars(:) = clvarsin(:) + + ityp (:) = 0 + itypmpp(:) = 0 + + ioserrcount = 0 + + DO jk = 1, iobstot + + jj = ifileidx(iindx(jk)) + ji = isurfidx(iindx(jk)) + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + + IF ( narea == 1 ) THEN + IF ( inpfiles(jj)%iproc(ji,1) > narea-1 ) CYCLE + ELSE + IF ( inpfiles(jj)%iproc(ji,1) /= narea-1 ) CYCLE + ENDIF + + ! Set observation information + + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(1,ji,1),2) ) THEN + + iobs = iobs + 1 + + CALL jul2greg( isec, & + & imin, & + & ihou, & + & iday, & + & imon, & + & iyea, & + & inpfiles(jj)%ptim(ji), & + & irefdate(jj) ) + + + ! Surface time coordinates + surfdata%nyea(iobs) = iyea + surfdata%nmon(iobs) = imon + surfdata%nday(iobs) = iday + surfdata%nhou(iobs) = ihou + surfdata%nmin(iobs) = imin + + ! Surface space coordinates + surfdata%rlam(iobs) = inpfiles(jj)%plam(ji) + surfdata%rphi(iobs) = inpfiles(jj)%pphi(ji) + + ! Coordinate search parameters + surfdata%mi (iobs) = inpfiles(jj)%iobsi(ji,1) + surfdata%mj (iobs) = inpfiles(jj)%iobsj(ji,1) + + ! WMO number + surfdata%cwmo(iobs) = inpfiles(jj)%cdwmo(ji) + + ! Instrument type + READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 901 ) itype +901 IF ( ios /= 0 ) THEN + IF (ioserrcount == 0) THEN + CALL ctl_warn ( 'Problem converting an instrument type ', & + & 'to integer. Setting type to zero' ) + ENDIF + ioserrcount = ioserrcount + 1 + itype = 0 + ENDIF + surfdata%ntyp(iobs) = itype + IF ( itype < jpsurfmaxtype + 1 ) THEN + ityp(itype+1) = ityp(itype+1) + 1 + ELSE + IF(lwp)WRITE(numout,*)'WARNING:Increase jpsurfmaxtype in ',& + & cpname + ENDIF + + ! Bookkeeping data to match observations + surfdata%nsidx(iobs) = iobs + surfdata%nsfil(iobs) = iindx(jk) + + ! QC flags + surfdata%nqc(iobs) = inpfiles(jj)%ivqc(ji,1) + + ! Observed value + surfdata%robs(iobs,1) = inpfiles(jj)%pob(1,ji,1) + + + ! Model and MDT is set to fbrmdi unless read from file + IF ( ldmod ) THEN + surfdata%rmod(iobs,1) = inpfiles(jj)%padd(1,ji,1,1) + IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) THEN + surfdata%rext(iobs,1) = inpfiles(jj)%padd(1,ji,2,1) + surfdata%rext(iobs,2) = inpfiles(jj)%pext(1,ji,1) + ENDIF + ELSE + surfdata%rmod(iobs,1) = fbrmdi + IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) surfdata%rext(iobs,:) = fbrmdi + ENDIF + ENDIF + ENDIF + + END DO + + !----------------------------------------------------------------------- + ! Sum up over processors + !----------------------------------------------------------------------- + + CALL obs_mpp_sum_integer( iobs, iobsmpp ) + CALL obs_mpp_sum_integers( ityp, itypmpp, jpsurfmaxtype + 1 ) + + !----------------------------------------------------------------------- + ! Output number of observations. + !----------------------------------------------------------------------- + IF (lwp) THEN + + WRITE(numout,*) + WRITE(numout,'(1X,A)')TRIM( surfdata%cvars(1) )//' data' + WRITE(numout,'(1X,A)')'--------------' + DO jj = 1,8 + IF ( itypmpp(jj) > 0 ) THEN + WRITE(numout,'(1X,A4,I4,A3,I10)')'Type ', jj,' = ',itypmpp(jj) + ENDIF + END DO + WRITE(numout,'(1X,A)') & + & '---------------------------------------------------------------' + WRITE(numout,'(1X,A,I8)') & + & 'Total data for variable '//TRIM( surfdata%cvars(1) )// & + & ' = ', iobsmpp + WRITE(numout,'(1X,A)') & + & '---------------------------------------------------------------' + WRITE(numout,*) + + ENDIF + + !----------------------------------------------------------------------- + ! Deallocate temporary data + !----------------------------------------------------------------------- + DEALLOCATE( ifileidx, isurfidx, zdat, clvarsin ) + + !----------------------------------------------------------------------- + ! Deallocate input data + !----------------------------------------------------------------------- + DO jj = 1, inobf + IF ( inpfiles(jj)%lalloc ) THEN + CALL dealloc_obfbdata( inpfiles(jj) ) + ENDIF + END DO + DEALLOCATE( inpfiles ) + + END SUBROUTINE obs_rea_surf + +END MODULE obs_read_surf \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_readmdt.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_readmdt.F90 new file mode 100644 index 0000000..48343f7 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_readmdt.F90 @@ -0,0 +1,260 @@ +MODULE obs_readmdt + !!====================================================================== + !! *** MODULE obs_readmdt *** + !! Observation diagnostics: Read the MDT for SLA data (skeleton for now) + !!====================================================================== + !! History : ! 2007-03 (K. Mogensen) Initial skeleton version + !! ! 2007-04 (E. Remy) migration and improvement from OPAVAR + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! obs_rea_mdt : Driver for reading MDT + !! obs_offset_mdt : Remove the offset between the model MDT and the used one + !!---------------------------------------------------------------------- + USE par_kind ! Precision variables + USE par_oce ! Domain parameters + USE in_out_manager ! I/O manager + USE obs_surf_def ! Surface observation definitions + USE obs_inter_sup ! Interpolation support routines + USE obs_inter_h2d ! 2D interpolation + USE obs_utils ! Various observation tools + USE iom_nf90 ! IOM NetCDF + USE netcdf ! NetCDF library + USE lib_mpp ! MPP library + USE dom_oce, ONLY : & ! Domain variables + & tmask, tmask_i, e1e2t, gphit, glamt + USE obs_const, ONLY : obfillflt ! Fillvalue + USE oce , ONLY : ssh ! Model variables + + IMPLICIT NONE + PRIVATE + + PUBLIC obs_rea_mdt ! called by dia_obs_init + PUBLIC obs_offset_mdt ! called by obs_rea_mdt + + INTEGER , PUBLIC :: nn_msshc = 1 ! MDT correction scheme + REAL(wp), PUBLIC :: rn_mdtcorr = 1.61_wp ! User specified MDT correction + REAL(wp), PUBLIC :: rn_mdtcutoff = 65.0_wp ! MDT cutoff for computed correction + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_readmdt.F90 13295 2020-07-10 18:24:21Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE obs_rea_mdt( sladata, k2dint, Kmm ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_rea_mdt *** + !! + !! ** Purpose : Read from file the MDT data (skeleton) + !! + !! ** Method : + !! + !! ** Action : + !!---------------------------------------------------------------------- + USE iom + ! + TYPE(obs_surf), INTENT(inout) :: sladata ! SLA data + INTEGER , INTENT(in) :: k2dint ! ? + INTEGER , INTENT(in) :: Kmm ! ? + ! + CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_rea_mdt' + CHARACTER(LEN=20), PARAMETER :: mdtname = 'slaReferenceLevel.nc' + + INTEGER :: jobs ! Obs loop variable + INTEGER :: jpimdt, jpjmdt ! Number of grid point in lat/lon for the MDT + INTEGER :: iico, ijco ! Grid point indicies + INTEGER :: i_nx_id, i_ny_id, i_file_id, i_var_id, i_stat + INTEGER :: nummdt + ! + REAL(wp), DIMENSION(1) :: zext, zobsmask + REAL(wp), DIMENSION(2,2,1) :: zweig + ! + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zmask, zmdtl, zglam, zgphi + INTEGER , DIMENSION(:,:,:), ALLOCATABLE :: igrdi, igrdj + ! + REAL(wp), DIMENSION(jpi,jpj) :: z_mdt, mdtmask + + REAL(wp) :: zlam, zphi, zfill, zinfill ! local scalar + !!---------------------------------------------------------------------- + + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*) ' obs_rea_mdt : Read MDT for referencing altimeter anomalies' + IF(lwp)WRITE(numout,*) ' ------------- ' + CALL FLUSH(numout) + + CALL iom_open( mdtname, nummdt ) ! Open the file + ! ! Get the MDT data + CALL iom_get ( nummdt, jpdom_global, 'sossheig', z_mdt(:,:) ) + CALL iom_close(nummdt) ! Close the file + + ! Read in the fill value + zinfill = 0.0 + i_stat = nf90_open( mdtname, nf90_nowrite, nummdt ) + i_stat = nf90_inq_varid( nummdt, 'sossheig', i_var_id ) + i_stat = nf90_get_att( nummdt, i_var_id, "_FillValue",zinfill) + zfill = zinfill + i_stat = nf90_close( nummdt ) + + ! setup mask based on tmask and MDT mask + ! set mask to 0 where the MDT is set to fillvalue + WHERE(z_mdt(:,:) /= zfill) ; mdtmask(:,:) = tmask(:,:,1) + ELSE WHERE ; mdtmask(:,:) = 0 + END WHERE + + ! Remove the offset between the MDT used with the sla and the model MDT + IF( nn_msshc == 1 .OR. nn_msshc == 2 ) & + & CALL obs_offset_mdt( jpi, jpj, z_mdt, zfill, Kmm ) + + ! Intepolate the MDT already on the model grid at the observation point + + ALLOCATE( & + & igrdi(2,2,sladata%nsurf), & + & igrdj(2,2,sladata%nsurf), & + & zglam(2,2,sladata%nsurf), & + & zgphi(2,2,sladata%nsurf), & + & zmask(2,2,sladata%nsurf), & + & zmdtl(2,2,sladata%nsurf) & + & ) + + DO jobs = 1, sladata%nsurf + + igrdi(1,1,jobs) = sladata%mi(jobs)-1 + igrdj(1,1,jobs) = sladata%mj(jobs)-1 + igrdi(1,2,jobs) = sladata%mi(jobs)-1 + igrdj(1,2,jobs) = sladata%mj(jobs) + igrdi(2,1,jobs) = sladata%mi(jobs) + igrdj(2,1,jobs) = sladata%mj(jobs)-1 + igrdi(2,2,jobs) = sladata%mi(jobs) + igrdj(2,2,jobs) = sladata%mj(jobs) + + END DO + + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, glamt , zglam ) + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, gphit , zgphi ) + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, mdtmask, zmask ) + CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, z_mdt , zmdtl ) + + DO jobs = 1, sladata%nsurf + + zlam = sladata%rlam(jobs) + zphi = sladata%rphi(jobs) + + CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & + & zglam(:,:,jobs), zgphi(:,:,jobs), & + & zmask(:,:,jobs), zweig, zobsmask ) + + CALL obs_int_h2d( 1, 1, zweig, zmdtl(:,:,jobs), zext ) + + sladata%rext(jobs,2) = zext(1) + +! mark any masked data with a QC flag + IF( zobsmask(1) == 0 ) sladata%nqc(jobs) = IBSET(sladata%nqc(jobs),15) + + END DO + + DEALLOCATE( & + & igrdi, & + & igrdj, & + & zglam, & + & zgphi, & + & zmask, & + & zmdtl & + & ) + + IF(lwp)WRITE(numout,*) ' ------------- ' + ! + END SUBROUTINE obs_rea_mdt + + + SUBROUTINE obs_offset_mdt( kpi, kpj, mdt, zfill, Kmm ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_offset_mdt *** + !! + !! ** Purpose : Compute a correction term for the MDT on the model grid + !! !!!!! IF it is on the model grid + !! + !! ** Method : Compute the mean difference between the model and the + !! used MDT and remove the offset. + !! + !! ** Action : + !!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: kpi, kpj + INTEGER, INTENT(IN) :: Kmm + REAL(wp), DIMENSION(kpi,kpj), INTENT(INOUT) :: mdt ! MDT used on the model grid + REAL(wp) , INTENT(IN ) :: zfill + ! + INTEGER :: ji, jj + REAL(wp) :: zdxdy, zarea, zeta1, zeta2, zcorr_mdt, zcorr_bcketa, zcorr ! local scalar + REAL(wp), DIMENSION(jpi,jpj) :: zpromsk + CHARACTER(LEN=14), PARAMETER :: cpname = 'obs_offset_mdt' + !!---------------------------------------------------------------------- + + ! Initialize the local mask, for domain projection + ! Also exclude mdt points which are set to missing data + + DO ji = 1, jpi + DO jj = 1, jpj + zpromsk(ji,jj) = tmask_i(ji,jj) + IF ( ( gphit(ji,jj) .GT. rn_mdtcutoff ) & + &.OR.( gphit(ji,jj) .LT. -rn_mdtcutoff ) & + &.OR.( mdt(ji,jj) .EQ. zfill ) ) & + & zpromsk(ji,jj) = 0.0 + END DO + END DO + + ! Compute MSSH mean over [0,360] x [-rn_mdtcutoff,rn_mdtcutoff] + + zarea = 0.0 + zeta1 = 0.0 + zeta2 = 0.0 + + DO_2D( 1, 1, 1, 1 ) + zdxdy = e1e2t(ji,jj) * zpromsk(ji,jj) + zarea = zarea + zdxdy + zeta1 = zeta1 + mdt(ji,jj) * zdxdy + zeta2 = zeta2 + ssh(ji,jj,Kmm) * zdxdy + END_2D + + CALL mpp_sum( 'obs_readmdt', zeta1 ) + CALL mpp_sum( 'obs_readmdt', zeta2 ) + CALL mpp_sum( 'obs_readmdt', zarea ) + + zcorr_mdt = zeta1 / zarea + zcorr_bcketa = zeta2 / zarea + + ! Define correction term + + zcorr = zcorr_mdt - zcorr_bcketa + + ! Correct spatial mean of the MSSH + + IF( nn_msshc == 1 ) mdt(:,:) = mdt(:,:) - zcorr + + ! User defined value : 1.6 m for the Rio MDT compared to ORCA2 MDT + + IF( nn_msshc == 2 ) mdt(:,:) = mdt(:,:) - rn_mdtcorr + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' obs_readmdt : rn_mdtcutoff = ', rn_mdtcutoff + WRITE(numout,*) ' ----------- zcorr_mdt = ', zcorr_mdt + WRITE(numout,*) ' zcorr_bcketa = ', zcorr_bcketa + WRITE(numout,*) ' zcorr = ', zcorr + WRITE(numout,*) ' nn_msshc = ', nn_msshc + ENDIF + + IF ( nn_msshc == 0 ) WRITE(numout,*) ' MSSH correction is not applied' + IF ( nn_msshc == 1 ) WRITE(numout,*) ' MSSH correction is applied' + IF ( nn_msshc == 2 ) WRITE(numout,*) ' User defined MSSH correction' + + ! + END SUBROUTINE obs_offset_mdt + + !!====================================================================== +END MODULE obs_readmdt \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_rot_vel.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_rot_vel.F90 new file mode 100644 index 0000000..3d302f1 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_rot_vel.F90 @@ -0,0 +1,228 @@ +MODULE obs_rot_vel + !!====================================================================== + !! *** MODULE obs_rot_vel *** + !! Observation diagnostics: Read the velocity profile observations + !!====================================================================== + + !!---------------------------------------------------------------------- + !! obs_rotvel : Rotate velocity data into N-S,E-W directorions + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind ! Precision variables + USE par_oce ! Ocean parameters + USE in_out_manager ! I/O manager + USE dom_oce ! Ocean space and time domain variables + USE obs_grid ! Grid search + USE obs_utils ! For error handling + USE obs_profiles_def ! Profile definitions + USE obs_inter_h2d ! Horizontal interpolation + USE obs_inter_sup ! MPP support routines for interpolation + USE geo2ocean ! Rotation of vectors + USE obs_fbm ! Feedback definitions + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + PUBLIC obs_rotvel ! Rotate the observations + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_rot_vel.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_rotvel( profdata, k2dint, pu, pv ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_rea_pro_dri *** + !! + !! ** Purpose : Rotate velocity data into N-S,E-W directorions + !! + !! ** Method : Interpolation of geo2ocean coefficients on U,V grid + !! to observation point followed by a similar computations + !! as in geo2ocean. + !! + !! ** Action : Review if there is a better way to do this. + !! + !! References : + !! + !! History : + !! ! : 2009-02 (K. Mogensen) : New routine + !!---------------------------------------------------------------------- + !! * Modules used + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: profdata ! Profile data to be read + INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation methed + REAL(wp), DIMENSION(:) :: & + & pu, & + & pv + !! * Local declarations + REAL(wp), DIMENSION(2,2,1) :: zweig + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zmasku, & + & zmaskv, & + & zcoslu, & + & zsinlu, & + & zcoslv, & + & zsinlv, & + & zglamu, & + & zgphiu, & + & zglamv, & + & zgphiv + REAL(wp), DIMENSION(1) :: & + & zsinu, & + & zcosu, & + & zsinv, & + & zcosv + REAL(wp) :: zsin + REAL(wp) :: zcos + REAL(wp), DIMENSION(1) :: zobsmask + REAL(wp), DIMENSION(jpi,jpj) :: zsingu,zcosgu,zsingv,zcosgv + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & + & igrdiu, & + & igrdju, & + & igrdiv, & + & igrdjv + INTEGER :: ji + INTEGER :: jk + + + !----------------------------------------------------------------------- + ! Allocate data for message parsing and interpolation + !----------------------------------------------------------------------- + + ALLOCATE( & + & igrdiu(2,2,profdata%nprof), & + & igrdju(2,2,profdata%nprof), & + & zglamu(2,2,profdata%nprof), & + & zgphiu(2,2,profdata%nprof), & + & zmasku(2,2,profdata%nprof), & + & zcoslu(2,2,profdata%nprof), & + & zsinlu(2,2,profdata%nprof), & + & igrdiv(2,2,profdata%nprof), & + & igrdjv(2,2,profdata%nprof), & + & zglamv(2,2,profdata%nprof), & + & zgphiv(2,2,profdata%nprof), & + & zmaskv(2,2,profdata%nprof), & + & zcoslv(2,2,profdata%nprof), & + & zsinlv(2,2,profdata%nprof) & + & ) + + !----------------------------------------------------------------------- + ! Receive the angles on the U and V grids. + !----------------------------------------------------------------------- + + CALL obs_rot( zsingu, zcosgu, zsingv, zcosgv ) + + DO ji = 1, profdata%nprof + igrdiu(1,1,ji) = profdata%mi(ji,1)-1 + igrdju(1,1,ji) = profdata%mj(ji,1)-1 + igrdiu(1,2,ji) = profdata%mi(ji,1)-1 + igrdju(1,2,ji) = profdata%mj(ji,1) + igrdiu(2,1,ji) = profdata%mi(ji,1) + igrdju(2,1,ji) = profdata%mj(ji,1)-1 + igrdiu(2,2,ji) = profdata%mi(ji,1) + igrdju(2,2,ji) = profdata%mj(ji,1) + igrdiv(1,1,ji) = profdata%mi(ji,2)-1 + igrdjv(1,1,ji) = profdata%mj(ji,2)-1 + igrdiv(1,2,ji) = profdata%mi(ji,2)-1 + igrdjv(1,2,ji) = profdata%mj(ji,2) + igrdiv(2,1,ji) = profdata%mi(ji,2) + igrdjv(2,1,ji) = profdata%mj(ji,2)-1 + igrdiv(2,2,ji) = profdata%mi(ji,2) + igrdjv(2,2,ji) = profdata%mj(ji,2) + END DO + + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & + & glamu, zglamu ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & + & gphiu, zgphiu ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & + & umask(:,:,1), zmasku ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & + & zsingu, zsinlu ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & + & zcosgu, zcoslu ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & + & glamv, zglamv ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & + & gphiv, zgphiv ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & + & vmask(:,:,1), zmaskv ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & + & zsingv, zsinlv ) + CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & + & zcosgv, zcoslv ) + + DO ji = 1, profdata%nprof + + CALL obs_int_h2d_init( 1, 1, k2dint, & + & profdata%rlam(ji), profdata%rphi(ji), & + & zglamu(:,:,ji), zgphiu(:,:,ji), & + & zmasku(:,:,ji), zweig, zobsmask ) + + CALL obs_int_h2d( 1, 1, zweig, zsinlu(:,:,ji), zsinu ) + + CALL obs_int_h2d( 1, 1, zweig, zcoslu(:,:,ji), zcosu ) + + CALL obs_int_h2d_init( 1, 1, k2dint, & + & profdata%rlam(ji), profdata%rphi(ji), & + & zglamv(:,:,ji), zgphiv(:,:,ji), & + & zmaskv(:,:,ji), zweig, zobsmask ) + + CALL obs_int_h2d( 1, 1, zweig, zsinlv(:,:,ji), zsinv ) + + CALL obs_int_h2d( 1, 1, zweig, zcoslv(:,:,ji), zcosv ) + + ! Assume that the angle at observation point is the + ! mean of u and v cosines/sines + + zcos = 0.5_wp * ( zcosu(1) + zcosv(1) ) + zsin = 0.5_wp * ( zsinu(1) + zsinv(1) ) + + IF ( ( profdata%npvsta(ji,1) /= profdata%npvsta(ji,2) ) .OR. & + & ( profdata%npvend(ji,1) /= profdata%npvend(ji,2) ) ) THEN + CALL fatal_error( 'Different number of U and V observations '// & + 'in a profile in obs_rotvel', __LINE__ ) + ENDIF + + DO jk = profdata%npvsta(ji,1), profdata%npvend(ji,1) + IF ( ( profdata%var(1)%vmod(jk) /= fbrmdi ) .AND. & + & ( profdata%var(2)%vmod(jk) /= fbrmdi ) ) THEN + pu(jk) = profdata%var(1)%vmod(jk) * zcos - & + & profdata%var(2)%vmod(jk) * zsin + pv(jk) = profdata%var(2)%vmod(jk) * zcos + & + & profdata%var(1)%vmod(jk) * zsin + ELSE + pu(jk) = fbrmdi + pv(jk) = fbrmdi + ENDIF + + END DO + + END DO + + DEALLOCATE( & + & igrdiu, & + & igrdju, & + & zglamu, & + & zgphiu, & + & zmasku, & + & zcoslu, & + & zsinlu, & + & igrdiv, & + & igrdjv, & + & zglamv, & + & zgphiv, & + & zmaskv, & + & zcoslv, & + & zsinlv & + & ) + + END SUBROUTINE obs_rotvel + +END MODULE obs_rot_vel \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_sort.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_sort.F90 new file mode 100644 index 0000000..5cfbaf2 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_sort.F90 @@ -0,0 +1,146 @@ +MODULE obs_sort + !!===================================================================== + !! *** MODULE obs_sort *** + !! Observation diagnostics: Various tools for sorting etc. + !!===================================================================== + + !!---------------------------------------------------------------------- + !! sort_dp_indx : Get indicies for ascending order for a double prec. array + !! index_sort : Get indicies for ascending order for a double prec. array + !!--------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & dp + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE index_sort ! Get indicies for ascending order for a double prec. array + + PUBLIC sort_dp_indx ! Get indicies for ascending order for a double prec. array + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_sort.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE sort_dp_indx( kvals, pvals, kindx ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sort_dp_indx *** + !! + !! ** Purpose : Get indicies for ascending order for a double precision array + !! + !! ** Method : Call index_sort routine + !! + !! ** Action : + !! + !! History : + !! ! 06-05 (K. Mogensen) Original code + !! ! 06-10 (A. Weaver) Cleaning + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kvals ! Number of elements to be sorted + REAL(KIND=dp), DIMENSION(kvals), INTENT(IN) :: & + & pvals ! Array to be sorted + INTEGER, DIMENSION(kvals), INTENT(OUT) :: & + & kindx ! Indices for ordering of array + + !! * Local declarations + + !----------------------------------------------------------------------- + ! Call qsort routine + !----------------------------------------------------------------------- + IF (kvals>=1) THEN + + CALL index_sort( pvals, kindx, kvals ) + + ENDIF + + END SUBROUTINE sort_dp_indx + + SUBROUTINE index_sort( pval, kindx, kvals ) + !!---------------------------------------------------------------------- + !! *** ROUTINE index_sort *** + !! + !! ** Purpose : Get indicies for ascending order for a double precision array + !! + !! ** Method : Heapsort + !! + !! ** Action : + !! + !! References : http://en.wikipedia.org/wiki/Heapsort + !! + !! History : + !! ! 06-05 (K. Mogensen) Original code + !! ! 06-10 (A. Weaver) Cleaning + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kvals ! Number of values + REAL(KIND=dp), DIMENSION(kvals), INTENT(IN) :: & + & pval ! Array to be sorted + INTEGER, DIMENSION(kvals), INTENT(INOUT) :: & + & kindx ! Indicies for ordering + + !! * Local declarations + INTEGER :: ji + INTEGER :: jj + INTEGER :: jt + INTEGER :: jn + INTEGER :: jparent + INTEGER :: jchild + + DO ji = 1, kvals + kindx(ji) = ji + END DO + + ji = kvals/2 + 1 + jn = kvals + + main_loop : DO + + IF ( ji > 1 ) THEN + ji = ji-1 + jt = kindx(ji) + ELSE + jt = kindx(jn) + kindx(jn) = kindx(1) + jn = jn-1 + IF ( jn <= 1 ) THEN + kindx(1) = jt + EXIT main_loop + ENDIF + ENDIF + + jparent = ji + jchild = 2 * ji + + inner_loop : DO + + IF ( jchild > jn ) EXIT inner_loop + IF ( jchild < jn ) THEN + IF ( pval(kindx(jchild)) < pval(kindx(jchild+1)) ) THEN + jchild = jchild+1 + ENDIF + ENDIF + IF ( pval(jt) < pval(kindx(jchild))) THEN + kindx(jparent) = kindx(jchild) + jparent = jchild + jchild = jchild*2 + ELSE + jchild = jn + 1 + ENDIF + + END DO inner_loop + + kindx(jparent) = jt + + END DO main_loop + + END SUBROUTINE index_sort + +END MODULE obs_sort \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_sstbias.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_sstbias.F90 new file mode 100644 index 0000000..b42947f --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_sstbias.F90 @@ -0,0 +1,242 @@ +MODULE obs_sstbias + !!====================================================================== + !! *** MODULE obs_sstbias *** + !! Observation diagnostics: Read the bias for SST data + !!====================================================================== + !!---------------------------------------------------------------------- + !! obs_app_sstbias : Driver for reading and applying the SST bias + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp, & + & dp, & + & sp + USE par_oce, ONLY : & ! Domain parameters + & jpi, & + & jpj + USE in_out_manager, ONLY : & ! I/O manager + & lwp, & + & numout + USE obs_surf_def ! Surface observation definitions + USE dom_oce, ONLY : & ! Domain variables + & tmask, & + & tmask_i, & + & e1t, & + & e2t, & + & gphit, & + & glamt + USE oce, ONLY : & ! Model variables + & ssh + USE obs_inter_h2d + USE obs_utils ! Various observation tools + USE obs_inter_sup + IMPLICIT NONE + !! * Routine accessibility + PRIVATE + PUBLIC obs_app_sstbias ! Read the altimeter bias +CONTAINS + SUBROUTINE obs_app_sstbias( sstdata, k2dint, knumtypes, & + cl_bias_files ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_app_sstbias *** + !! + !! ** Purpose : Read SST bias data from files and apply correction to + !! observations + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! : 2014-08 (J. While) Bias correction code for SST obs, + !! ! based on obs_rea_altbias + !!---------------------------------------------------------------------- + !! * Modules used + USE iom + USE netcdf + !! * Arguments + + TYPE(obs_surf), INTENT(INOUT) :: sstdata ! SST data + INTEGER, INTENT(IN) :: k2dint + INTEGER, INTENT(IN) :: knumtypes !number of bias types to read in + CHARACTER(LEN=128), DIMENSION(knumtypes), INTENT(IN) :: & + cl_bias_files !List of files to read + !! * Local declarations + INTEGER :: jobs ! Obs loop variable + INTEGER :: jpisstbias ! Number of grid point in latitude for the bias + INTEGER :: jpjsstbias ! Number of grid point in longitude for the bias + INTEGER :: iico ! Grid point indices + INTEGER :: ijco + INTEGER :: jt + INTEGER :: i_nx_id ! Index to read the NetCDF file + INTEGER :: i_ny_id ! + INTEGER :: i_file_id ! + INTEGER :: i_var_id + INTEGER, DIMENSION(knumtypes) :: & + & ibiastypes ! Array of the bias types in each file + REAL(wp), DIMENSION(jpi,jpj,knumtypes) :: & + & z_sstbias ! Array to store the SST bias values + REAL(wp), DIMENSION(jpi,jpj) :: & + & z_sstbias_2d ! Array to store the SST bias values + REAL(wp), DIMENSION(1) :: & + & zext, & + & zobsmask + REAL(wp), DIMENSION(2,2,1) :: & + & zweig + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zmask, & + & zglam, & + & zgphi + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zmask_tmp, & + & zglam_tmp, & + & zgphi_tmp + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zbias + REAL(wp) :: zlam + REAL(wp) :: zphi + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & + & igrdi, & + & igrdj + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & + & igrdi_tmp, & + & igrdj_tmp + INTEGER :: numsstbias + INTEGER(KIND=NF90_INT) :: ifile_source + + INTEGER :: incfile + INTEGER :: jtype + INTEGER :: iret + INTEGER :: inumtype + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*) 'obs_rea_sstbias : ' + IF(lwp)WRITE(numout,*) '----------------- ' + IF(lwp)WRITE(numout,*) 'Read SST bias ' + ! Open and read the files + z_sstbias(:,:,:)=0.0_wp + DO jtype = 1, knumtypes + + numsstbias=0 + IF(lwp)WRITE(numout,*) 'Opening ',cl_bias_files(jtype) + CALL iom_open( cl_bias_files(jtype), numsstbias, ldstop=.FALSE. ) + IF (numsstbias > 0) THEN + + !Read the bias type from the file + !No IOM get attribute command at time of writing, + !so have to use NETCDF + !routines directly - should be upgraded in the future + iret=NF90_OPEN(TRIM(cl_bias_files(jtype)), NF90_NOWRITE, incfile) + iret=NF90_GET_ATT( incfile, NF90_GLOBAL, "SST_source", & + ifile_source ) + ibiastypes(jtype) = ifile_source + iret=NF90_CLOSE(incfile) + + IF ( iret /= 0 ) CALL ctl_stop( & + 'obs_rea_sstbias : Cannot read bias type from file '// & + cl_bias_files(jtype) ) + ! Get the SST bias data + CALL iom_get( numsstbias, jpdom_global, 'tn', z_sstbias_2d(:,:), 1 ) + z_sstbias(:,:,jtype) = z_sstbias_2d(:,:) + ! Close the file + CALL iom_close(numsstbias) + ELSE + CALL ctl_stop('obs_read_sstbias: File '// & + TRIM( cl_bias_files(jtype) )//' Not found') + ENDIF + END DO + + ! Interpolate the bias already on the model grid at the observation point + ALLOCATE( & + & igrdi(2,2,sstdata%nsurf), & + & igrdj(2,2,sstdata%nsurf), & + & zglam(2,2,sstdata%nsurf), & + & zgphi(2,2,sstdata%nsurf), & + & zmask(2,2,sstdata%nsurf) ) + + DO jobs = 1, sstdata%nsurf + igrdi(1,1,jobs) = sstdata%mi(jobs)-1 + igrdj(1,1,jobs) = sstdata%mj(jobs)-1 + igrdi(1,2,jobs) = sstdata%mi(jobs)-1 + igrdj(1,2,jobs) = sstdata%mj(jobs) + igrdi(2,1,jobs) = sstdata%mi(jobs) + igrdj(2,1,jobs) = sstdata%mj(jobs)-1 + igrdi(2,2,jobs) = sstdata%mi(jobs) + igrdj(2,2,jobs) = sstdata%mj(jobs) + END DO + CALL obs_int_comm_2d( 2, 2, sstdata%nsurf, jpi, jpj, & + & igrdi, igrdj, glamt, zglam ) + CALL obs_int_comm_2d( 2, 2, sstdata%nsurf, jpi, jpj, & + & igrdi, igrdj, gphit, zgphi ) + CALL obs_int_comm_2d( 2, 2, sstdata%nsurf, jpi, jpj, & + & igrdi, igrdj, tmask(:,:,1), zmask ) + DO jtype = 1, knumtypes + + !Find the number observations of type and allocate tempory arrays + inumtype = COUNT( sstdata%ntyp(:) == ibiastypes(jtype) ) + ALLOCATE( & + & igrdi_tmp(2,2,inumtype), & + & igrdj_tmp(2,2,inumtype), & + & zglam_tmp(2,2,inumtype), & + & zgphi_tmp(2,2,inumtype), & + & zmask_tmp(2,2,inumtype), & + & zbias( 2,2,inumtype ) ) + jt=1 + DO jobs = 1, sstdata%nsurf + IF ( sstdata%ntyp(jobs) == ibiastypes(jtype) ) THEN + igrdi_tmp(:,:,jt) = igrdi(:,:,jobs) + igrdj_tmp(:,:,jt) = igrdj(:,:,jobs) + zglam_tmp(:,:,jt) = zglam(:,:,jobs) + zgphi_tmp(:,:,jt) = zgphi(:,:,jobs) + zmask_tmp(:,:,jt) = zmask(:,:,jobs) + jt = jt +1 + ENDIF + END DO + + CALL obs_int_comm_2d( 2, 2, inumtype, jpi, jpj, & + & igrdi_tmp(:,:,:), igrdj_tmp(:,:,:), & + & z_sstbias(:,:,jtype), zbias(:,:,:) ) + jt=1 + DO jobs = 1, sstdata%nsurf + IF ( sstdata%ntyp(jobs) == ibiastypes(jtype) ) THEN + zlam = sstdata%rlam(jobs) + zphi = sstdata%rphi(jobs) + iico = sstdata%mi(jobs) + ijco = sstdata%mj(jobs) + CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & + & zglam_tmp(:,:,jt), & + & zgphi_tmp(:,:,jt), & + & zmask_tmp(:,:,jt), zweig, zobsmask ) + CALL obs_int_h2d( 1, 1, zweig, zbias(:,:,jt), zext ) + ! adjust sst with bias field + sstdata%robs(jobs,1) = sstdata%robs(jobs,1) - zext(1) + jt=jt+1 + ENDIF + END DO + + !Deallocate arrays + DEALLOCATE( & + & igrdi_tmp, & + & igrdj_tmp, & + & zglam_tmp, & + & zgphi_tmp, & + & zmask_tmp, & + & zbias ) + END DO + DEALLOCATE( & + & igrdi, & + & igrdj, & + & zglam, & + & zgphi, & + & zmask ) + + IF(lwp) THEN + WRITE(numout,*) " " + WRITE(numout,*) "SST bias correction applied successfully" + WRITE(numout,*) "Obs types: ",ibiastypes(:), & + " Have all been bias corrected\n" + ENDIF + END SUBROUTINE obs_app_sstbias + +END MODULE obs_sstbias \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_surf_def.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_surf_def.F90 new file mode 100644 index 0000000..042e892 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_surf_def.F90 @@ -0,0 +1,529 @@ +MODULE obs_surf_def + !!===================================================================== + !! *** MODULE obs_surf_def *** + !! Observation diagnostics: Storage handling for surface observation + !! arrays and additional flags etc. + !! This module only defines the data type and + !! operations on the data type. There is no + !! actual data in the module. + !!===================================================================== + + !!---------------------------------------------------------------------- + !! obs_surf : F90 type containing the surface information + !! obs_surf_alloc : Allocates surface data arrays + !! obs_surf_dealloc : Deallocates surface data arrays + !! obs_surf_compress : Extract sub-information from a obs_surf type + !! to a new obs_surf type + !! obs_surf_decompress : Reinsert sub-information from a obs_surf type + !! into the original obs_surf type + !!---------------------------------------------------------------------- + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp + USE obs_mpp, ONLY : & ! MPP tools + obs_mpp_sum_integer + + IMPLICIT NONE + + !! * Routine/type accessibility + PRIVATE + + PUBLIC & + & obs_surf, & + & obs_surf_alloc, & + & obs_surf_dealloc, & + & obs_surf_compress, & + & obs_surf_decompress + + !! * Type definition for surface observation type + + TYPE obs_surf + + ! Bookkeeping + + INTEGER :: nsurf !: Local number of surface data within window + INTEGER :: nsurfmpp !: Global number of surface data within window + INTEGER :: nvar !: Number of variables at observation points + INTEGER :: nextra !: Number of extra fields at observation points + INTEGER :: nstp !: Number of time steps + INTEGER :: npi !: Number of 3D grid points + INTEGER :: npj + INTEGER :: nsurfup !: Observation counter used in obs_oper + INTEGER :: nrec !: Number of surface observation records in window + + ! Arrays with size equal to the number of surface observations + + INTEGER, POINTER, DIMENSION(:) :: & + & mi, & !: i-th grid coord. for interpolating to surface observation + & mj, & !: j-th grid coord. for interpolating to surface observation + & mt, & !: time record number for gridded data + & nsidx,& !: Surface observation number + & nsfil,& !: Surface observation number in file + & nyea, & !: Year of surface observation + & nmon, & !: Month of surface observation + & nday, & !: Day of surface observation + & nhou, & !: Hour of surface observation + & nmin, & !: Minute of surface observation + & mstp, & !: Time step nearest to surface observation + & nqc, & !: Surface observation qc flag + & ntyp !: Type of surface observation product + + CHARACTER(len=8), POINTER, DIMENSION(:) :: & + & cvars !: Variable names + + CHARACTER(LEN=8), POINTER, DIMENSION(:) :: & + & cwmo !: WMO indentifier + + REAL(KIND=wp), POINTER, DIMENSION(:) :: & + & rlam, & !: Longitude coordinate of surface observation + & rphi !: Latitude coordinate of surface observation + + REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & + & robs, & !: Surface observation + & rmod !: Model counterpart of the surface observation vector + + REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & + & rext !: Extra fields interpolated to observation points + + REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & + & vdmean !: Time averaged of model field + + ! Arrays with size equal to the number of time steps in the window + + INTEGER, POINTER, DIMENSION(:) :: & + & nsstp, & !: Local number of surface observations per time step + & nsstpmpp !: Global number of surface observations per time step + + ! Arrays with size equal to the number of observation records in the window + INTEGER, POINTER, DIMENSION(:) :: & + & mrecstp ! Time step of the records + + ! Arrays used to store source indices when + ! compressing obs_surf derived types + + ! Array with size nsurf + + INTEGER, POINTER, DIMENSION(:) :: & + & nsind !: Source indices of surface data in compressed data + + ! Is this a gridded product? + + LOGICAL :: lgrid + + END TYPE obs_surf + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_surf_def.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_surf_alloc( surf, ksurf, kvar, kextra, kstp, kpi, kpj ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_surf_alloc *** + !! + !! ** Purpose : - Allocate data for surface data arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-03 (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_surf), INTENT(INOUT) :: surf ! Surface data to be allocated + INTEGER, INTENT(IN) :: ksurf ! Number of surface observations + INTEGER, INTENT(IN) :: kvar ! Number of surface variables + INTEGER, INTENT(IN) :: kextra ! Number of extra fields at observation points + INTEGER, INTENT(IN) :: kstp ! Number of time steps + INTEGER, INTENT(IN) :: kpi ! Number of 3D grid points + INTEGER, INTENT(IN) :: kpj + + !!* Local variables + INTEGER :: ji + INTEGER :: jvar + + ! Set bookkeeping variables + + surf%nsurf = ksurf + surf%nsurfmpp = 0 + surf%nextra = kextra + surf%nvar = kvar + surf%nstp = kstp + surf%npi = kpi + surf%npj = kpj + + ! Allocate arrays of size number of variables + + ALLOCATE( & + & surf%cvars(kvar) & + & ) + + DO jvar = 1, kvar + surf%cvars(jvar) = "NotSet" + END DO + + ! Allocate arrays of number of surface data size + + ALLOCATE( & + & surf%mi(ksurf), & + & surf%mj(ksurf), & + & surf%mt(ksurf), & + & surf%nsidx(ksurf), & + & surf%nsfil(ksurf), & + & surf%nyea(ksurf), & + & surf%nmon(ksurf), & + & surf%nday(ksurf), & + & surf%nhou(ksurf), & + & surf%nmin(ksurf), & + & surf%mstp(ksurf), & + & surf%nqc(ksurf), & + & surf%ntyp(ksurf), & + & surf%cwmo(ksurf), & + & surf%rlam(ksurf), & + & surf%rphi(ksurf), & + & surf%nsind(ksurf) & + & ) + + surf%mt(:) = -1 + + + ! Allocate arrays of number of surface data size * number of variables + + ALLOCATE( & + & surf%robs(ksurf,kvar), & + & surf%rmod(ksurf,kvar) & + & ) + + ! Allocate arrays of number of extra fields at observation points + + ALLOCATE( & + & surf%rext(ksurf,kextra) & + & ) + + surf%rext(:,:) = 0.0_wp + + ! Allocate arrays of number of time step size + + ALLOCATE( & + & surf%nsstp(kstp), & + & surf%nsstpmpp(kstp) & + & ) + + ! Allocate arrays of size number of grid points + + ALLOCATE( & + & surf%vdmean(kpi,kpj) & + & ) + + ! Set defaults for compression indices + + DO ji = 1, ksurf + surf%nsind(ji) = ji + END DO + + ! Set defaults for number of observations per time step + + surf%nsstp(:) = 0 + surf%nsstpmpp(:) = 0 + + ! Set the observation counter used in obs_oper + + surf%nsurfup = 0 + + ! Not gridded by default + + surf%lgrid = .FALSE. + + END SUBROUTINE obs_surf_alloc + + SUBROUTINE obs_surf_dealloc( surf ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_surf_dealloc *** + !! + !! ** Purpose : - Deallocate data for surface data arrays + !! + !! ** Method : - Fortran-90 dynamic arrays + !! + !! History : + !! ! 07-03 (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_surf), INTENT(INOUT) :: & + & surf ! Surface data to be allocated + + !!* Local variables + + ! Deallocate arrays of number of surface data size + + DEALLOCATE( & + & surf%mi, & + & surf%mj, & + & surf%mt, & + & surf%nsidx, & + & surf%nsfil, & + & surf%nyea, & + & surf%nmon, & + & surf%nday, & + & surf%nhou, & + & surf%nmin, & + & surf%mstp, & + & surf%nqc, & + & surf%ntyp, & + & surf%cwmo, & + & surf%rlam, & + & surf%rphi, & + & surf%nsind & + & ) + + ! Allocate arrays of number of surface data size * number of variables + + DEALLOCATE( & + & surf%robs, & + & surf%rmod & + & ) + + ! Deallocate arrays of number of extra fields at observation points + + DEALLOCATE( & + & surf%rext & + & ) + + ! Deallocate arrays of size number of grid points size times + ! number of variables + + DEALLOCATE( & + & surf%vdmean & + & ) + + ! Deallocate arrays of number of time step size + + DEALLOCATE( & + & surf%nsstp, & + & surf%nsstpmpp & + & ) + + ! Dellocate arrays of size number of variables + + DEALLOCATE( & + & surf%cvars & + & ) + + END SUBROUTINE obs_surf_dealloc + + SUBROUTINE obs_surf_compress( surf, newsurf, lallocate, kumout, lvalid ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_surf_compress *** + !! + !! ** Purpose : - Extract sub-information from a obs_surf type + !! into a new obs_surf type + !! + !! ** Method : - The data is copied from surf to new surf. + !! In the case of lvalid being present only the + !! selected data will be copied. + !! If lallocate is true the data in the newsurf is + !! allocated either with the same number of elements + !! as surf or with only the subset of elements defined + !! by the optional selection. + !! + !! History : + !! ! 07-03 (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_surf), INTENT(IN) :: surf ! Original surface data + TYPE(obs_surf), INTENT(INOUT) :: newsurf ! New surface data with a subset of the original data + LOGICAL, INTENT(IN) :: lallocate ! Allocate newsurf data + INTEGER,INTENT(IN) :: kumout ! Fortran unit for messages + LOGICAL, OPTIONAL, INTENT(in), DIMENSION(:) :: & + & lvalid ! Valid of surface observations + + !!* Local variables + INTEGER :: insurf + INTEGER :: ji + INTEGER :: jk + LOGICAL, DIMENSION(:), ALLOCATABLE :: llvalid + + ! Count how many elements there should be in the new data structure + + IF ( PRESENT(lvalid) ) THEN + insurf = 0 + DO ji = 1, surf%nsurf + IF ( lvalid(ji) ) THEN + insurf = insurf + 1 + ENDIF + END DO + ELSE + insurf = surf%nsurf + ENDIF + + ! Optionally allocate data in the new data structure + + IF ( lallocate ) THEN + CALL obs_surf_alloc( newsurf, insurf, surf%nvar, & + & surf%nextra, surf%nstp, surf%npi, surf%npj ) + ENDIF + + ! Allocate temporary valid array to unify the code for both cases + + ALLOCATE( llvalid(surf%nsurf) ) + IF ( PRESENT(lvalid) ) THEN + llvalid(:) = lvalid(:) + ELSE + llvalid(:) = .TRUE. + ENDIF + + ! Setup bookkeeping variables + + insurf = 0 + + ! Loop over source surface data + + DO ji = 1, surf%nsurf + + IF ( llvalid(ji) ) THEN + + ! Copy the header information + + insurf = insurf + 1 + + newsurf%mi(insurf) = surf%mi(ji) + newsurf%mj(insurf) = surf%mj(ji) + newsurf%mt(insurf) = surf%mt(ji) + newsurf%nsidx(insurf) = surf%nsidx(ji) + newsurf%nsfil(insurf) = surf%nsfil(ji) + newsurf%nyea(insurf) = surf%nyea(ji) + newsurf%nmon(insurf) = surf%nmon(ji) + newsurf%nday(insurf) = surf%nday(ji) + newsurf%nhou(insurf) = surf%nhou(ji) + newsurf%nmin(insurf) = surf%nmin(ji) + newsurf%mstp(insurf) = surf%mstp(ji) + newsurf%nqc(insurf) = surf%nqc(ji) + newsurf%ntyp(insurf) = surf%ntyp(ji) + newsurf%cwmo(insurf) = surf%cwmo(ji) + newsurf%rlam(insurf) = surf%rlam(ji) + newsurf%rphi(insurf) = surf%rphi(ji) + + DO jk = 1, surf%nvar + + newsurf%robs(insurf,jk) = surf%robs(ji,jk) + newsurf%rmod(insurf,jk) = surf%rmod(ji,jk) + + END DO + + DO jk = 1, surf%nextra + + newsurf%rext(insurf,jk) = surf%rext(ji,jk) + + END DO + + ! nsind is the index of the original surface data + + newsurf%nsind(insurf) = ji + + ENDIF + + END DO + + ! Update MPP counters + + newsurf%nsurf = insurf + CALL obs_mpp_sum_integer ( newsurf%nsurf, newsurf%nsurfmpp ) + + ! Set book keeping variables which do not depend on number of obs. + + newsurf%nstp = surf%nstp + newsurf%cvars(:) = surf%cvars(:) + + ! Set gridded stuff + + newsurf%mt(insurf) = surf%mt(ji) + + ! Deallocate temporary data + + DEALLOCATE( llvalid ) + + END SUBROUTINE obs_surf_compress + + SUBROUTINE obs_surf_decompress( surf, oldsurf, ldeallocate, kumout ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_surf_decompress *** + !! + !! ** Purpose : - Copy back information to original surface data type + !! + !! ** Method : - Reinsert updated information from a previous + !! copied/compressed surface data type into the original + !! surface data and optionally deallocate the surface + !! data input + !! + !! History : + !! ! 07-03 (K. Mogensen, A. Weaver, E. Remy, S. Ricci) original + !!---------------------------------------------------------------------- + !! * Arguments + TYPE(obs_surf),INTENT(INOUT) :: surf ! Updated surface data + TYPE(obs_surf),INTENT(INOUT) :: oldsurf ! Original surface data + LOGICAL, INTENT(IN) :: ldeallocate ! Deallocate the updated data of insertion + INTEGER,INTENT(in) :: kumout ! Output unit + + !!* Local variables + INTEGER :: ji + INTEGER :: jj + INTEGER :: jk + + ! Copy data from surf to old surf + + DO ji = 1, surf%nsurf + + jj=surf%nsind(ji) + + oldsurf%mi(jj) = surf%mi(ji) + oldsurf%mj(jj) = surf%mj(ji) + oldsurf%mt(jj) = surf%mt(ji) + oldsurf%nsidx(jj) = surf%nsidx(ji) + oldsurf%nsfil(jj) = surf%nsfil(ji) + oldsurf%nyea(jj) = surf%nyea(ji) + oldsurf%nmon(jj) = surf%nmon(ji) + oldsurf%nday(jj) = surf%nday(ji) + oldsurf%nhou(jj) = surf%nhou(ji) + oldsurf%nmin(jj) = surf%nmin(ji) + oldsurf%mstp(jj) = surf%mstp(ji) + oldsurf%nqc(jj) = surf%nqc(ji) + oldsurf%ntyp(jj) = surf%ntyp(ji) + oldsurf%cwmo(jj) = surf%cwmo(ji) + oldsurf%rlam(jj) = surf%rlam(ji) + oldsurf%rphi(jj) = surf%rphi(ji) + + END DO + + DO jk = 1, surf%nvar + + DO ji = 1, surf%nsurf + + jj=surf%nsind(ji) + + oldsurf%robs(jj,jk) = surf%robs(ji,jk) + oldsurf%rmod(jj,jk) = surf%rmod(ji,jk) + + END DO + + END DO + + DO jk = 1, surf%nextra + + DO ji = 1, surf%nsurf + + jj=surf%nsind(ji) + + oldsurf%rext(jj,jk) = surf%rext(ji,jk) + + END DO + + END DO + + ! Optionally deallocate the updated surface data + + IF ( ldeallocate ) CALL obs_surf_dealloc( surf ) + + END SUBROUTINE obs_surf_decompress + +END MODULE obs_surf_def \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_types.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_types.F90 new file mode 100644 index 0000000..610d006 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_types.F90 @@ -0,0 +1,267 @@ +MODULE obs_types + !!===================================================================== + !! *** MODULE obs_types *** + !! Observation diagnostics: Observation type integer to character + !! translation + !!===================================================================== + + !!--------------------------------------------------------------------- + !! + !! The NetCDF variable CWMO_INST_TYP_COR is used to identify the + !! different instrument types for coriolis data. + !! + !! WMO NEMOVAR TYPE DESCRIPTION + !! --- ------- ---- -------------------------------------------- + !! 800 0 MBT (1941-) mechanical bathythermograph data + !! 401 1 XBT (1967-) expendable bathythermograph data + !! 830 2 CTD (1967-) high resolution CTD data + !! 820 3 MRB (1990-) moored buoy data + !! 831 4 PFL (1994-) profiling float data + !! 995 5 DRB (1998-) drifting buoy data + !! 997 6 APB (1997-) autonomous pinniped bathythermograph + !! 996 7 UOR (1992-) undulating oceanographic recorder + !! 741 8 OSD (1800-) low resolution (bottle) CTD data + !! + !! History : + !! ! 06-03 (K. Mogensen) Original code + !! ! 06-10 (A. Weaver) Cleanup + !!--------------------------------------------------------------------- + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + + !! * Shared Module variables + + INTEGER, PUBLIC, PARAMETER :: ntyp1770 = 1023 +!RBbug useless ? CHARACTER(LEN=4), PUBLIC, DIMENSION(0:ntyp1770) :: cwmotyp1770 + CHARACTER(LEN=80), PUBLIC, DIMENSION(0:ntyp1770) :: cwmonam1770 + CHARACTER(LEN=3), PUBLIC, DIMENSION(0:ntyp1770) :: ctypshort + + INTEGER, PUBLIC, PARAMETER :: ntypalt = 8 + CHARACTER(LEN=40), PUBLIC, DIMENSION(0:ntypalt) :: calttyp + + PUBLIC obs_typ_init + PUBLIC obs_wmo_init + PUBLIC obs_alt_typ_init + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_types.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_typ_init + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_wmo_init *** + !! + !! ** Purpose : Initialize code tables + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! : 2007-06 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + + !! * Local declarations + + CALL obs_wmo_init + + CALL obs_alt_typ_init + + END SUBROUTINE obs_typ_init + + SUBROUTINE obs_wmo_init + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_wmo_init *** + !! + !! ** Purpose : Initialize WMO code 1770 code tables + !! + !! ** Method : Direct initialisation of variables + !! + !! ** Action : + !! + !! References : WORLD METEOROLOGICAL ORGANIZATION + !! Manual on Codes + !! International Codes + !! VOLUME I.1 (Annex II to WMO Technical Regulations) + !! Part A -- Alphanumeric Codes + !! 1995 edition + !! WMO-No. 306 + !! Secretariat of the World Meteorological Organization + !! Geneva, Switzerland + !! + !! History : + !! ! : 2007-04 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + + !! * Local declarations + INTEGER :: ji + + DO ji = 0, ntyp1770 + + cwmonam1770(ji) = 'Not defined' + ctypshort(ji) = '---' + +! IF ( ji < 1000 ) THEN +! WRITE(cwmotyp1770(ji),'(1X,I3.3)') ji +! ELSE +! WRITE(cwmotyp1770(ji),'(I4.4)') ji +! ENDIF + + END DO + + cwmonam1770( 1) = 'Sippican T-4' + cwmonam1770( 2) = 'Sippican T-4' + cwmonam1770( 11) = 'Sippican T-5' + cwmonam1770( 21) = 'Sippican Fast Deep' + cwmonam1770( 31) = 'Sippican T-6' + cwmonam1770( 32) = 'Sippican T-6' + cwmonam1770( 41) = 'Sippican T-7' + cwmonam1770( 42) = 'Sippican T-7' + cwmonam1770( 51) = 'Sippican Deep Blue' + cwmonam1770( 52) = 'Sippican Deep Blue' + cwmonam1770( 61) = 'Sippican T-10' + cwmonam1770( 71) = 'Sippican T-11' + cwmonam1770( 201) = 'TSK T-4' + cwmonam1770( 202) = 'TSK T-4' + cwmonam1770( 211) = 'TSK T-6' + cwmonam1770( 212) = 'TSK T-6' + cwmonam1770( 221) = 'TSK T-7' + cwmonam1770( 222) = 'TSK T-7' + cwmonam1770( 231) = 'TSK T-5' + cwmonam1770( 241) = 'TSK T-10' + cwmonam1770( 251) = 'TSK Deep Blue' + cwmonam1770( 252) = 'TSK Deep Blue' + cwmonam1770( 261) = 'TSK AXBT ' + cwmonam1770( 401) = 'Sparton XBT-1' + cwmonam1770( 411) = 'Sparton XBT-3' + cwmonam1770( 421) = 'Sparton XBT-4' + cwmonam1770( 431) = 'Sparton XBT-5' + cwmonam1770( 441) = 'Sparton XBT-5DB' + cwmonam1770( 451) = 'Sparton XBT-6' + cwmonam1770( 461) = 'Sparton XBT-7' + cwmonam1770( 462) = 'Sparton XBT-7' + cwmonam1770( 471) = 'Sparton XBT-7DB' + cwmonam1770( 481) = 'Sparton XBT-10' + cwmonam1770( 491) = 'Sparton XBT-20' + cwmonam1770( 501) = 'Sparton XBT-20DB' + cwmonam1770( 510) = 'Sparton 536 AXBT' + cwmonam1770( 700) = 'Sippican XCTD standard' + cwmonam1770( 710) = 'Sippican XCTD deep' + cwmonam1770( 720) = 'Sippican AXCTD' + cwmonam1770( 730) = 'Sippican SXCTD' + cwmonam1770( 741) = 'TSK XCTD' + cwmonam1770( 742) = 'TSK XCTD-2 ' + cwmonam1770( 743) = 'TSK XCTD-2F ' + cwmonam1770( 751) = 'TSK AXCTD ' + cwmonam1770( 800) = 'Mechanical BT' + cwmonam1770( 810) = 'Hydrocast' + cwmonam1770( 820) = 'Thermistor Chain' + cwmonam1770( 825) = 'Temperature (sonic) and pressure probes' + cwmonam1770( 830) = 'CTD' + cwmonam1770( 831) = 'CTD-P-ALACE float' + cwmonam1770( 840) = 'PROVOR, No conductivity sensor ' + cwmonam1770( 841) = 'PROVOR, Seabird conductivity sensor ' + cwmonam1770( 842) = 'PROVOR, FSI conductivity sensor ' + cwmonam1770( 845) = 'Web Research, No conductivity sensor ' + cwmonam1770( 846) = 'Web Research, Seabird conductivity sensor ' + cwmonam1770( 847) = 'Web Research. FSI conductivity sensor' + cwmonam1770( 850) = 'SOLO, No conductivity sensor ' + cwmonam1770( 851) = 'SOLO, Seabird conductivity sensor ' + cwmonam1770( 852) = 'SOLO, FSI conductivity sensor' + cwmonam1770( 855) = 'Profiling float, NINJA, no conductivity sensor' + cwmonam1770( 856) = 'Profiling float, NINJA, SBE conductivity sensor' + cwmonam1770( 857) = 'Profiling float, NINJA, FSI conductivity sensor' + cwmonam1770( 858) = 'Profiling float, NINJA, TSK conductivity sensor' + cwmonam1770( 900) = 'Sippican T-12 XBT' + cwmonam1770(1023) = 'Missing value' + + DO ji = 853, 854 + cwmonam1770(ji) = 'Reserved' + END DO + + DO ji = 859, 899 + cwmonam1770(ji) = 'Reserved' + END DO + + DO ji = 901, 999 + cwmonam1770(ji) = 'Reserved' + END DO + + DO ji = 1000, 1022 + cwmonam1770(ji) = 'Reserved' + END DO + + ctypshort(800) = 'MBT' + ctypshort(401) = 'XBT' + ctypshort(830) = 'CTD' + ctypshort(820) = 'MRB' + ctypshort(831) = 'PFL' + ctypshort(995) = 'DRB' + ctypshort(997) = 'APB' + ctypshort(996) = 'UOR' + ctypshort(700:799) = 'OSD' + + END SUBROUTINE obs_wmo_init + + SUBROUTINE obs_alt_typ_init + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_alt_typ_init *** + !! + !! ** Purpose : Initialize CLS altimeter code tables + !! + !! ** Method : Direct initialisation of variables + !! + !! ** Action : + !! + !! References : CLS + !1 SSALTO/DUACS User Handbook + !! (M)SLA and (M)ADT Near-Real Time and + !! Delayed time products + !! CLS-DOS-NT-06-034 + !! 2006 + !! CLS + !! 8-10 Rue Hermes + !! Parc Technologique du Canal + !! 31526 Ramonville St-Agne + !! France + !! + !! History : + !! ! : 2007-06 (K. Mogensen) Original code + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + + !! * Local declarations + + calttyp(0) = 'Unknown' + calttyp(1) = 'ERS-1' + calttyp(2) = 'ERS-2' + calttyp(3) = 'Topex/Poseidon' + calttyp(4) = 'Topex/Poseidon on its new orbit' + calttyp(5) = 'GFO' + calttyp(6) = 'Jason-1' + calttyp(7) = 'Envisat' + calttyp(8) = 'Jason-2' + + END SUBROUTINE obs_alt_typ_init + +END MODULE obs_types \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_utils.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_utils.F90 new file mode 100644 index 0000000..a58435c --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_utils.F90 @@ -0,0 +1,209 @@ +MODULE obs_utils + !!====================================================================== + !! *** MODULE obs_utils *** + !! Observation diagnostics: Utility functions + !!===================================================================== + + !!---------------------------------------------------------------------- + !! grt_cir_dis : Great circle distance + !! grt_cir_dis_saa : Great circle distance (small angle) + !! chkerr : Error-message managment for NetCDF files + !! chkdim : Error-message managment for NetCDF files + !! fatal_error : Fatal error handling + !! ddatetoymdhms : Convert YYYYMMDD.hhmmss to components + !!---------------------------------------------------------------------- + !! * Modules used + USE par_oce, ONLY : & ! Precision variables + & wp, & + & dp, & + & i8 + USE in_out_manager ! I/O manager + USE lib_mpp ! For ctl_warn/stop + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + PUBLIC grt_cir_dis, & ! Great circle distance + & grt_cir_dis_saa, & ! Great circle distance (small angle) + & str_c_to_for, & ! Remove non-printable chars from string + & chkerr, & ! Error-message managment for NetCDF files + & chkdim, & ! Check if dimensions are correct for a variable + & fatal_error, & ! Fatal error handling + & warning, & ! Warning handling + & ddatetoymdhms ! Convert YYYYMMDD.hhmmss to components + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_utils.F90 14275 2021-01-07 12:13:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "grt_cir_dis.h90" + +#include "grt_cir_dis_saa.h90" + +#include "str_c_to_for.h90" + + SUBROUTINE chkerr( kstatus, cd_name, klineno ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE chkerr *** + !! + !! ** Purpose : Error-message managment for NetCDF files. + !! + !! ** Method : + !! + !! ** Action : + !! + !! History + !! ! 02-12 (N. Daget) hdlerr + !! ! 06-04 (A. Vidard) f90/nemovar migration, change name + !! ! 06-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + !! * Modules used + USE netcdf ! NetCDF library + + !! * Arguments + INTEGER, INTENT(IN) :: kstatus + INTEGER, INTENT(IN) :: klineno + CHARACTER(LEN=*), INTENT(IN) :: cd_name + + !! * Local declarations + CHARACTER(len=200) :: clineno + + ! Main computation + IF ( kstatus /= nf90_noerr ) THEN + WRITE(clineno,'(A,I8)')' at line number ', klineno + CALL ctl_stop( ' chkerr', ' Netcdf Error in ' // TRIM( cd_name ), & + & clineno, nf90_strerror( kstatus ) ) + ENDIF + + END SUBROUTINE chkerr + + SUBROUTINE chkdim( kfileid, kvarid, kndim, kdim, cd_name, klineno ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE chkerr *** + !! + !! ** Purpose : Error-message managment for NetCDF files. + !! + !! ** Method : + !! + !! ** Action : + !! + !! History + !! ! 07-03 (K. Mogenen + E. Remy) Initial version + !!---------------------------------------------------------------------- + !! * Modules used + USE netcdf ! NetCDF library + + !! * Arguments + INTEGER :: kfileid ! NetCDF file id + INTEGER :: kvarid ! NetCDF variable id + INTEGER :: kndim ! Expected number of dimensions + INTEGER, DIMENSION(kndim) :: kdim ! Expected dimensions + CHARACTER(LEN=*) :: cd_name ! Calling routine name + INTEGER :: klineno ! Calling line number + + !! * Local declarations + INTEGER :: indim + INTEGER, ALLOCATABLE, DIMENSION(:) :: & + & idim,ilendim + INTEGER :: ji + LOGICAL :: llerr + CHARACTER(len=200) :: clineno + + CALL chkerr( nf90_inquire_variable( kfileid, kvarid, ndims=indim ), & + & cd_name, klineno ) + + ALLOCATE(idim(indim),ilendim(indim)) + + CALL chkerr( nf90_inquire_variable( kfileid, kvarid, dimids=idim ), & + & cd_name, klineno ) + + DO ji = 1, indim + CALL chkerr( nf90_inquire_dimension( kfileid, idim(ji), & + & len=ilendim(ji) ), & + & cd_name, klineno ) + END DO + + IF ( indim /= kndim ) THEN + WRITE(clineno,'(A,I8)')' at line number ', klineno + CALL ctl_stop( ' chkdim', & + & ' Netcdf no dim error in ' // TRIM( cd_name ), & + & clineno ) + ENDIF + + DO ji = 1, indim + IF ( ilendim(ji) /= kdim(ji) ) THEN + WRITE(clineno,'(A,I8)')' at line number ', klineno + CALL ctl_stop( ' chkdim', & + & ' Netcdf dim len error in ' // TRIM( cd_name ), & + & clineno ) + ENDIF + END DO + + DEALLOCATE(idim,ilendim) + + END SUBROUTINE chkdim + + SUBROUTINE fatal_error( cd_name, klineno ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE fatal_error *** + !! + !! ** Purpose : Fatal error handling + !! + !! ** Method : + !! + !! ** Action : + !! + !! History + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + INTEGER, INTENT(IN) :: klineno + CHARACTER(LEN=*) :: cd_name + !! * Local declarations + CHARACTER(len=200) :: clineno + + WRITE(clineno,'(A,I8)')' at line number ', klineno + CALL ctl_stop( ' fatal_error', ' Error in ' // TRIM( cd_name ), & + & clineno) + + END SUBROUTINE fatal_error + + SUBROUTINE warning( cd_name, klineno ) + !!---------------------------------------------------------------------- + !! + !! *** ROUTINE warning *** + !! + !! ** Purpose : Warning handling + !! + !! ** Method : + !! + !! ** Action : + !! + !! History + !!---------------------------------------------------------------------- + !! * Modules used + + !! * Arguments + INTEGER, INTENT(IN) :: klineno + CHARACTER(LEN=*) :: cd_name + !! * Local declarations + CHARACTER(len=200) :: clineno + + WRITE(clineno,'(A,I8)')' at line number ', klineno + CALL ctl_warn( ' warning', ' Potential problem in ' // TRIM( cd_name ), & + & clineno) + + END SUBROUTINE warning + +#include "ddatetoymdhms.h90" + +END MODULE obs_utils \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_write.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_write.F90 new file mode 100644 index 0000000..45253c1 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obs_write.F90 @@ -0,0 +1,632 @@ +MODULE obs_write + !!====================================================================== + !! *** MODULE obs_write *** + !! Observation diagnosticss: Write observation related diagnostics + !!===================================================================== + + !!---------------------------------------------------------------------- + !! obs_wri_prof : Write profile observations in feedback format + !! obs_wri_surf : Write surface observations in feedback format + !! obs_wri_stats : Print basic statistics on the data being written out + !!---------------------------------------------------------------------- + + !! * Modules used + USE par_kind, ONLY : & ! Precision variables + & wp + USE in_out_manager ! I/O manager + USE dom_oce ! Ocean space and time domain variables + USE obs_types ! Observation type integer to character translation + USE julian, ONLY : & ! Julian date routines + & greg2jul + USE obs_utils, ONLY : & ! Observation operator utility functions + & chkerr + USE obs_profiles_def ! Type definitions for profiles + USE obs_surf_def ! Type defintions for surface observations + USE obs_fbm ! Observation feedback I/O + USE obs_grid ! Grid tools + USE obs_conv ! Conversion between units + USE obs_const + USE obs_mpp ! MPP support routines for observation diagnostics + USE lib_mpp ! MPP routines + + IMPLICIT NONE + + !! * Routine accessibility + PRIVATE + PUBLIC obs_wri_prof, & ! Write profile observation files + & obs_wri_surf, & ! Write surface observation files + & obswriinfo + + TYPE obswriinfo + INTEGER :: inum + INTEGER, POINTER, DIMENSION(:) :: ipoint + CHARACTER(len=ilenname), POINTER, DIMENSION(:) :: cdname + CHARACTER(len=ilenlong), POINTER, DIMENSION(:,:) :: cdlong + CHARACTER(len=ilenunit), POINTER, DIMENSION(:,:) :: cdunit + END TYPE obswriinfo + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obs_write.F90 14275 2021-01-07 12:13:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_wri_prof( profdata, padd, pext ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_wri_prof *** + !! + !! ** Purpose : Write profile feedback files + !! + !! ** Method : NetCDF + !! + !! ** Action : + !! + !! History : + !! ! 06-04 (A. Vidard) Original + !! ! 06-04 (A. Vidard) Reformatted + !! ! 06-10 (A. Weaver) Cleanup + !! ! 07-01 (K. Mogensen) Use profile data types + !! ! 07-03 (K. Mogensen) General handling of profiles + !! ! 09-01 (K. Mogensen) New feedback format + !! ! 15-02 (M. Martin) Combined routine for writing profiles + !!----------------------------------------------------------------------- + + !! * Arguments + TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data + TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable + TYPE(obswriinfo), OPTIONAL :: pext ! Extra info + + !! * Local declarations + TYPE(obfbdata) :: fbdata + CHARACTER(LEN=40) :: clfname + CHARACTER(LEN=10) :: clfiletype + CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable + CHARACTER(LEN=ilenunit) :: clunits ! Units of variable + CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable + CHARACTER(LEN=12) :: clfmt ! writing format + INTEGER :: idg ! number of digits + INTEGER :: ilevel + INTEGER :: jvar + INTEGER :: jo + INTEGER :: jk + INTEGER :: ik + INTEGER :: ja + INTEGER :: je + INTEGER :: iadd + INTEGER :: iext + REAL(wp) :: zpres + + IF ( PRESENT( padd ) ) THEN + iadd = padd%inum + ELSE + iadd = 0 + ENDIF + + IF ( PRESENT( pext ) ) THEN + iext = pext%inum + ELSE + iext = 0 + ENDIF + + CALL init_obfbdata( fbdata ) + + ! Find maximum level + ilevel = 0 + DO jvar = 1, profdata%nvar + ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) + END DO + + SELECT CASE ( TRIM(profdata%cvars(1)) ) + CASE('POTM') + + clfiletype='profb' + CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & + & 1 + iadd, 1 + iext, .TRUE. ) + fbdata%cname(1) = profdata%cvars(1) + fbdata%cname(2) = profdata%cvars(2) + fbdata%coblong(1) = 'Potential temperature' + fbdata%coblong(2) = 'Practical salinity' + fbdata%cobunit(1) = 'Degrees centigrade' + fbdata%cobunit(2) = 'PSU' + fbdata%cextname(1) = 'TEMP' + fbdata%cextlong(1) = 'Insitu temperature' + fbdata%cextunit(1) = 'Degrees centigrade' + fbdata%caddlong(1,1) = 'Model interpolated potential temperature' + fbdata%caddlong(1,2) = 'Model interpolated practical salinity' + fbdata%caddunit(1,1) = 'Degrees centigrade' + fbdata%caddunit(1,2) = 'PSU' + fbdata%cgrid(:) = 'T' + DO je = 1, iext + fbdata%cextname(1+je) = pext%cdname(je) + fbdata%cextlong(1+je) = pext%cdlong(je,1) + fbdata%cextunit(1+je) = pext%cdunit(je,1) + END DO + DO ja = 1, iadd + fbdata%caddname(1+ja) = padd%cdname(ja) + DO jvar = 1, 2 + fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) + fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) + END DO + END DO + + CASE('UVEL') + + clfiletype='velfb' + CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 1, 0, .TRUE. ) + fbdata%cname(1) = profdata%cvars(1) + fbdata%cname(2) = profdata%cvars(2) + fbdata%coblong(1) = 'Zonal velocity' + fbdata%coblong(2) = 'Meridional velocity' + fbdata%cobunit(1) = 'm/s' + fbdata%cobunit(2) = 'm/s' + DO je = 1, iext + fbdata%cextname(je) = pext%cdname(je) + fbdata%cextlong(je) = pext%cdlong(je,1) + fbdata%cextunit(je) = pext%cdunit(je,1) + END DO + fbdata%caddlong(1,1) = 'Model interpolated zonal velocity' + fbdata%caddlong(1,2) = 'Model interpolated meridional velocity' + fbdata%caddunit(1,1) = 'm/s' + fbdata%caddunit(1,2) = 'm/s' + fbdata%cgrid(1) = 'U' + fbdata%cgrid(2) = 'V' + DO ja = 1, iadd + fbdata%caddname(1+ja) = padd%cdname(ja) + fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) + fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) + END DO + + END SELECT + + IF ( ( TRIM(profdata%cvars(1)) /= 'POTM' ) .AND. & + & ( TRIM(profdata%cvars(1)) /= 'UVEL' ) ) THEN + CALL alloc_obfbdata( fbdata, 1, profdata%nprof, ilevel, & + & 1 + iadd, iext, .TRUE. ) + fbdata%cname(1) = profdata%cvars(1) + fbdata%coblong(1) = cllongname + fbdata%cobunit(1) = clunits + fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(cllongname) + fbdata%caddunit(1,1) = clunits + fbdata%cgrid(:) = clgrid + DO je = 1, iext + fbdata%cextname(je) = pext%cdname(je) + fbdata%cextlong(je) = pext%cdlong(je,1) + fbdata%cextunit(je) = pext%cdunit(je,1) + END DO + DO ja = 1, iadd + fbdata%caddname(1+ja) = padd%cdname(ja) + fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) + fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) + END DO + ENDIF + + fbdata%caddname(1) = 'Hx' + + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' + WRITE(clfname,clfmt) TRIM(clfiletype), '_fdbk_', narea-1, '.nc' + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*)'obs_wri_prof :' + WRITE(numout,*)'~~~~~~~~~~~~~' + WRITE(numout,*)'Writing '//TRIM(clfiletype)//' feedback file : ',TRIM(clfname) + ENDIF + + ! Transform obs_prof data structure into obfb data structure + fbdata%cdjuldref = '19500101000000' + DO jo = 1, profdata%nprof + fbdata%plam(jo) = profdata%rlam(jo) + fbdata%pphi(jo) = profdata%rphi(jo) + WRITE(fbdata%cdtyp(jo),'(I4)') profdata%ntyp(jo) + fbdata%ivqc(jo,:) = profdata%ivqc(jo,:) + fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:) + IF ( profdata%nqc(jo) > 255 ) THEN + fbdata%ioqc(jo) = IBSET(profdata%nqc(jo),2) + fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo) + fbdata%ioqcf(2,jo) = profdata%nqc(jo) + ELSE + fbdata%ioqc(jo) = profdata%nqc(jo) + fbdata%ioqcf(:,jo) = profdata%nqcf(:,jo) + ENDIF + fbdata%ipqc(jo) = profdata%ipqc(jo) + fbdata%ipqcf(:,jo) = profdata%ipqcf(:,jo) + fbdata%itqc(jo) = profdata%itqc(jo) + fbdata%itqcf(:,jo) = profdata%itqcf(:,jo) + fbdata%cdwmo(jo) = profdata%cwmo(jo) + fbdata%kindex(jo) = profdata%npfil(jo) + DO jvar = 1, profdata%nvar + IF (ln_grid_global) THEN + fbdata%iobsi(jo,jvar) = profdata%mi(jo,jvar) + fbdata%iobsj(jo,jvar) = profdata%mj(jo,jvar) + ELSE + fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar)) + fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar)) + ENDIF + END DO + CALL greg2jul( 0, & + & profdata%nmin(jo), & + & profdata%nhou(jo), & + & profdata%nday(jo), & + & profdata%nmon(jo), & + & profdata%nyea(jo), & + & fbdata%ptim(jo), & + & krefdate = 19500101 ) + ! Reform the profiles arrays for output + DO jvar = 1, profdata%nvar + DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) + ik = profdata%var(jvar)%nvlidx(jk) + fbdata%padd(ik,jo,1,jvar) = profdata%var(jvar)%vmod(jk) + fbdata%pob(ik,jo,jvar) = profdata%var(jvar)%vobs(jk) + fbdata%pdep(ik,jo) = profdata%var(jvar)%vdep(jk) + fbdata%idqc(ik,jo) = profdata%var(jvar)%idqc(jk) + fbdata%idqcf(:,ik,jo) = profdata%var(jvar)%idqcf(:,jk) + IF ( profdata%var(jvar)%nvqc(jk) > 255 ) THEN + fbdata%ivlqc(ik,jo,jvar) = IBSET(profdata%var(jvar)%nvqc(jk),2) + fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk) +!$AGRIF_DO_NOT_TREAT + fbdata%ivlqcf(2,ik,jo,jvar) = IAND(profdata%var(jvar)%nvqc(jk),b'0000000011111111') +!$AGRIF_END_DO_NOT_TREAT + ELSE + fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) + fbdata%ivlqcf(:,ik,jo,jvar) = profdata%var(jvar)%nvqcf(:,jk) + ENDIF + fbdata%iobsk(ik,jo,jvar) = profdata%var(jvar)%mvk(jk) + DO ja = 1, iadd + fbdata%padd(ik,jo,1+ja,jvar) = & + & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) + END DO + DO je = 1, iext + fbdata%pext(ik,jo,1+je) = & + & profdata%var(jvar)%vext(jk,pext%ipoint(je)) + END DO + IF ( ( jvar == 1 ) .AND. & + & ( TRIM(profdata%cvars(1)) == 'POTM' ) ) THEN + fbdata%pext(ik,jo,1) = profdata%var(jvar)%vext(jk,1) + ENDIF + END DO + END DO + END DO + + IF ( TRIM(profdata%cvars(1)) == 'POTM' ) THEN + ! Convert insitu temperature to potential temperature using the model + ! salinity if no potential temperature + DO jo = 1, fbdata%nobs + IF ( fbdata%pphi(jo) < 9999.0 ) THEN + DO jk = 1, fbdata%nlev + IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & + & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & + & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & + & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN + zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & + & REAL(fbdata%pphi(jo),wp) ) + fbdata%pob(jk,jo,1) = potemp( & + & REAL(fbdata%padd(jk,jo,1,2), wp), & + & REAL(fbdata%pext(jk,jo,1), wp), & + & zpres, 0.0_wp ) + ENDIF + END DO + ENDIF + END DO + ENDIF + + ! Write the obfbdata structure + CALL write_obfbdata( clfname, fbdata ) + + ! Output some basic statistics + CALL obs_wri_stats( fbdata ) + + CALL dealloc_obfbdata( fbdata ) + + END SUBROUTINE obs_wri_prof + + SUBROUTINE obs_wri_surf( surfdata, padd, pext ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_wri_surf *** + !! + !! ** Purpose : Write surface observation files + !! + !! ** Method : NetCDF + !! + !! ** Action : + !! + !! ! 07-03 (K. Mogensen) Original + !! ! 09-01 (K. Mogensen) New feedback format. + !! ! 15-02 (M. Martin) Combined surface writing routine. + !!----------------------------------------------------------------------- + + !! * Modules used + IMPLICIT NONE + + !! * Arguments + TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data + TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable + TYPE(obswriinfo), OPTIONAL :: pext ! Extra info + + !! * Local declarations + TYPE(obfbdata) :: fbdata + CHARACTER(LEN=40) :: clfname ! netCDF filename + CHARACTER(LEN=10) :: clfiletype + CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable + CHARACTER(LEN=ilenunit) :: clunits ! Units of variable + CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable + CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' + CHARACTER(LEN=12) :: clfmt ! writing format + INTEGER :: idg ! number of digits + INTEGER :: jo + INTEGER :: ja + INTEGER :: je + INTEGER :: iadd + INTEGER :: iext + + IF ( PRESENT( padd ) ) THEN + iadd = padd%inum + ELSE + iadd = 0 + ENDIF + + IF ( PRESENT( pext ) ) THEN + iext = pext%inum + ELSE + iext = 0 + ENDIF + + CALL init_obfbdata( fbdata ) + + SELECT CASE ( TRIM(surfdata%cvars(1)) ) + CASE('SLA') + + ! SLA needs special treatment because of MDT, so is all done here + ! Other variables are done more generically + ! No climatology for SLA, MDT is our best estimate of that and is already output. + + CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & + & 2 + iadd, 1 + iext, .TRUE. ) + + clfiletype = 'slafb' + fbdata%cname(1) = surfdata%cvars(1) + fbdata%coblong(1) = 'Sea level anomaly' + fbdata%cobunit(1) = 'Metres' + fbdata%cextname(1) = 'MDT' + fbdata%cextlong(1) = 'Mean dynamic topography' + fbdata%cextunit(1) = 'Metres' + DO je = 1, iext + fbdata%cextname(je) = pext%cdname(je) + fbdata%cextlong(je) = pext%cdlong(je,1) + fbdata%cextunit(je) = pext%cdunit(je,1) + END DO + fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' + fbdata%caddunit(1,1) = 'Metres' + fbdata%caddname(2) = 'SSH' + fbdata%caddlong(2,1) = 'Model Sea surface height' + fbdata%caddunit(2,1) = 'Metres' + fbdata%cgrid(1) = 'T' + DO ja = 1, iadd + fbdata%caddname(2+ja) = padd%cdname(ja) + fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) + fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) + END DO + + CASE('SST') + + clfiletype = 'sstfb' + cllongname = 'Sea surface temperature' + clunits = 'Degree centigrade' + clgrid = 'T' + + CASE('ICECONC') + + clfiletype = 'sicfb' + cllongname = 'Sea ice concentration' + clunits = 'Fraction' + clgrid = 'T' + + CASE('SSS') + + clfiletype = 'sssfb' + cllongname = 'Sea surface salinity' + clunits = 'psu' + clgrid = 'T' + + CASE DEFAULT + + CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) + + END SELECT + + ! SLA needs special treatment because of MDT, so is done above + ! Remaining variables treated more generically + + IF ( TRIM(surfdata%cvars(1)) /= 'SLA' ) THEN + + CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & + & 1 + iadd, iext, .TRUE. ) + + fbdata%cname(1) = surfdata%cvars(1) + fbdata%coblong(1) = cllongname + fbdata%cobunit(1) = clunits + DO je = 1, iext + fbdata%cextname(je) = pext%cdname(je) + fbdata%cextlong(je) = pext%cdlong(je,1) + fbdata%cextunit(je) = pext%cdunit(je,1) + END DO + IF ( TRIM(surfdata%cvars(1)) == 'ICECONC' ) THEN + fbdata%caddlong(1,1) = 'Model interpolated ICE' + ELSE + fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(surfdata%cvars(1)) + ENDIF + fbdata%caddunit(1,1) = clunits + fbdata%cgrid(1) = clgrid + DO ja = 1, iadd + fbdata%caddname(1+ja) = padd%cdname(ja) + fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) + fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) + END DO + ENDIF + + fbdata%caddname(1) = 'Hx' + + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg ! '(a,a,ix.x,a)' + WRITE(clfname,clfmt) TRIM(clfiletype), '_fdbk_', narea-1, '.nc' + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*)'obs_wri_surf :' + WRITE(numout,*)'~~~~~~~~~~~~~' + WRITE(numout,*)'Writing '//TRIM(surfdata%cvars(1))//' feedback file : ',TRIM(clfname) + ENDIF + + ! Transform surf data structure into obfbdata structure + fbdata%cdjuldref = '19500101000000' + DO jo = 1, surfdata%nsurf + fbdata%plam(jo) = surfdata%rlam(jo) + fbdata%pphi(jo) = surfdata%rphi(jo) + WRITE(fbdata%cdtyp(jo),'(I4)') surfdata%ntyp(jo) + fbdata%ivqc(jo,:) = 0 + fbdata%ivqcf(:,jo,:) = 0 + IF ( surfdata%nqc(jo) > 255 ) THEN + fbdata%ioqc(jo) = 4 + fbdata%ioqcf(1,jo) = 0 +!$AGRIF_DO_NOT_TREAT + fbdata%ioqcf(2,jo) = IAND(surfdata%nqc(jo),b'0000000011111111') +!$AGRIF_END_DO_NOT_TREAT + ELSE + fbdata%ioqc(jo) = surfdata%nqc(jo) + fbdata%ioqcf(:,jo) = 0 + ENDIF + fbdata%ipqc(jo) = 0 + fbdata%ipqcf(:,jo) = 0 + fbdata%itqc(jo) = 0 + fbdata%itqcf(:,jo) = 0 + fbdata%cdwmo(jo) = surfdata%cwmo(jo) + fbdata%kindex(jo) = surfdata%nsfil(jo) + IF (ln_grid_global) THEN + fbdata%iobsi(jo,1) = surfdata%mi(jo) + fbdata%iobsj(jo,1) = surfdata%mj(jo) + ELSE + fbdata%iobsi(jo,1) = mig(surfdata%mi(jo)) + fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo)) + ENDIF + CALL greg2jul( 0, & + & surfdata%nmin(jo), & + & surfdata%nhou(jo), & + & surfdata%nday(jo), & + & surfdata%nmon(jo), & + & surfdata%nyea(jo), & + & fbdata%ptim(jo), & + & krefdate = 19500101 ) + fbdata%padd(1,jo,1,1) = surfdata%rmod(jo,1) + IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%padd(1,jo,2,1) = surfdata%rext(jo,1) + fbdata%pob(1,jo,1) = surfdata%robs(jo,1) + fbdata%pdep(1,jo) = 0.0 + fbdata%idqc(1,jo) = 0 + fbdata%idqcf(:,1,jo) = 0 + IF ( surfdata%nqc(jo) > 255 ) THEN + fbdata%ivqc(jo,1) = 4 + fbdata%ivlqc(1,jo,1) = 4 + fbdata%ivlqcf(1,1,jo,1) = 0 +!$AGRIF_DO_NOT_TREAT + fbdata%ivlqcf(2,1,jo,1) = IAND(surfdata%nqc(jo),b'0000000011111111') +!$AGRIF_END_DO_NOT_TREAT + ELSE + fbdata%ivqc(jo,1) = surfdata%nqc(jo) + fbdata%ivlqc(1,jo,1) = surfdata%nqc(jo) + fbdata%ivlqcf(:,1,jo,1) = 0 + ENDIF + fbdata%iobsk(1,jo,1) = 0 + IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%pext(1,jo,1) = surfdata%rext(jo,2) + DO ja = 1, iadd + fbdata%padd(1,jo,2+ja,1) = & + & surfdata%rext(jo,padd%ipoint(ja)) + END DO + DO je = 1, iext + fbdata%pext(1,jo,1+je) = & + & surfdata%rext(jo,pext%ipoint(je)) + END DO + END DO + + ! Write the obfbdata structure + CALL write_obfbdata( clfname, fbdata ) + + ! Output some basic statistics + CALL obs_wri_stats( fbdata ) + + CALL dealloc_obfbdata( fbdata ) + + END SUBROUTINE obs_wri_surf + + SUBROUTINE obs_wri_stats( fbdata ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_wri_stats *** + !! + !! ** Purpose : Output some basic statistics of the data being written out + !! + !! ** Method : + !! + !! ** Action : + !! + !! ! 2014-08 (D. Lea) Initial version + !!----------------------------------------------------------------------- + + !! * Arguments + TYPE(obfbdata) :: fbdata + + !! * Local declarations + INTEGER :: jvar + INTEGER :: jo + INTEGER :: jk + INTEGER :: inumgoodobs + INTEGER :: inumgoodobsmpp + REAL(wp) :: zsumx + REAL(wp) :: zsumx2 + REAL(wp) :: zomb + + + IF (lwp) THEN + WRITE(numout,*) '' + WRITE(numout,*) 'obs_wri_stats :' + WRITE(numout,*) '~~~~~~~~~~~~~~~' + ENDIF + + DO jvar = 1, fbdata%nvar + zsumx=0.0_wp + zsumx2=0.0_wp + inumgoodobs=0 + DO jo = 1, fbdata%nobs + DO jk = 1, fbdata%nlev + IF ( ( fbdata%pob(jk,jo,jvar) < 9999.0 ) .AND. & + & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & + & ( fbdata%padd(jk,jo,1,jvar) < 9999.0 ) ) THEN + + zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar) + zsumx=zsumx+zomb + zsumx2=zsumx2+zomb**2 + inumgoodobs=inumgoodobs+1 + ENDIF + ENDDO + ENDDO + + CALL obs_mpp_sum_integer( inumgoodobs, inumgoodobsmpp ) + CALL mpp_sum('obs_write', zsumx) + CALL mpp_sum('obs_write', zsumx2) + + IF (lwp) THEN + WRITE(numout,*) 'Type: ',fbdata%cname(jvar),' Total number of good observations: ',inumgoodobsmpp + WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/inumgoodobsmpp + WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/inumgoodobsmpp ) + WRITE(numout,*) '' + ENDIF + + ENDDO + + END SUBROUTINE obs_wri_stats + +END MODULE obs_write \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obsinter_h2d.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obsinter_h2d.h90 new file mode 100644 index 0000000..103db7a --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obsinter_h2d.h90 @@ -0,0 +1,1359 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obsinter_h2d.h90 10353 2018-11-21 16:04:47Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE obs_int_h2d_init( kpk, kpk2, k2dint, plam, pphi, & + & pglam, pgphi, pmask, pweig, pobsmask, & + & iminpoints ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d *** + !! + !! ** Purpose : Computes weights for horizontal interpolation to the + !! observation point. + !! + !! ** Method : Horizontal interpolation to the observation point using + !! model values at the corners of the surrounding grid + !! points. + !! + !! Interpolation Schemes : + !! + !! 1) k2dint = 0: Distance-weighted interpolation scheme 1 + !! + !! The interpolation weights are computed as a weighted + !! sum of the distance between the model grid points (A) + !! and the observation point (B). Distance (s) is computed + !! using the great-circle distance formula: + !! + !! s(AB) = arcos( sin( phiA ) x sin( phiB ) + !! + cos( phiA ) x cos( phiB ) + !! x cos( lamB - lamA ) ) + !! + !! 2) k2dint = 1: Distance-weighted interpolation scheme 2 + !! + !! As k2dint = 0 but with distance (ds) computed using + !! a small-angle approximation to the great-circle formula: + !! + !! ds(AB) = sqrt( ( phiB - phiA )^{2} + !! + ( ( lamB - lamA ) * cos( phiB ) )^{2} ) + !! + !! 3) k2dint = 2: Bilinear interpolation on a geographical grid + !! + !! The interpolation is split into two 1D interpolations in + !! the longitude and latitude directions, respectively. + !! + !! 4) k2dint = 3: General bilinear remapping interpolation + !! + !! An iterative scheme that involves first mapping a + !! quadrilateral cell into a cell with coordinates + !! (0,0), (1,0), (0,1) and (1,1). + !! + !! 5) k2dint = 4: Polynomial interpolation + !! + !! The interpolation weights are computed by fitting a + !! polynomial function of the form + !! + !! P(i) = a1(i) + a2(i) * phi + a3(i) * plam + !! + a4(i) * phi * plam + !! + !! through the model values at the four surrounding grid points. + !! + !! ** Action : + !! + !! References : Jones, P.: A users guide for SCRIP: A Spherical + !! Coordinate Remapping and Interpolation Package. + !! Version 1.4. Los Alomos. + !! + !! http://www.acl.lanl.gov/climate/software/SCRIP/SCRIPmain.html + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) NEMOVAR migration + !! ! 06-10 (A. Weaver) Cleanup + !! ! 07-08 (K. Mogensen) Split in two routines for easier adj. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk, & ! Parameter values for automatic arrays + & kpk2, & + & k2dint ! Interpolation scheme options + ! = 0 distance-weighted (great circle) + ! = 1 distance-weighted (small angle) + ! = 2 bilinear (geographical grid) + ! = 3 bilinear (quadrilateral grid) + ! = 4 polynomial (quadrilateral grid) + REAL(KIND=wp), INTENT(INOUT) :: & + & plam, & + & pphi ! Geographical (lat,lon) coordinates of + ! observation + REAL(KIND=wp), DIMENSION(2,2), INTENT(IN) :: & + & pglam, & ! Model variable lat + & pgphi ! Model variable lon + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(OUT) :: & + & pweig ! Weights for interpolation + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & pobsmask ! Vertical mask for observations + INTEGER, INTENT(IN), OPTIONAL :: & + & iminpoints ! Reject point which is not surrounded + ! by at least iminpoints sea points + + !! * Local declarations + INTEGER :: & + & jk + INTEGER :: & + & ikmax, & + & iamb1, & + & iamb2 + REAL(KIND=wp) :: & + & zphimm, & + & zphimp, & + & zphipm, & + & zphipp, & + & zlammm, & + & zlammp, & + & zlampm, & + & zlampp, & + & zphimin, & + & zphimax, & + & zlammin, & + & zlammax + REAL(KIND=wp), DIMENSION(kpk2) :: & + & z2dmm, & + & z2dmp, & + & z2dpm, & + & z2dpp, & + & z2dmmt, & + & z2dmpt, & + & z2dpmt, & + & z2dppt, & + & zsum + LOGICAL :: & + & ll_ds1, & + & ll_skip, & + & ll_fail + + !------------------------------------------------------------------------ + ! Constants for the 360 degrees ambiguity + !------------------------------------------------------------------------ + iamb1 = 10 ! dlam < iamb1 * dphi + iamb2 = 3 ! Special treatment if iamb2 * lam < max(lam) + + !------------------------------------------------------------------------ + ! Initialize number of levels + !------------------------------------------------------------------------ + IF ( kpk2 == 1 ) THEN + ikmax = 1 + ELSEIF ( kpk2 == kpk) THEN + ikmax = kpk-1 + ENDIF + !------------------------------------------------------------------------ + ! Initialize the cell corners + !------------------------------------------------------------------------ + zphimm = pgphi(1,1) + zphimp = pgphi(1,2) + zphipm = pgphi(2,1) + zphipp = pgphi(2,2) + zlammm = pglam(1,1) + zlammp = pglam(1,2) + zlampm = pglam(2,1) + zlampp = pglam(2,2) + + !------------------------------------------------------------------------ + ! Treat the 360 degrees ambiguity + !------------------------------------------------------------------------ + DO WHILE ( ( zlammm < 0.0_wp ).OR.( zlammm > 360.0_wp ) & + & .OR.( zlampm < 0.0_wp ).OR.( zlampm > 360.0_wp ) & + & .OR.( zlampp < 0.0_wp ).OR.( zlampp > 360.0_wp ) & + & .OR.( zlammp < 0.0_wp ).OR.( zlammp > 360.0_wp ) ) + + IF ( zlammm < 0.0_wp ) zlammm = zlammm + 360.0_wp + IF ( zlammm > 360.0_wp ) zlammm = zlammm - 360.0_wp + IF ( zlammp < 0.0_wp ) zlammp = zlammp + 360.0_wp + IF ( zlammp > 360.0_wp ) zlammp = zlammp - 360.0_wp + IF ( zlampm < 0.0_wp ) zlampm = zlampm + 360.0_wp + IF ( zlampm > 360.0_wp ) zlampm = zlampm - 360.0_wp + IF ( zlampp < 0.0_wp ) zlampp = zlampp + 360.0_wp + IF ( zlampp > 360.0_wp ) zlampp = zlampp - 360.0_wp + + END DO + + DO WHILE ( ( plam < 0.0_wp ) .OR. ( plam > 360.0_wp ) ) + IF ( plam < 0.0_wp ) plam = plam + 360.0_wp + IF ( plam > 360.0_wp ) plam = plam - 360.0_wp + END DO + + !------------------------------------------------------------------------ + ! Special case for observation on grid points + !------------------------------------------------------------------------ + ll_skip = .FALSE. + IF ( ( ABS( zphimm - pphi ) < 1.0e-6_wp ) .AND. & + & ( ABS( zlammm - plam ) < 1.0e-6_wp ) ) THEN + z2dmm(:) = 1.0_wp + z2dpm(:) = 0.0_wp + z2dmp(:) = 0.0_wp + z2dpp(:) = 0.0_wp + ll_skip = .TRUE. + ENDIF + IF ( ( ABS( zphipm - pphi ) < 1.0e-6_wp ) .AND. & + & ( ABS( zlampm - plam ) < 1.0e-6_wp ) ) THEN + z2dmm(:) = 0.0_wp + z2dpm(:) = 1.0_wp + z2dmp(:) = 0.0_wp + z2dpp(:) = 0.0_wp + ll_skip = .TRUE. + ENDIF + IF ( ( ABS( zphimp - pphi ) < 1.0e-6_wp ) .AND. & + & ( ABS( zlammp - plam ) < 1.0e-6_wp ) ) THEN + z2dmm(:) = 0.0_wp + z2dpm(:) = 0.0_wp + z2dmp(:) = 1.0_wp + z2dpp(:) = 0.0_wp + ll_skip = .TRUE. + ENDIF + IF ( ( ABS( zphipp - pphi ) < 1.0e-6_wp ) .AND. & + & ( ABS( zlampp - plam ) < 1.0e-6_wp ) ) THEN + z2dmm(:) = 0.0_wp + z2dpm(:) = 0.0_wp + z2dmp(:) = 0.0_wp + z2dpp(:) = 1.0_wp + ll_skip = .TRUE. + ENDIF + + IF ( .NOT.ll_skip ) THEN + + zphimin = MIN( zphimm, zphipm, zphipp, zphimp ) + zphimax = MAX( zphimm, zphipm, zphipp, zphimp ) + zlammin = MIN( zlammm, zlampm, zlampp, zlammp ) + zlammax = MAX( zlammm, zlampm, zlampp, zlammp ) + + IF ( ( ( zlammax - zlammin ) / ( zphimax - zphimin ) ) > iamb1 ) THEN + IF ( iamb2 * zlammm < zlammax ) zlammm = zlammm + 360.0_wp + IF ( iamb2 * zlammp < zlammax ) zlammp = zlammp + 360.0_wp + IF ( iamb2 * zlampm < zlammax ) zlampm = zlampm + 360.0_wp + IF ( iamb2 * zlampp < zlammax ) zlampp = zlampp + 360.0_wp + ENDIF + + zlammin = MIN( zlammm, zlampm, zlampp, zlammp ) + IF ( zlammm > ( zlammin + 180.0_wp ) ) zlammm = zlammm - 360.0_wp + IF ( zlammp > ( zlammin + 180.0_wp ) ) zlammp = zlammp - 360.0_wp + IF ( zlampm > ( zlammin + 180.0_wp ) ) zlampm = zlampm - 360.0_wp + IF ( zlampp > ( zlammin + 180.0_wp ) ) zlampp = zlampp - 360.0_wp + + IF ( plam < zlammin ) plam = plam + 360.0_wp + z2dmm = 0.0_wp + z2dmp = 0.0_wp + z2dpm = 0.0_wp + z2dpp = 0.0_wp + SELECT CASE (k2dint) + + CASE(0) + CALL obs_int_h2d_ds1( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + CASE(1) + CALL obs_int_h2d_ds2( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + CASE(2) + CALL obs_int_h2d_bil( kpk2, ikmax, & + & pphi, plam, pmask, & + & zlammp, & + & zphipm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + CASE(3) + CALL obs_int_h2d_bir( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp, ll_fail ) + IF (ll_fail) THEN + IF(lwp) THEN + WRITE(numout,*)'Bilinear weight computation failed' + WRITE(numout,*)'Switching to great circle distance' + WRITE(numout,*) + ENDIF + CALL obs_int_h2d_ds1( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + ENDIF + CASE(4) + CALL obs_int_h2d_pol( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmm, z2dmp, z2dpm, z2dpp ) + END SELECT + + ENDIF + !------------------------------------------------------------------------ + ! Compute weights for interpolation to the observation point + !------------------------------------------------------------------------ + pobsmask(:) = 0.0_wp + pweig(:,:,:) = 0.0_wp + ! ll_ds1 is used for failed interpolations + ll_ds1 = .FALSE. + DO jk = 1, ikmax + IF (PRESENT(iminpoints)) THEN + IF (NINT(SUM(pmask(:,:,jk))) 0.0_wp ) .AND. & + & ( pmask(1,1,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dmp(jk) > 0.0_wp ) .AND. & + & ( pmask(1,2,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dpm(jk) > 0.0_wp ) .AND. & + & ( pmask(2,1,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dpp(jk) > 0.0_wp ) .AND. & + & ( pmask(2,2,jk) == 1.0_wp ) ) ) pobsmask(jk)=1.0_wp + ELSE + ! If the interpolation has failed due to the point + ! being on the intersect of two land points retry with + ! k2dint = 0 + IF ( ( pmask(1,1,jk) /= 0.0_wp ).OR. & + & ( pmask(1,2,jk) /= 0.0_wp ).OR. & + & ( pmask(2,1,jk) /= 0.0_wp ).OR. & + & ( pmask(2,2,jk) /= 0.0_wp ) ) THEN + ! If ll_ds1 is false compute k2dint = 0 weights + IF ( .NOT.ll_ds1 ) THEN + CALL obs_int_h2d_ds1( kpk2, ikmax, & + & pphi, plam, pmask, & + & zphimm, zlammm, zphimp, zlammp, & + & zphipm, zlampm, zphipp, zlampp, & + & z2dmmt, z2dmpt, z2dpmt, z2dppt ) + ll_ds1 = .TRUE. + ENDIF + zsum(jk) = z2dmmt(jk) + z2dmpt(jk) + z2dpmt(jk) + z2dppt(jk) + IF ( zsum(jk) /= 0.0_wp ) THEN + pweig(1,1,jk) = z2dmmt(jk) + pweig(1,2,jk) = z2dmpt(jk) + pweig(2,1,jk) = z2dpmt(jk) + pweig(2,2,jk) = z2dppt(jk) + ! Set the vertical mask + IF ( ( ( z2dmmt(jk) > 0.0_wp ) .AND. & + & ( pmask(1,1,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dmpt(jk) > 0.0_wp ) .AND. & + & ( pmask(1,2,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dpmt(jk) > 0.0_wp) .AND. & + & ( pmask(2,1,jk) == 1.0_wp ) ) .OR. & + & ( ( z2dppt(jk) > 0.0_wp ) .AND. & + & ( pmask(2,2,jk) == 1.0_wp ) ) ) & + & pobsmask(jk)=1.0_wp + ENDIF + ENDIF + ENDIF + END DO + + END SUBROUTINE obs_int_h2d_init + + SUBROUTINE obs_int_h2d( kpk, kpk2, & + & pweig, pmod, pobsk ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d *** + !! + !! ** Purpose : Horizontal interpolation to the observation point. + !! + !! ** Method : Horizontal interpolation to the observation point using + !! model values at the corners of the surrounding grid + !! points. + !! + !! ** Action : + !! + !! References : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) NEMOVAR migration + !! ! 06-10 (A. Weaver) Cleanup + !! ! 07-08 (K. Mogensen) Split in two routines for easier adj. + !!----------------------------------------------------------------------- + !! * Modules used + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk, & ! Parameter values for automatic arrays + & kpk2 + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pweig ! Interpolation weights + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmod ! Model variable to interpolate + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & pobsk ! Model profile interpolated to obs (i,j) pt + + !! * Local declarations + INTEGER :: & + & jk + INTEGER :: & + & ikmax + REAL(KIND=wp) :: & + & zsum + !------------------------------------------------------------------------ + ! Initialize number of levels + !------------------------------------------------------------------------ + IF ( kpk2 == 1 ) THEN + ikmax = 1 + ELSEIF ( kpk2 == kpk) THEN + ikmax = kpk-1 + ENDIF + !------------------------------------------------------------------------ + ! Interpolate to the observation point + !------------------------------------------------------------------------ + pobsk(:) = obfillflt + DO jk = 1, ikmax + zsum = pweig(1,1,jk) + pweig(1,2,jk) + pweig(2,1,jk) + pweig(2,2,jk) + IF ( zsum /= 0.0_wp ) THEN + pobsk(jk) = ( pweig(1,1,jk) * pmod(1,1,jk) & + & + pweig(1,2,jk) * pmod(1,2,jk) & + & + pweig(2,1,jk) * pmod(2,1,jk) & + & + pweig(2,2,jk) * pmod(2,2,jk) & + & ) / zsum + ENDIF + END DO + + END SUBROUTINE obs_int_h2d + + SUBROUTINE obs_int_h2d_ds1( kpk2, kmax, & + & pphi, plam, pmask, & + & pphimm, plammm, pphimp, plammp, & + & pphipm, plampm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_ds1 *** + !! + !! ** Purpose : Distance-weighted interpolation scheme (k2dint = 0) + !! + !! ** Method : The interpolation weights are computed as a weighted + !! sum of the distance between the model grid points (A) + !! and the observation point (B). + !! + !! Distance (s) is computed using the great-circle distance formula: + !! + !! s(AB) = arcos( sin( phiA ) x sin( phiB ) + !! + cos( phiA ) x cos( phiB ) x cos( lamB - lamA ) + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Modules used + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zphi2, & + & zlam2, & + & zcola, & + & za2, & + & zb2, & + & zc2, & + & zphimm2, & + & zphimp2, & + & zphipm2, & + & zphipp2, & + & zlammm2, & + & zlammp2, & + & zlampm2, & + & zlampp2, & + & za1mm, & + & za1mp, & + & za1pm, & + & za1pp, & + & zcomm, & + & zcomp, & + & zcopm, & + & zcopp, & + & zb1mm, & + & zb1mp, & + & zb1pm, & + & zb1pp, & + & zc1mm, & + & zc1mp, & + & zc1pm, & + & zc1pp, & + & zsopmpp, & + & zsommmp, & + & zsomm, & + & zsomp, & + & zsopm, & + & zsopp + + !------------------------------------------------------------------------ + ! Distance-weighted interpolation using the great circle formula + !------------------------------------------------------------------------ + zphi2 = pphi * rad + zlam2 = plam * rad + zcola = COS( zphi2 ) + za2 = SIN( zphi2 ) + zb2 = zcola * COS( zlam2 ) + zc2 = zcola * SIN( zlam2 ) + + zphimm2 = pphimm * rad + zphimp2 = pphimp * rad + zphipm2 = pphipm * rad + zphipp2 = pphipp * rad + + zlammm2 = plammm * rad + zlammp2 = plammp * rad + zlampm2 = plampm * rad + zlampp2 = plampp * rad + + za1mm = SIN( zphimm2 ) + za1mp = SIN( zphimp2 ) + za1pm = SIN( zphipm2 ) + za1pp = SIN( zphipp2 ) + + zcomm = COS( zphimm2 ) + zcomp = COS( zphimp2 ) + zcopm = COS( zphipm2 ) + zcopp = COS( zphipp2 ) + + zb1mm = zcomm * COS( zlammm2 ) + zb1mp = zcomp * COS( zlammp2 ) + zb1pm = zcopm * COS( zlampm2 ) + zb1pp = zcopp * COS( zlampp2 ) + + zc1mm = zcomm * SIN( zlammm2 ) + zc1mp = zcomp * SIN( zlammp2 ) + zc1pm = zcopm * SIN( zlampm2 ) + zc1pp = zcopp * SIN( zlampp2 ) + + ! Function for arcsin(sqrt(1-x^2) version of great-circle formula + zsomm = grt_cir_dis( za1mm, za2, zb1mm, zb2, zc1mm, zc2 ) + zsomp = grt_cir_dis( za1mp, za2, zb1mp, zb2, zc1mp, zc2 ) + zsopm = grt_cir_dis( za1pm, za2, zb1pm, zb2, zc1pm, zc2 ) + zsopp = grt_cir_dis( za1pp, za2, zb1pp, zb2, zc1pp, zc2 ) + + zsopmpp = zsopm * zsopp + zsommmp = zsomm * zsomp + DO jk = 1, kmax + p2dmm(jk) = zsomp * zsopmpp * pmask(1,1,jk) + p2dmp(jk) = zsomm * zsopmpp * pmask(1,2,jk) + p2dpm(jk) = zsopp * zsommmp * pmask(2,1,jk) + p2dpp(jk) = zsopm * zsommmp * pmask(2,2,jk) + END DO + + END SUBROUTINE obs_int_h2d_ds1 + + SUBROUTINE obs_int_h2d_ds2( kpk2, kmax, & + & pphi, plam, pmask, & + & pphimm, plammm, pphimp, plammp, & + & pphipm, plampm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_ds2 *** + !! + !! ** Purpose : Distance-weighted interpolation scheme (k2dint = 1) + !! + !! ** Method : As k2dint = 0 but with distance (ds) computed using a + !! small-angle approximation to the great-circle distance + !! formula: + !! + !! ds(AB) = sqrt( ( phiB - phiA )^{2} + !! + ( ( lamB - lamA ) * cos( phiB ) )^{2} ) + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !!----------------------------------------------------------------------- + !! * Modules used + !!----------------------------------------------------------------------- + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zcosp, & + & zdlmm, & + & zdlmp, & + & zdlpm, & + & zdlpp, & + & zdpmm, & + & zdpmp, & + & zdppm, & + & zdppp, & + & zsomm, & + & zsomp, & + & zsopm, & + & zsopp, & + & zsopmpp, & + & zsommmp + + !------------------------------------------------------------------------ + ! Distance-weighted interpolation with a small angle approximation + !------------------------------------------------------------------------ + zcosp = COS( pphi * rad ) + + zdlmm = plammm - plam + zdlmp = plammp - plam + zdlpm = plampm - plam + zdlpp = plampp - plam + + zdpmm = pphimm - pphi + zdpmp = pphimp - pphi + zdppm = pphipm - pphi + zdppp = pphipp - pphi + + zsomm = grt_cir_dis_saa( zdlmm, zdpmm, zcosp ) + zsomp = grt_cir_dis_saa( zdlmp, zdpmp, zcosp ) + zsopm = grt_cir_dis_saa( zdlpm, zdppm, zcosp ) + zsopp = grt_cir_dis_saa( zdlpp, zdppp, zcosp ) + + zsopmpp = zsopm * zsopp + zsommmp = zsomm * zsomp + + DO jk = 1, kmax + p2dmm(jk) = zsomp * zsopmpp * pmask(1,1,jk) + p2dmp(jk) = zsomm * zsopmpp * pmask(1,2,jk) + p2dpm(jk) = zsopp * zsommmp * pmask(2,1,jk) + p2dpp(jk) = zsopm * zsommmp * pmask(2,2,jk) + END DO + + END SUBROUTINE obs_int_h2d_ds2 + + SUBROUTINE obs_int_h2d_bil( kpk2, kmax, & + & pphi, plam, pmask, & + & plammp, pphipm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_bil *** + !! + !! ** Purpose : Bilinear interpolation on a geographical grid (k2dint = 2) + !! + !! ** Method : The interpolation is split into two 1D interpolations in + !! the longitude and latitude directions, respectively. + !! + !! An iterative scheme that involves first mapping a quadrilateral + !! cell into a cell with coordinates (0,0), (1,0), (0,1) and (1,1). + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphipm, & ! Geographical location of surrounding + & pphipp, & ! model grid points + & plammp, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zdlmp, & + & zdppm, & + & zdlpp, & + & zdppp + + !---------------------------------------------------------------------- + ! Bilinear interpolation for geographical grid + !---------------------------------------------------------------------- + zdlmp = ABS(plam - plammp) + zdppm = ABS(pphi - pphipm) + zdlpp = ABS(plampp - plam) + zdppp = ABS(pphipp - pphi) + + DO jk = 1, kmax + p2dmm(jk) = zdlpp * zdppp * pmask(1,1,jk) + p2dmp(jk) = zdlpp * zdppm * pmask(1,2,jk) + p2dpm(jk) = zdlmp * zdppp * pmask(2,1,jk) + p2dpp(jk) = zdlmp * zdppm * pmask(2,2,jk) + END DO + + END SUBROUTINE obs_int_h2d_bil + + SUBROUTINE obs_int_h2d_bir( kpk2, kmax, & + & pphi, plam, pmask, & + & pphimm, plammm, pphimp, plammp, & + & pphipm, plampm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp, ldfail ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_bir *** + !! + !! ** Purpose : General bilinear remapping interpolation (k2dint = 3) + !! + !! ** Method : An iterative scheme that involves first mapping a + !! quadrilateral cell into a cell with coordinates + !! (0,0), (1,0), (0,1) and (1,1). + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + LOGICAL, INTENT(OUT) :: & + & ldfail + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zbiwmm, & + & zbiwmp, & + & zbiwpm, & + & zbiwpp + + !---------------------------------------------------------------------- + ! Bilinear remapping interpolation for general quadrilateral grid + !---------------------------------------------------------------------- + CALL bil_wgt( pphimm, pphimp, pphipm, pphipp, & + & plammm, plammp, plampm, plampp, & + & zbiwmm, zbiwmp, zbiwpm, zbiwpp, & + & pphi , plam, ldfail ) + + IF ( .NOT.ldfail ) THEN + DO jk = 1, kmax + p2dmm(jk) = zbiwmm * pmask(1,1,jk) + p2dmp(jk) = zbiwmp * pmask(1,2,jk) + p2dpm(jk) = zbiwpm * pmask(2,1,jk) + p2dpp(jk) = zbiwpp * pmask(2,2,jk) + END DO + ENDIF + + END SUBROUTINE obs_int_h2d_bir + + SUBROUTINE obs_int_h2d_pol( kpk2, kmax, & + & pphi, plam, pmask, & + & pphimm, plammm, pphimp, plammp, & + & pphipm, plampm, pphipp, plampp, & + & p2dmm, p2dmp, p2dpm, p2dpp ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_h2d_pol *** + !! + !! ** Purpose : Polynomial interpolation (k2dint = 4) + !! + !! ** Method : The interpolation weights are computed by fitting a + !! polynomial function of the form + !! + !! P(i) = a1(i) + a2(i) * phi + a3(i) * plam + a4(i) * phi * plam + !! + !! through the model values at four surrounding grid pts (i=1,4). + !! As k2dint = 0 but with distance (ds) computed using a small- + !! angle approximation to the great-circle distance formula: + !! + !! ds(AB) = sqrt( ( phiB - phiA )^{2} + !! + ( ( lamB - lamA ) * cos( phiB ) )^{2} ) + !! + !! ** Action : + !! + !! History : + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kpk2, & ! Parameter values for automatic arrays + & kmax + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), DIMENSION(2,2,kpk2), INTENT(IN) :: & + & pmask ! Model variable mask + REAL(KIND=wp), DIMENSION(kpk2), INTENT(OUT) :: & + & p2dmm, & ! Interpolation weights + & p2dmp, & + & p2dpm, & + & p2dpp + + !! * Local declarations + INTEGER :: & + & jk + REAL(KIND=wp) :: & + & zplp + REAL(KIND=wp), DIMENSION(4,4) :: & + & zmat, & + & zmati + + !------------------------------------------------------------------------ + ! Polynomial interpolation + !------------------------------------------------------------------------ + zmat(1,1) = 1.0_wp + zmat(1,2) = 1.0_wp + zmat(1,3) = 1.0_wp + zmat(1,4) = 1.0_wp + zmat(2,1) = plammm + zmat(2,2) = plammp + zmat(2,3) = plampm + zmat(2,4) = plampp + zmat(3,1) = pphimm + zmat(3,2) = pphimp + zmat(3,3) = pphipm + zmat(3,4) = pphipp + zmat(4,1) = plammm * pphimm + zmat(4,2) = plammp * pphimp + zmat(4,3) = plampm * pphipm + zmat(4,4) = plampp * pphipp + + CALL lu_invmat( zmat, 4, zmati ) + + zplp = plam * pphi + DO jk = 1, kmax + p2dmm(jk) = ABS( zmati(1,1) + zmati(1,2) * plam & + & + zmati(1,3) * pphi + zmati(1,4) * zplp ) & + & * pmask(1,1,jk) + p2dmp(jk) = ABS( zmati(2,1) + zmati(2,2) * plam & + & + zmati(2,3) * pphi + zmati(2,4) * zplp ) & + & * pmask(1,2,jk) + p2dpm(jk) = ABS( zmati(3,1) + zmati(3,2) * plam & + & + zmati(3,3) * pphi + zmati(3,4) * zplp ) & + & * pmask(2,1,jk) + p2dpp(jk) = ABS( zmati(4,1) + zmati(4,2) * plam & + & + zmati(4,3) * pphi + zmati(4,4) * zplp ) & + & * pmask(2,2,jk) + END DO + + END SUBROUTINE obs_int_h2d_pol + + SUBROUTINE bil_wgt( pphimm, pphimp, pphipm, pphipp, & + & plammm, plammp, plampm, plampp, & + & pbiwmm, pbiwmp, pbiwpm, pbiwpp, & + & pphi , plam, ldfail ) + !!------------------------------------------------------------------- + !! + !! *** ROUTINE bil_wgt *** + !! + !! ** Purpose : Compute the weights for a bilinear remapping + !! interpolation scheme. + !! + !! ** Method : This scheme is appropriate for bilinear interpolation + !! on a general quadrilateral grid. + !! This scheme is also used in OASIS. + !! + !! This routine is a derivative of the SCRIP software. + !! Copyright 1997, 1998 the Regents of the University + !! of California. See SCRIP_Copyright.txt. + !! + !! ** Action : + !! + !! References : Jones, P.: A user's guide for SCRIP: A Spherical + !! Coordinate Remapping and Interpolation Package. + !! Version 1.4. Los Alamos. + !! + !! http://www.acl.lanl.gov/climate/software/SCRIP/SCRIPmain.html + !! + !! History + !! ! 97-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + REAL(KIND=wp), INTENT(IN) :: & + & pphi, & ! Geographical location of observation + & plam, & + & pphimm, & ! Geographical location of surrounding + & pphimp, & ! model grid points + & pphipm, & + & pphipp, & + & plammm, & + & plammp, & + & plampm, & + & plampp + REAL(KIND=wp), INTENT(OUT) :: & + & pbiwmm, & ! Interpolation weights + & pbiwmp, & + & pbiwpm, & + & pbiwpp + LOGICAL, INTENT(out) :: & + & ldfail + + !! * Local declarations + INTEGER :: & + & jiter + INTEGER :: & + & itermax + REAL(KIND=wp) :: & + & zphi, & ! Geographical location of observation + & zlam, & + & zphimm, & ! Geographical location of surrounding + & zphimp, & ! model grid points + & zphipm, & + & zphipp, & + & zlammm, & + & zlammp, & + & zlampm, & + & zlampp, & + & zdth1, & + & zdth2, & + & zdth3, & + & zdthp, & + & zdph1, & + & zdph2, & + & zdph3, & + & zdphp, & + & zmat1, & + & zmat2, & + & zmat3, & + & zmat4, & + & zdeli, & + & zdelj, & + & ziguess, & + & zjguess, & + & zeps, & + & zdeterm, & + & z2pi, & + & zhpi + + ! Initialization + + ! Conversion to radians + + zphi = pphi * rad + zlam = plam * rad + zphimm = pphimm * rad + zphimp = pphimp * rad + zphipm = pphipm * rad + zphipp = pphipp * rad + zlammm = plammm * rad + zlammp = plammp * rad + zlampm = plampm * rad + zlampp = plampp * rad + + ldfail = .FALSE. + + zdth1 = zphipm - zphimm + zdth2 = zphimp - zphimm + zdth3 = zphipp - zphipm - zdth2 + + zdph1 = zlampm - zlammm + zdph2 = zlammp - zlammm + zdph3 = zlampp - zlampm + + z2pi = 2.0_wp * rpi + + IF ( zdph1 > 3.0_wp * rpi ) zdph1 = zdph1 - z2pi + IF ( zdph2 > 3.0_wp * rpi ) zdph2 = zdph2 - z2pi + IF ( zdph3 > 3.0_wp * rpi ) zdph3 = zdph3 - z2pi + IF ( zdph1 < -3.0_wp * rpi ) zdph1 = zdph1 + z2pi + IF ( zdph2 < -3.0_wp * rpi ) zdph2 = zdph2 + z2pi + IF ( zdph3 < -3.0_wp * rpi ) zdph3 = zdph3 + z2pi + + zdph3 = zdph3 - zdph2 + + ziguess = 0.5_wp + zjguess = 0.5_wp + + itermax = 100 + + IF ( wp == sp ) THEN + zeps = 1.0e-6_wp ! Single precision + ELSE + zeps = 1.0e-10_wp ! Double precision + ENDIF + + !------------------------------------------------------------------------ + ! Iterate to determine (i,j) in new coordinate system + !------------------------------------------------------------------------ + jiter_loop: DO jiter = 1, itermax + + zdthp = zphi - zphimm - zdth1 * ziguess - zdth2 * zjguess & + & - zdth3 * ziguess * zjguess + zdphp = zlam - zlammm + + zhpi = 0.5_wp * rpi + IF ( zdphp > 3.0_wp * zhpi ) zdphp = zdphp - z2pi + IF ( zdphp < -3.0_wp * zhpi ) zdphp = zdphp + z2pi + + zdphp = zdphp - zdph1 * ziguess - zdph2 * zjguess & + & - zdph3 * ziguess * zjguess + + zmat1 = zdth1 + zdth3 * zjguess + zmat2 = zdth2 + zdth3 * ziguess + zmat3 = zdph1 + zdph3 * zjguess + zmat4 = zdph2 + zdph3 * ziguess + + ! Matrix determinant + zdeterm = zmat1 * zmat4 - zmat2 * zmat3 + + zdeli = ( zdthp * zmat4 - zmat2 * zdphp) / zdeterm + zdelj = ( zmat1 * zdphp - zdthp * zmat3) / zdeterm + + IF ( ABS( zdeli ) < zeps .AND. ABS( zdelj ) < zeps ) EXIT jiter_loop + + ziguess = ziguess + zdeli + zjguess = zjguess + zdelj + + ! DJL prevent ziguess and zjguess from going outside the range + ! 0 to 1 + ! prevents interpolated value going wrong + ! for example sea ice concentration gt 1 + + IF ( ziguess < 0 ) ziguess = 0.0_wp + IF ( zjguess < 0 ) zjguess = 0.0_wp + IF ( ziguess > 1 ) ziguess = 1.0_wp + IF ( zjguess > 1 ) zjguess = 1.0_wp + + END DO jiter_loop + + IF ( jiter <= itermax ) THEN + + ! Successfully found i,j, now compute the weights + + pbiwmm = ( 1.0_wp - ziguess ) * ( 1.0_wp - zjguess ) + pbiwmp = ( 1.0_wp - ziguess ) * zjguess + pbiwpm = ziguess * ( 1.0_wp - zjguess ) + pbiwpp = ziguess * zjguess + + ELSEIF ( jiter > itermax ) THEN + + IF(lwp) THEN + + WRITE(numout,*)'Obs lat/lon : ',pphi, plam + WRITE(numout,*)'Grid lats : ',pphimm, pphimp, pphipm, pphipp + WRITE(numout,*)'Grid lons : ',plammm, plammp, plampm, plampp + WRITE(numout,*)'Current i,j : ',ziguess, zjguess + WRITE(numout,*)'jiter = ',jiter + WRITE(numout,*)'zeps = ',zeps + WRITE(numout,*)'zdeli, zdelj = ',zdeli, zdelj + WRITE(numout,*)' Iterations for i,j exceed max iteration count!' + WRITE(numout,*) + + ldfail = .TRUE. + + ENDIF + + ENDIF + + END SUBROUTINE bil_wgt + + SUBROUTINE lu_invmat( pmatin, kdim, pmatou ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE lu_invmat *** + !! + !! ** Purpose : Invert a matrix using LU decomposition. + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 02-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !! ! 06-11 (NEMOVAR task force) Fix declaration of zd. + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kdim ! Array dimension + REAL(KIND=wp), DIMENSION(kdim,kdim), INTENT(IN) :: & + & pmatin + REAL(KIND=wp), DIMENSION(kdim,kdim), INTENT(OUT) :: & + & pmatou + + !! * Local declarations + INTEGER :: & + & ji, & + & jj + INTEGER, DIMENSION(kdim) :: & + & indx + REAL(KIND=wp), DIMENSION(kdim,kdim) :: & + & zmat + REAL(KIND=wp) :: & + & zd + + ! Invert the matrix + DO jj = 1, kdim + DO ji = 1, kdim + pmatou(ji,jj) = 0.0_wp + zmat(ji,jj) = pmatin(ji,jj) + END DO + pmatou(jj,jj) = 1.0_wp + END DO + CALL lu_decomp( zmat, kdim, kdim, indx, zd ) + DO jj = 1, kdim + CALL lu_backsb( zmat, kdim, kdim, indx, pmatou(1,jj) ) + END DO + + END SUBROUTINE lu_invmat + + SUBROUTINE lu_decomp( pmatin, kdim1, kdim2, kindex, pflt ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE lu_decomp *** + !! + !! ** Purpose : Compute the LU decomposition of a matrix + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 02-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kdim1, & ! Array dimensions + & kdim2 + INTEGER, DIMENSION(kdim1), INTENT(OUT) :: & + & kindex + REAL(KIND=wp), INTENT(OUT) :: & + & pflt + REAL(KIND=wp), DIMENSION(kdim2,kdim2), INTENT(INOUT) :: & + & pmatin + + !! * Local declarations + INTEGER, PARAMETER :: & + & jpmax = 100 + REAL(KIND=wp), PARAMETER :: & + & pptiny = 1.0e-20_wp + REAL(KIND=wp), DIMENSION(jpmax) :: & + & zvv + INTEGER :: & + & ji, & + & jj, & + & jk + INTEGER :: & + & imax + REAL(KIND=wp) :: & + & zsum, & + & zdum, & + & zaamax + + imax = -1 + ! Main computation + pflt = 1.0_wp + DO ji = 1, kdim1 + zaamax = 0.0_wp + DO jj = 1, kdim1 + IF ( ABS( pmatin(ji,jj) ) > zaamax ) zaamax = ABS( pmatin(ji,jj) ) + END DO + IF ( zaamax == 0.0_wp ) THEN + CALL ctl_stop( 'singular matrix' ) + ENDIF + zvv(ji) = 1.0_wp / zaamax + END DO + DO jj = 1, kdim1 + DO ji = 1, jj-1 + zsum = pmatin(ji,jj) + DO jk = 1, ji-1 + zsum = zsum - pmatin(ji,jk) * pmatin(jk,jj) + END DO + pmatin(ji,jj) = zsum + END DO + zaamax = 0.0_wp + DO ji = jj, kdim1 + zsum = pmatin(ji,jj) + DO jk = 1, jj-1 + zsum = zsum - pmatin(ji,jk) * pmatin(jk,jj) + END DO + pmatin(ji,jj) = zsum + zdum = zvv(ji) * ABS( zsum ) + IF ( zdum >= zaamax ) THEN + imax = ji + zaamax = zdum + ENDIF + END DO + IF ( jj /= imax ) THEN + DO jk = 1, kdim1 + zdum = pmatin(imax,jk) + pmatin(imax,jk) = pmatin(jj,jk) + pmatin(jj,jk) = zdum + END DO + pflt = -pflt + zvv(imax) = zvv(jj) + ENDIF + kindex(jj) = imax + IF ( pmatin(jj,jj) == 0.0_wp ) pmatin(jj,jj) = pptiny + IF ( jj /= kdim1 ) THEN + zdum = 1.0_wp / pmatin(jj,jj) + DO ji = jj+1, kdim1 + pmatin(ji,jj) = pmatin(ji,jj) * zdum + END DO + ENDIF + END DO + + END SUBROUTINE lu_decomp + + SUBROUTINE lu_backsb( pmat, kdim1, kdim2, kindex, pvect ) + !!----------------------------------------------------------------------- + !! + !! *** ROUTINE lu_backsb *** + !! + !! ** Purpose : Back substitution + !! + !! ** Method : + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 02-11 (A. Weaver, N. Daget) + !! ! 06-03 (A. Vidard) + !! ! 06-10 (A. Weaver) Cleanup + !!----------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: & + & kdim1, & ! Array dimensions + & kdim2 + INTEGER, DIMENSION(kdim1), INTENT(IN) :: & + & kindex + REAL(KIND=wp), DIMENSION(kdim1), INTENT(INOUT) :: & + & pvect + REAL(KIND=wp), DIMENSION(kdim2,kdim2), INTENT(IN) :: & + & pmat + + !! * Local declarations + INTEGER :: & + & ji, & + & jii, & + & jj, & + & jll + REAL(KIND=wp) :: & + & zsum + + ! Main computation + jii = 0 + DO ji = 1, kdim1 + jll = kindex(ji) + zsum = pvect(jll) + pvect(jll) = pvect(ji) + IF ( jii /= 0 ) THEN + DO jj = jii, ji-1 + zsum = zsum - pmat(ji,jj) * pvect(jj) + END DO + ELSEIF ( zsum /= 0.0_wp ) THEN + jii = ji + ENDIF + pvect(ji) = zsum + END DO + DO ji = kdim1, 1, -1 + zsum = pvect(ji) + DO jj = ji+1, kdim1 + zsum = zsum - pmat(ji,jj) * pvect(jj) + END DO + pvect(ji) = zsum / pmat(ji,ji) + END DO + + END SUBROUTINE lu_backsb \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obsinter_z1d.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obsinter_z1d.h90 new file mode 100644 index 0000000..74a9d4a --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/obsinter_z1d.h90 @@ -0,0 +1,193 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: obsinter_z1d.h90 13226 2020-07-02 14:24:31Z orioltp $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE obs_int_z1d( kpk, kkco, k1dint, kdep, & + & pobsdep, pobsk, pobs2k, & + & pobs, pdep, pobsmask ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_z1d *** + !! + !! ** Purpose : Vertical interpolation to the observation point. + !! + !! ** Method : If k1dint = 0 then use linear interpolation. + !! If k1dint = 1 then use cubic spline interpolation. + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 97-11 (A. Weaver, S. Ricci, N. Daget) + !! ! 06-03 (G. Smith) Conversion to F90 for use with NEMOVAR + !! ! 06-10 (A. Weaver) Cleanup + !! ! 07-01 (K. Mogensen) Use profile rather than single level + !!--------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kpk ! Number of vertical levels + INTEGER, INTENT(IN) :: k1dint ! 0 = linear; 1 = cubic spline interpolation + INTEGER, INTENT(IN) :: kdep ! Number of levels in profile + INTEGER, INTENT(IN), DIMENSION(kdep) :: & + & kkco ! Array indicies for interpolation + REAL(KIND=wp), INTENT(IN), DIMENSION(kdep) :: & + & pobsdep ! Depth of the observation + REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & + & pobsk, & ! Model profile at a given (lon,lat) + & pobs2k, & ! 2nd derivative of the interpolating function + & pdep, & ! Model depth array + & pobsmask ! Vertical mask + REAL(KIND=wp), INTENT(OUT), DIMENSION(kdep) :: & + & pobs ! Model equivalent at observation point + + !! * Local declarations + REAL(KIND=wp) :: z1dm ! Distance above and below obs to model grid points + REAL(KIND=wp) :: z1dp + REAL(KIND=wp) :: zsum ! Dummy variables for computation + REAL(KIND=wp) :: zsum2 + INTEGER :: jdep ! Observation depths loop variable + + !------------------------------------------------------------------------ + ! Loop over all observation depths + !------------------------------------------------------------------------ + + DO jdep = 1, kdep + + !--------------------------------------------------------------------- + ! Initialization + !--------------------------------------------------------------------- + z1dm = ( pdep(kkco(jdep)) - pobsdep(jdep) ) + z1dp = ( pobsdep(jdep) - pdep(kkco(jdep)-1) ) + + ! If kkco(jdep) is masked then set pobs(jdep) to the lowest value located above bathymetry + IF ( pobsmask(kkco(jdep)) == 0.0_wp ) THEN + pobs(jdep) = pobsk(kkco(jdep)-1) + ELSE + zsum = z1dm + z1dp + + IF ( k1dint == 0 ) THEN + + !----------------------------------------------------------------- + ! Linear interpolation + !----------------------------------------------------------------- + pobs(jdep) = ( z1dm * pobsk(kkco(jdep)-1) & + & + z1dp * pobsk(kkco(jdep) ) ) / zsum + + ELSEIF ( k1dint == 1 ) THEN + + !----------------------------------------------------------------- + ! Cubic spline interpolation + !----------------------------------------------------------------- + zsum2 = zsum * zsum + pobs(jdep) = ( z1dm * pobsk (kkco(jdep)-1) & + & + z1dp * pobsk (kkco(jdep) ) & + & + ( z1dm * ( z1dm * z1dm - zsum2 ) * pobs2k(kkco(jdep)-1) & + & + z1dp * ( z1dp * z1dp - zsum2 ) * pobs2k(kkco(jdep) ) & + & ) / 6.0_wp & + & ) / zsum + + ENDIF + ENDIF + END DO + + END SUBROUTINE obs_int_z1d + + SUBROUTINE obs_int_z1d_spl( kpk, pobsk, pobs2k, & + & pdep, pobsmask ) + !!-------------------------------------------------------------------- + !! + !! *** ROUTINE obs_int_z1d_spl *** + !! + !! ** Purpose : Compute the local vector of vertical second-derivatives + !! of the interpolating function used with a cubic spline. + !! + !! ** Method : + !! + !! Top and bottom boundary conditions on the 2nd derivative are + !! set to zero. + !! + !! ** Action : + !! + !! References : + !! + !! History + !! ! 01-11 (A. Weaver, S. Ricci, N. Daget) + !! ! 06-03 (G. Smith) Conversion to F90 for use with NEMOVAR + !! ! 06-10 (A. Weaver) Cleanup + !!---------------------------------------------------------------------- + + !! * Arguments + INTEGER, INTENT(IN) :: kpk ! Number of vertical levels + REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & + & pobsk, & ! Model profile at a given (lon,lat) + & pdep, & ! Model depth array + & pobsmask ! Vertical mask + REAL(KIND=wp), INTENT(OUT), DIMENSION(kpk) :: & + & pobs2k ! 2nd derivative of the interpolating function + + !! * Local declarations + INTEGER :: jk + REAL(KIND=wp) :: za + REAL(KIND=wp) :: zb + REAL(KIND=wp) :: zc + REAL(KIND=wp) :: zpa + REAL(KIND=wp) :: zkm + REAL(KIND=wp) :: zkp + REAL(KIND=wp) :: zk + REAL(KIND=wp), DIMENSION(kpk-1) :: & + & zs, & + & zp, & + & zu, & + & zv + + !----------------------------------------------------------------------- + ! Matrix initialisation + !----------------------------------------------------------------------- + zs(1) = 0.0_wp + zp(1) = 0.0_wp + zv(1) = -0.5_wp + DO jk = 2, kpk-1 + zs(jk) = ( pdep(jk ) - pdep(jk-1) ) & + & / ( pdep(jk+1) - pdep(jk-1) ) + zp(jk) = zs(jk) * zv(jk-1) + 2.0_wp + zv(jk) = ( zs(jk) - 1.0_wp ) / zp(jk) + END DO + + !----------------------------------------------------------------------- + ! Solution of the tridiagonal system + !----------------------------------------------------------------------- + + ! Top boundary condition + zu(1) = 0.0_wp + + DO jk = 2, kpk-1 + za = pdep(jk+1) - pdep(jk-1) + zb = pdep(jk+1) - pdep(jk ) + zc = pdep(jk ) - pdep(jk-1) + + zpa = 6.0_wp / ( zp(jk) * za ) + zkm = zpa / zc + zkp = zpa / zb + zk = - ( zkm + zkp ) + + zu(jk) = pobsk(jk+1) * zkp & + & + pobsk(jk ) * zk & + & + pobsk(jk-1) * zkm & + & + zu(jk-1) * ( -zs(jk) / zp(jk) ) + END DO + + !----------------------------------------------------------------------- + ! Second derivative + !----------------------------------------------------------------------- + pobs2k(kpk) = 0.0_wp + + ! Bottom boundary condition + DO jk = kpk-1, 1, -1 + pobs2k(jk) = zv(jk) * pobs2k(jk+1) + zu(jk) + IF ( pobsmask(jk+1) == 0.0_wp ) pobs2k(jk) = 0.0_wp + END DO + + END SUBROUTINE obs_int_z1d_spl \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/str_c_to_for.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/str_c_to_for.h90 new file mode 100644 index 0000000..97f8ef1 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/OBS/str_c_to_for.h90 @@ -0,0 +1,39 @@ +!!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: str_c_to_for.h90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + SUBROUTINE str_c_to_for( cd_str ) + !!--------------------------------------------------------------------- + !! + !! *** ROUTINE str_c_to_for *** + !! + !! ** Purpose : Loop over a string and replace all non-printable + !! ASCII characters with spaces assuming English + !! characters only + !! + !! ** Method : Loop over a string and replace all non-printable + !! ASCII characters with spaces assuming English + !! characters only + !! + !! ** Action : + !! + !! History : + !! ! : 06-05 (K. Mogensen) Original + !! ! : 06-05 (A. Vidard) Cleaning up + !! ! : 06-10 (A. Weaver) More cleaning + !!--------------------------------------------------------------------- + !! * Arguments + CHARACTER(LEN=*), INTENT(INOUT) :: cd_str + + !! * Local declarations + INTEGER :: & + & ji + + DO ji = 1, LEN( cd_str ) + IF ( ( IACHAR( cd_str(ji:ji) ) > 128 ) & + & .OR.( IACHAR( cd_str(ji:ji) ) < 32 ) ) cd_str(ji:ji) = ' ' + END DO + + END SUBROUTINE str_c_to_for \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/abl.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/abl.F90 new file mode 100644 index 0000000..6e8243d --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/abl.F90 @@ -0,0 +1,31 @@ +MODULE abl + !!====================================================================== + !! *** MODULE abl *** + !! Abl : ABL dynamics and active tracers defined in memory + !!====================================================================== + USE par_kind ! abl parameters + + IMPLICIT NONE + PRIVATE + !! -------------------------- ! + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: u_abl !: i-horizontal velocity [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: v_abl !: j-horizontal velocity [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: tq_abl !: 4D T-q fields [Kelvin,kg/kg] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avm_abl !: turbulent viscosity [m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avt_abl !: turbulent diffusivity [m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: mxl_abl !: mixing length [m] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: tke_abl !: turbulent kinetic energy [m2/s2] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: fft_abl !: Coriolis parameter [1/s] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: pblh !: PBL height [m] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: rest_eq + ! + INTEGER , PUBLIC :: nt_n, nt_a !: now / after indices (equal 1 or 2) + ! + !!---------------------------------------------------------------------- + !! NEMO/OPA 4.0 , NEMO Consortium (2011) + !! $Id: abl.F90 4990 2014-12-15 16:42:49Z timgraham $ + !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- +CONTAINS + +END MODULE abl \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/cpl_oasis3.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/cpl_oasis3.F90 new file mode 100644 index 0000000..2d67598 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/cpl_oasis3.F90 @@ -0,0 +1,580 @@ +MODULE cpl_oasis3 + !!====================================================================== + !! *** MODULE cpl_oasis *** + !! Coupled O/A : coupled ocean-atmosphere case using OASIS3-MCT + !!===================================================================== + !! History : 1.0 ! 2004-06 (R. Redler, NEC Laboratories Europe, Germany) Original code + !! - ! 2004-11 (R. Redler, NEC Laboratories Europe; N. Keenlyside, W. Park, IFM-GEOMAR, Germany) revision + !! - ! 2004-11 (V. Gayler, MPI M&D) Grid writing + !! 2.0 ! 2005-08 (R. Redler, W. Park) frld initialization, paral(2) revision + !! - ! 2005-09 (R. Redler) extended to allow for communication over root only + !! - ! 2006-01 (W. Park) modification of physical part + !! - ! 2006-02 (R. Redler, W. Park) buffer array fix for root exchange + !! 3.4 ! 2011-11 (C. Harris) Changes to allow mutiple category fields + !! 3.6 ! 2014-11 (S. Masson) OASIS3-MCT + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 'key_oasis3' coupled Ocean/Atmosphere via OASIS3-MCT + !!---------------------------------------------------------------------- + !! cpl_init : initialization of coupled mode communication + !! cpl_define : definition of grid and fields + !! cpl_snd : snd out fields in coupled mode + !! cpl_rcv : receive fields in coupled mode + !! cpl_finalize : finalize the coupled mode communication + !!---------------------------------------------------------------------- +#if defined key_oasis3 + USE mod_oasis ! OASIS3-MCT module +#endif + USE par_oce ! ocean parameters + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC cpl_init + PUBLIC cpl_define + PUBLIC cpl_snd + PUBLIC cpl_rcv + PUBLIC cpl_freq + PUBLIC cpl_finalize + + INTEGER, PUBLIC :: OASIS_Rcv = 1 !: return code if received field + INTEGER, PUBLIC :: OASIS_idle = 0 !: return code if nothing done by oasis + INTEGER :: ncomp_id ! id returned by oasis_init_comp + INTEGER :: nerror ! return error code +#if ! defined key_oasis3 + ! OASIS Variables not used. defined only for compilation purpose + INTEGER :: OASIS_Out = -1 + INTEGER :: OASIS_REAL = -1 + INTEGER :: OASIS_Ok = -1 + INTEGER :: OASIS_In = -1 + INTEGER :: OASIS_Sent = -1 + INTEGER :: OASIS_SentOut = -1 + INTEGER :: OASIS_ToRest = -1 + INTEGER :: OASIS_ToRestOut = -1 + INTEGER :: OASIS_Recvd = -1 + INTEGER :: OASIS_RecvOut = -1 + INTEGER :: OASIS_FromRest = -1 + INTEGER :: OASIS_FromRestOut = -1 +#endif + + INTEGER :: nrcv ! total number of fields received + INTEGER :: nsnd ! total number of fields sent + INTEGER :: ncplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data + INTEGER, PUBLIC, PARAMETER :: nmaxfld=62 ! Maximum number of coupling fields + INTEGER, PUBLIC, PARAMETER :: nmaxcat=5 ! Maximum number of coupling fields + INTEGER, PUBLIC, PARAMETER :: nmaxcpl=5 ! Maximum number of coupling fields + + TYPE, PUBLIC :: FLD_CPL !: Type for coupling field information + LOGICAL :: laction ! To be coupled or not + CHARACTER(len = 8) :: clname ! Name of the coupling field + CHARACTER(len = 1) :: clgrid ! Grid type + REAL(wp) :: nsgn ! Control of the sign change + INTEGER, DIMENSION(nmaxcat,nmaxcpl) :: nid ! Id of the field (no more than 9 categories and 9 extrena models) + INTEGER :: nct ! Number of categories in field + INTEGER :: ncplmodel ! Maximum number of models to/from which this variable may be sent/received + END TYPE FLD_CPL + + TYPE(FLD_CPL), DIMENSION(nmaxfld), PUBLIC :: srcv, ssnd !: Coupling fields + + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: exfld ! Temporary buffer for receiving + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: cpl_oasis3.F90 14434 2021-02-11 08:20:52Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE cpl_init( cd_modname, kl_comm ) + !!------------------------------------------------------------------- + !! *** ROUTINE cpl_init *** + !! + !! ** Purpose : Initialize coupled mode communication for ocean + !! exchange between AGCM, OGCM and COUPLER. (OASIS3 software) + !! + !! ** Method : OASIS3 MPI communication + !!-------------------------------------------------------------------- + CHARACTER(len = *), INTENT(in ) :: cd_modname ! model name as set in namcouple file + INTEGER , INTENT( out) :: kl_comm ! local communicator of the model + !!-------------------------------------------------------------------- + + ! WARNING: No write in numout in this routine + !============================================ + + !------------------------------------------------------------------ + ! 1st Initialize the OASIS system for the application + !------------------------------------------------------------------ + CALL oasis_init_comp ( ncomp_id, TRIM(cd_modname), nerror ) + IF( nerror /= OASIS_Ok ) & + CALL oasis_abort (ncomp_id, 'cpl_init', 'Failure in oasis_init_comp') + + !------------------------------------------------------------------ + ! 3rd Get an MPI communicator for OCE local communication + !------------------------------------------------------------------ + + CALL oasis_get_localcomm ( kl_comm, nerror ) + IF( nerror /= OASIS_Ok ) & + CALL oasis_abort (ncomp_id, 'cpl_init','Failure in oasis_get_localcomm' ) + ! + END SUBROUTINE cpl_init + + + SUBROUTINE cpl_define( krcv, ksnd, kcplmodel ) + !!------------------------------------------------------------------- + !! *** ROUTINE cpl_define *** + !! + !! ** Purpose : Define grid and field information for ocean + !! exchange between AGCM, OGCM and COUPLER. (OASIS3 software) + !! + !! ** Method : OASIS3 MPI communication + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: krcv, ksnd ! Number of received and sent coupling fields + INTEGER, INTENT(in) :: kcplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data + ! + INTEGER :: id_part + INTEGER :: paral(5) ! OASIS3 box partition + INTEGER :: ishape(4) ! shape of arrays passed to PSMILe + INTEGER :: ji,jc,jm ! local loop indicees + CHARACTER(LEN=64) :: zclname + CHARACTER(LEN=2) :: cli2 + !!-------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'cpl_define : initialization in coupled ocean/atmosphere case' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) + + ncplmodel = kcplmodel + IF( kcplmodel > nmaxcpl ) THEN + CALL oasis_abort ( ncomp_id, 'cpl_define', 'ncplmodel is larger than nmaxcpl, increase nmaxcpl') ; RETURN + ENDIF + + nrcv = krcv + IF( nrcv > nmaxfld ) THEN + CALL oasis_abort ( ncomp_id, 'cpl_define', 'nrcv is larger than nmaxfld, increase nmaxfld') ; RETURN + ENDIF + + nsnd = ksnd + IF( nsnd > nmaxfld ) THEN + CALL oasis_abort ( ncomp_id, 'cpl_define', 'nsnd is larger than nmaxfld, increase nmaxfld') ; RETURN + ENDIF + ! + ! ... Define the shape for the area that excludes the halo as we don't want them to be "seen" by oasis + ! + ishape(1) = 1 + ishape(2) = Ni_0 + ishape(3) = 1 + ishape(4) = Nj_0 + ! + ! ... Allocate memory for data exchange + ! + ALLOCATE(exfld(Ni_0, Nj_0), stat = nerror) ! allocate only inner domain (without halos) + IF( nerror > 0 ) THEN + CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating exfld') ; RETURN + ENDIF + ! + ! ----------------------------------------------------------------- + ! ... Define the partition, excluding halos as we don't want them to be "seen" by oasis + ! ----------------------------------------------------------------- + + paral(1) = 2 ! box partitioning + paral(2) = Ni0glo * mjg0(nn_hls) + mig0(nn_hls) ! NEMO lower left corner global offset, without halos + paral(3) = Ni_0 ! local extent in i, excluding halos + paral(4) = Nj_0 ! local extent in j, excluding halos + paral(5) = Ni0glo ! global extent in x, excluding halos + + IF( sn_cfctl%l_oasout ) THEN + WRITE(numout,*) ' multiexchg: paral (1:5)', paral + WRITE(numout,*) ' multiexchg: Ni_0, Nj_0 =', Ni_0, Nj_0 + WRITE(numout,*) ' multiexchg: Nis0, Nie0, nimpp =', Nis0, Nie0, nimpp + WRITE(numout,*) ' multiexchg: Njs0, Nje0, njmpp =', Njs0, Nje0, njmpp + ENDIF + + CALL oasis_def_partition ( id_part, paral, nerror, Ni0glo*Nj0glo ) ! global number of points, excluding halos + ! + ! ... Announce send variables. + ! + ssnd(:)%ncplmodel = kcplmodel + ! + DO ji = 1, ksnd + IF( ssnd(ji)%laction ) THEN + + IF( ssnd(ji)%nct > nmaxcat ) THEN + CALL oasis_abort ( ncomp_id, 'cpl_define', 'Number of categories of '// & + & TRIM(ssnd(ji)%clname)//' is larger than nmaxcat, increase nmaxcat' ) + RETURN + ENDIF + + DO jc = 1, ssnd(ji)%nct + DO jm = 1, kcplmodel + + IF( ssnd(ji)%nct .GT. 1 ) THEN + WRITE(cli2,'(i2.2)') jc + zclname = TRIM(ssnd(ji)%clname)//'_cat'//cli2 + ELSE + zclname = ssnd(ji)%clname + ENDIF + IF( kcplmodel > 1 ) THEN + WRITE(cli2,'(i2.2)') jm + zclname = 'model'//cli2//'_'//TRIM(zclname) + ENDIF +#if defined key_agrif + IF( agrif_fixed() /= 0 ) THEN + zclname=TRIM(Agrif_CFixed())//'_'//TRIM(zclname) + ENDIF +#endif + IF( sn_cfctl%l_oasout ) WRITE(numout,*) "Define", ji, jc, jm, " "//TRIM(zclname), " for ", OASIS_Out + CALL oasis_def_var (ssnd(ji)%nid(jc,jm), zclname, id_part , (/ 2, 1 /), & + & OASIS_Out , ishape , OASIS_REAL, nerror ) + IF( nerror /= OASIS_Ok ) THEN + WRITE(numout,*) 'Failed to define transient ', ji, jc, jm, " "//TRIM(zclname) + CALL oasis_abort ( ssnd(ji)%nid(jc,jm), 'cpl_define', 'Failure in oasis_def_var' ) + ENDIF + IF( sn_cfctl%l_oasout .AND. ssnd(ji)%nid(jc,jm) /= -1 ) WRITE(numout,*) "variable defined in the namcouple" + IF( sn_cfctl%l_oasout .AND. ssnd(ji)%nid(jc,jm) == -1 ) WRITE(numout,*) "variable NOT defined in the namcouple" + END DO + END DO + ENDIF + END DO + ! + ! ... Announce received variables. + ! + srcv(:)%ncplmodel = kcplmodel + ! + DO ji = 1, krcv + IF( srcv(ji)%laction ) THEN + + IF( srcv(ji)%nct > nmaxcat ) THEN + CALL oasis_abort ( ncomp_id, 'cpl_define', 'Number of categories of '// & + & TRIM(srcv(ji)%clname)//' is larger than nmaxcat, increase nmaxcat' ) + RETURN + ENDIF + + DO jc = 1, srcv(ji)%nct + DO jm = 1, kcplmodel + + IF( srcv(ji)%nct .GT. 1 ) THEN + WRITE(cli2,'(i2.2)') jc + zclname = TRIM(srcv(ji)%clname)//'_cat'//cli2 + ELSE + zclname = srcv(ji)%clname + ENDIF + IF( kcplmodel > 1 ) THEN + WRITE(cli2,'(i2.2)') jm + zclname = 'model'//cli2//'_'//TRIM(zclname) + ENDIF +#if defined key_agrif + IF( agrif_fixed() /= 0 ) THEN + zclname=TRIM(Agrif_CFixed())//'_'//TRIM(zclname) + ENDIF +#endif + IF( sn_cfctl%l_oasout ) WRITE(numout,*) "Define", ji, jc, jm, " "//TRIM(zclname), " for ", OASIS_In + CALL oasis_def_var (srcv(ji)%nid(jc,jm), zclname, id_part , (/ 2, 1 /), & + & OASIS_In , ishape , OASIS_REAL, nerror ) + IF( nerror /= OASIS_Ok ) THEN + WRITE(numout,*) 'Failed to define transient ', ji, jc, jm, " "//TRIM(zclname) + CALL oasis_abort ( srcv(ji)%nid(jc,jm), 'cpl_define', 'Failure in oasis_def_var' ) + ENDIF + IF( sn_cfctl%l_oasout .AND. srcv(ji)%nid(jc,jm) /= -1 ) WRITE(numout,*) "variable defined in the namcouple" + IF( sn_cfctl%l_oasout .AND. srcv(ji)%nid(jc,jm) == -1 ) WRITE(numout,*) "variable NOT defined in the namcouple" + + END DO + END DO + ENDIF + END DO + + !------------------------------------------------------------------ + ! End of definition phase + !------------------------------------------------------------------ + ! +#if defined key_agrif + ! Warning: Agrif_Nb_Fine_Grids not yet defined at this stage for Agrif_Root -> must use Agrif_Root_Only() + IF( Agrif_Root_Only() .OR. agrif_fixed() == Agrif_Nb_Fine_Grids() ) THEN +#endif + CALL oasis_enddef(nerror) + IF( nerror /= OASIS_Ok ) CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in oasis_enddef') +#if defined key_agrif + ENDIF +#endif + ! + END SUBROUTINE cpl_define + + + SUBROUTINE cpl_snd( kid, kstep, pdata, kinfo ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cpl_snd *** + !! + !! ** Purpose : - At each coupling time-step,this routine sends fields + !! like sst or ice cover to the coupler or remote application. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kid ! variable index in the array + INTEGER , INTENT( out) :: kinfo ! OASIS3 info argument + INTEGER , INTENT(in ) :: kstep ! ocean time-step in seconds + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdata + !! + INTEGER :: jc,jm ! local loop index + !!-------------------------------------------------------------------- + ! + ! snd data to OASIS3 + ! + DO jc = 1, ssnd(kid)%nct + DO jm = 1, ssnd(kid)%ncplmodel + + IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN ! exclude halos from data sent to oasis + CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, pdata(Nis0:Nie0, Njs0:Nje0,jc), kinfo ) + + IF ( sn_cfctl%l_oasout ) THEN + IF ( kinfo == OASIS_Sent .OR. kinfo == OASIS_ToRest .OR. & + & kinfo == OASIS_SentOut .OR. kinfo == OASIS_ToRestOut ) THEN + WRITE(numout,*) '****************' + WRITE(numout,*) 'oasis_put: Outgoing ', ssnd(kid)%clname + WRITE(numout,*) 'oasis_put: ivarid ', ssnd(kid)%nid(jc,jm) + WRITE(numout,*) 'oasis_put: kstep ', kstep + WRITE(numout,*) 'oasis_put: info ', kinfo + WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc)) + WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc)) + WRITE(numout,*) ' - Sum value is ', SUM(pdata(Nis0:Nie0,Njs0:Nje0,jc)) + WRITE(numout,*) '****************' + ENDIF + ENDIF + + ENDIF + + ENDDO + ENDDO + ! + END SUBROUTINE cpl_snd + + + SUBROUTINE cpl_rcv( kid, kstep, pdata, pmask, kinfo ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cpl_rcv *** + !! + !! ** Purpose : - At each coupling time-step,this routine receives fields + !! like stresses and fluxes from the coupler or remote application. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kid ! variable index in the array + INTEGER , INTENT(in ) :: kstep ! ocean time-step in seconds + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pdata ! IN to keep the value if nothing is done + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pmask ! coupling mask + INTEGER , INTENT( out) :: kinfo ! OASIS3 info argument + !! + INTEGER :: jc,jm ! local loop index + LOGICAL :: llaction, ll_1st + !!-------------------------------------------------------------------- + ! + ! receive local data from OASIS3 on every process + ! + kinfo = OASIS_idle + ! + DO jc = 1, srcv(kid)%nct + ll_1st = .TRUE. + + DO jm = 1, srcv(kid)%ncplmodel + + IF( srcv(kid)%nid(jc,jm) /= -1 ) THEN + + CALL oasis_get ( srcv(kid)%nid(jc,jm), kstep, exfld, kinfo ) + + llaction = kinfo == OASIS_Recvd .OR. kinfo == OASIS_FromRest .OR. & + & kinfo == OASIS_RecvOut .OR. kinfo == OASIS_FromRestOut + + IF ( sn_cfctl%l_oasout ) & + & WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm) + + IF( llaction ) THEN ! data received from oasis do not include halos + + kinfo = OASIS_Rcv + IF( ll_1st ) THEN + pdata(Nis0:Nie0,Njs0:Nje0,jc) = exfld(:,:) * pmask(Nis0:Nie0,Njs0:Nje0,jm) + ll_1st = .FALSE. + ELSE + pdata(Nis0:Nie0,Njs0:Nje0,jc) = pdata(Nis0:Nie0,Njs0:Nje0,jc) & + & + exfld(:,:) * pmask(Nis0:Nie0,Njs0:Nje0,jm) + ENDIF + + IF ( sn_cfctl%l_oasout ) THEN + WRITE(numout,*) '****************' + WRITE(numout,*) 'oasis_get: Incoming ', srcv(kid)%clname + WRITE(numout,*) 'oasis_get: ivarid ' , srcv(kid)%nid(jc,jm) + WRITE(numout,*) 'oasis_get: kstep', kstep + WRITE(numout,*) 'oasis_get: info ', kinfo + WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc)) + WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(Nis0:Nie0,Njs0:Nje0,jc)) + WRITE(numout,*) ' - Sum value is ', SUM(pdata(Nis0:Nie0,Njs0:Nje0,jc)) + WRITE(numout,*) '****************' + ENDIF + + ENDIF + + ENDIF + + ENDDO + + !--- we must call lbc_lnk to fill the halos that where not received. + IF( .NOT. ll_1st ) THEN + CALL lbc_lnk( 'cpl_oasis3', pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn ) + ENDIF + + ENDDO + ! + END SUBROUTINE cpl_rcv + + + INTEGER FUNCTION cpl_freq( cdfieldname ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cpl_freq *** + !! + !! ** Purpose : - send back the coupling frequency for a particular field + !!---------------------------------------------------------------------- + CHARACTER(len = *), INTENT(in) :: cdfieldname ! field name as set in namcouple file + !! + INTEGER :: id + INTEGER :: info + INTEGER, DIMENSION(1) :: itmp + INTEGER :: ji,jm ! local loop index + INTEGER :: mop + !!---------------------------------------------------------------------- + cpl_freq = 0 ! defaut definition + id = -1 ! defaut definition + ! + DO ji = 1, nsnd + IF(ssnd(ji)%laction ) THEN + DO jm = 1, ncplmodel + IF( ssnd(ji)%nid(1,jm) /= -1 ) THEN + IF( TRIM(cdfieldname) == TRIM(ssnd(ji)%clname) ) THEN + id = ssnd(ji)%nid(1,jm) + mop = OASIS_Out + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + DO ji = 1, nrcv + IF(srcv(ji)%laction ) THEN + DO jm = 1, ncplmodel + IF( srcv(ji)%nid(1,jm) /= -1 ) THEN + IF( TRIM(cdfieldname) == TRIM(srcv(ji)%clname) ) THEN + id = srcv(ji)%nid(1,jm) + mop = OASIS_In + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + ! + IF( id /= -1 ) THEN +#if ! defined key_oa3mct_v1v2 + CALL oasis_get_freqs(id, mop, 1, itmp, info) +#else + CALL oasis_get_freqs(id, 1, itmp, info) +#endif + cpl_freq = itmp(1) + ENDIF + ! + END FUNCTION cpl_freq + + + SUBROUTINE cpl_finalize + !!--------------------------------------------------------------------- + !! *** ROUTINE cpl_finalize *** + !! + !! ** Purpose : - Finalizes the coupling. If MPI_init has not been + !! called explicitly before cpl_init it will also close + !! MPI communication. + !!---------------------------------------------------------------------- + ! + DEALLOCATE( exfld ) + IF(nstop == 0) THEN + CALL oasis_terminate( nerror ) + ELSE + CALL oasis_abort( ncomp_id, "cpl_finalize", "NEMO ABORT STOP" ) + ENDIF + ! + END SUBROUTINE cpl_finalize + +#if ! defined key_oasis3 + + !!---------------------------------------------------------------------- + !! No OASIS Library OASIS3 Dummy module... + !!---------------------------------------------------------------------- + + SUBROUTINE oasis_init_comp(k1,cd1,k2) + CHARACTER(*), INTENT(in ) :: cd1 + INTEGER , INTENT( out) :: k1,k2 + k1 = -1 ; k2 = -1 + WRITE(numout,*) 'oasis_init_comp: Error you sould not be there...', cd1 + END SUBROUTINE oasis_init_comp + + SUBROUTINE oasis_abort(k1,cd1,cd2) + INTEGER , INTENT(in ) :: k1 + CHARACTER(*), INTENT(in ) :: cd1,cd2 + WRITE(numout,*) 'oasis_abort: Error you sould not be there...', cd1, cd2 + END SUBROUTINE oasis_abort + + SUBROUTINE oasis_get_localcomm(k1,k2) + INTEGER , INTENT( out) :: k1,k2 + k1 = -1 ; k2 = -1 + WRITE(numout,*) 'oasis_get_localcomm: Error you sould not be there...' + END SUBROUTINE oasis_get_localcomm + + SUBROUTINE oasis_def_partition(k1,k2,k3,k4) + INTEGER , INTENT( out) :: k1,k3 + INTEGER , INTENT(in ) :: k2(5) + INTEGER , INTENT(in ) :: k4 + k1 = k2(1) ; k3 = k2(5)+k4 + WRITE(numout,*) 'oasis_def_partition: Error you sould not be there...' + END SUBROUTINE oasis_def_partition + + SUBROUTINE oasis_def_var(k1,cd1,k2,k3,k4,k5,k6,k7) + CHARACTER(*), INTENT(in ) :: cd1 + INTEGER , INTENT(in ) :: k2,k3(2),k4,k5(2,2),k6 + INTEGER , INTENT( out) :: k1,k7 + k1 = -1 ; k7 = -1 + WRITE(numout,*) 'oasis_def_var: Error you sould not be there...', cd1 + END SUBROUTINE oasis_def_var + + SUBROUTINE oasis_enddef(k1) + INTEGER , INTENT( out) :: k1 + k1 = -1 + WRITE(numout,*) 'oasis_enddef: Error you sould not be there...' + END SUBROUTINE oasis_enddef + + SUBROUTINE oasis_put(k1,k2,p1,k3) + REAL(wp), DIMENSION(:,:), INTENT(in ) :: p1 + INTEGER , INTENT(in ) :: k1,k2 + INTEGER , INTENT( out) :: k3 + k3 = -1 + WRITE(numout,*) 'oasis_put: Error you sould not be there...' + END SUBROUTINE oasis_put + + SUBROUTINE oasis_get(k1,k2,p1,k3) + REAL(wp), DIMENSION(:,:), INTENT( out) :: p1 + INTEGER , INTENT(in ) :: k1,k2 + INTEGER , INTENT( out) :: k3 + p1(1,1) = -1. ; k3 = -1 + WRITE(numout,*) 'oasis_get: Error you sould not be there...' + END SUBROUTINE oasis_get + + SUBROUTINE oasis_get_freqs(k1,k5,k2,k3,k4) + INTEGER , INTENT(in ) :: k1,k2 + INTEGER, DIMENSION(1), INTENT( out) :: k3 + INTEGER , INTENT( out) :: k4,k5 + k3(1) = k1 ; k4 = k2 ; k5 = k2 + WRITE(numout,*) 'oasis_get_freqs: Error you sould not be there...' + END SUBROUTINE oasis_get_freqs + + SUBROUTINE oasis_terminate(k1) + INTEGER , INTENT( out) :: k1 + k1 = -1 + WRITE(numout,*) 'oasis_terminate: Error you sould not be there...' + END SUBROUTINE oasis_terminate + +#endif + + !!===================================================================== +END MODULE cpl_oasis3 \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/cyclone.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/cyclone.F90 new file mode 100644 index 0000000..75713ce --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/cyclone.F90 @@ -0,0 +1,271 @@ +MODULE cyclone + !!====================================================================== + !! *** MODULE cyclone *** + !! add the Tropical Cyclones along tracks to the surface wind forcing + !! + !!====================================================================== + !! History : 3.3 ! 2010-05 (E Vincent, G Madec, S Masson) Original code + !!---------------------------------------------------------------------- + +#if defined key_cyclone + !!---------------------------------------------------------------------- + !! 'key_cyclone' : key option add Tropical Cyclones in the wind forcing + !!---------------------------------------------------------------------- + !! wnd_cyc : 1 module subroutine + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE sbc_oce ! surface boundary condition: ocean + USE dom_oce ! ocean space domain variables + USE phycst ! physical constant + USE fldread ! read input fields + USE in_out_manager ! I/O manager + USE geo2ocean ! tools for projection on ORCA grid + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + PUBLIC wnd_cyc ! routine called in sbcblk.F90 module + + INTEGER , PARAMETER :: jp_is1 = 1 ! index of presence 1 or absence 0 of a TC record + INTEGER , PARAMETER :: jp_lon = 2 ! index of longitude for present TCs + INTEGER , PARAMETER :: jp_lat = 3 ! index of latitude for present TCs + INTEGER , PARAMETER :: jp_vmax = 4 ! index of max wind for present TCs + INTEGER , PARAMETER :: jp_pres = 5 ! index of eye-pres for present TCs + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read) + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: cyclone.F90 13295 2020-07-10 18:24:21Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE wnd_cyc( kt, pwnd_i, pwnd_j ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wnd_cyc *** + !! + !! ** Purpose : Add cyclone winds on the ORCA grid + !! + !! ** Action : - open TC data, find TCs for the current timestep + !! - for each potential TC, add the winds on the grid + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! time step index + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: pwnd_i ! wind speed i-components at T-point ORCA direction + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: pwnd_j ! wind speed j-components at T-point ORCA direction + ! + !! + INTEGER :: ji, jj , jtc ! loop arguments + INTEGER :: ierror ! loop arguments + INTEGER :: vortex=1 ! vortex shape to be used: 0=Holland 1=Willoughby + REAL(wp) :: zrout1=1.5e6 ! distance from center where we begin to kill vortex (m) + REAL(wp) :: zrout2=2.5e6 ! distance from center where we bring vortex to zero (m) + REAL(wp) :: zb ! power in Holland vortex shape + REAL(wp) :: zA ! shape parameter in Willoughby vortex : A transtion between first and second outter exp + REAL(wp) :: zn ! shape parameter in Willoughby vortex : n power law in the eye + REAL(wp) :: zXX1 ! shape parameter in Willoughby vortex : decay length second outter exponential + REAL(wp) :: zXX2 ! shape parameter in Willoughby vortex : decay length first outter exponential + REAL(wp) :: zztmp ! temporary + REAL(wp) :: zzrglam, zzrgphi ! temporary + REAL(wp) :: ztheta ! azimuthal angle + REAL(wp) :: zdist ! dist to the TC center + REAL(wp) :: zhemi ! 1 for NH ; -1 for SH + REAL(wp) :: zinfl ! clim inflow angle in TCs + REAL(wp) :: zrmw ! mean radius of Max wind of a tropical cyclone (Willoughby 2004) [m] + REAL(wp) :: zwnd_r, zwnd_t ! radial and tangential components of the wind + REAL(wp) :: zvmax ! timestep interpolated vmax + REAL(wp) :: zrlon, zrlat ! temporary + REAL(wp), DIMENSION(jpi,jpj) :: zwnd_x, zwnd_y ! zonal and meridional components of the wind + REAL(wp), DIMENSION(14,5) :: ztct ! tropical cyclone track data at kt + ! + CHARACTER(len=100) :: cn_dir ! Root directory for location of files + TYPE(FLD_N), DIMENSION(1) :: slf_i ! array of namelist informations on the TC position + TYPE(FLD_N) :: sn_tc ! informations about the fields to be read + !!-------------------------------------------------------------------- + + ! ! ====================== ! + IF( kt == nit000 ) THEN ! First call kt=nit000 ! + ! ! ====================== ! + ! set file information (default values) + cn_dir = './' ! directory in which the model is executed + ! + ! (NB: frequency positive => hours, negative => months) + ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! land/sea mask ! + ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! filename ! + sn_tc = FLD_N( 'tc_track', 6 , 'tc' , .true. , .false. , 'yearly' , '' , '' , '' ) + ! + ! Namelist is read in namsbc_blk + ! set sf structure + ALLOCATE( sf(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'wnd_cyc: unable to allocate sf structure' ) ; RETURN + ENDIF + ALLOCATE( sf(1)%fnow(14,5,1) ) + ALLOCATE( sf(1)%fdta(14,5,1,2) ) + slf_i(1) = sn_tc + ! + ! fill sf with slf_i and control print + CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_tc', 'tropical cyclone track', 'namsbc_tc' ) + ! + ENDIF + + + ! Interpolation of lon lat vmax... at the current timestep + ! *************************************************************** + + CALL fld_read( kt, nn_fsbc, sf ) ! input fields provided at the current time-step + + ztct(:,:) = sf(1)%fnow(:,:,1) + + ! Add TC wind on the grid + ! *************************************************************** + + zwnd_x(:,:) = 0.e0 + zwnd_y(:,:) = 0.e0 + + DO jtc = 1, 14 + ! + IF( ztct(jtc,jp_is1) == 1 ) THEN ! cyclone is defined in this slot ? yes--> begin + + zvmax = ztct(jtc,jp_vmax) + zrlon = rad * ztct(jtc,jp_lon ) + zrlat = rad * ztct(jtc,jp_lat ) + zhemi = SIGN( 1. , zrlat ) + zinfl = 15.* rad ! clim inflow angle in Tropical Cyclones + IF( vortex == 0 ) THEN + + ! Vortex Holland reconstruct wind at each lon-lat position + ! ******************************************************** + zrmw = 51.6 * EXP( -0.0223*zvmax + 0.0281* ABS( ztct(jtc,jp_lat) ) ) * 1000. + ! climatological ZRMW of cyclones as a function of wind and latitude (Willoughby 2004) + ! zb = 1.0036 + 0.0173 * zvmax - 0.0313 * LOG(zrmw/1000.) + 0.0087 * ABS( ztct(jtc,jp_lat) ) + ! fitted B parameter (Willoughby 2004) + zb = 2. + + DO_2D( 1, 1, 1, 1 ) + + ! calc distance between TC center and any point following great circle + ! source : http://www.movable-type.co.uk/scripts/latlong.html + zzrglam = rad * glamt(ji,jj) - zrlon + zzrgphi = rad * gphit(ji,jj) + zdist = ra * ACOS( SIN( zrlat ) * SIN( zzrgphi ) & + & + COS( zrlat ) * COS( zzrgphi ) * COS( zzrglam ) ) + + IF(zdist < zrout2) THEN ! calculation of wind only to a given max radius + ! shape of the wind profile + zztmp = ( zrmw / ( zdist + 1.e-12 ) )**zb + zztmp = zvmax * SQRT( zztmp * EXP(1. - zztmp) ) + + IF(zdist > zrout1) THEN ! bring to zero between r_out1 and r_out2 + zztmp = zztmp * ( (zrout2-zdist)*1.e-6 ) + ENDIF + + ! !!! KILL EQ WINDS + ! IF(SIGN( 1. , zrlat ) /= zhemi) THEN + ! zztmp = 0. ! winds in other hemisphere + ! IF(ABS(gphit(ji,jj)) <= 5.) zztmp=0. ! kill between 5N-5S + ! ENDIF + ! IF(ABS(gphit(ji,jj)) <= 10. .and. ABS(gphit(ji,jj)) > 5.) THEN + ! zztmp = zztmp * ( 1./5. * (ABS(gphit(ji,jj)) - 5.) ) + ! !linear to zero between 10 and 5 + ! ENDIF + ! !!! / KILL EQ + + IF(ABS(gphit(ji,jj)) >= 55.) zztmp = 0. ! kill weak spurious winds at high latitude + + zwnd_t = COS( zinfl ) * zztmp + zwnd_r = - SIN( zinfl ) * zztmp + + ! Project radial-tangential components on zonal-meridional components + ! ------------------------------------------------------------------- + + ! ztheta = azimuthal angle of the great circle between two points + zztmp = COS( zrlat ) * SIN( zzrgphi ) & + & - SIN( zrlat ) * COS( zzrgphi ) * COS( zzrglam ) + ztheta = ATAN2( COS( zzrgphi ) * SIN( zzrglam ) , zztmp ) + + zwnd_x(ji,jj) = zwnd_x(ji,jj) - zhemi * COS(ztheta)*zwnd_t + SIN(ztheta)*zwnd_r + zwnd_y(ji,jj) = zwnd_y(ji,jj) + zhemi * SIN(ztheta)*zwnd_t + COS(ztheta)*zwnd_r + ENDIF + END_2D + + ELSE IF( vortex == 1 ) THEN + + ! Vortex Willoughby reconstruct wind at each lon-lat position + ! *********************************************************** + zrmw = 46.4 * EXP( -0.0155*zvmax + 0.0169* ABS( ztct(jtc,jp_lat) ) )*1000. + ! climatological ZRMW of cyclones as a function of wind and latitude (Willoughby 2006) + zXX2 = 25.*1000. ! 25km fixed "near-eye" exponential decay + zXX1 = ( 287.6 - 1.942 *zvmax + 7.799 *LOG(zrmw/1000.) + 1.819 *ABS( ztct(jtc,jp_lat) ) )*1000. + zn = 2.1340 + 0.0077*zvmax - 0.4522*LOG(zrmw/1000.) - 0.0038*ABS( ztct(jtc,jp_lat) ) + zA = 0.5913 + 0.0029*zvmax - 0.1361*LOG(zrmw/1000.) - 0.0042*ABS( ztct(jtc,jp_lat) ) + IF(zA < 0) THEN + zA=0 + ENDIF + + DO_2D( 1, 1, 1, 1 ) + + zzrglam = rad * glamt(ji,jj) - zrlon + zzrgphi = rad * gphit(ji,jj) + zdist = ra * ACOS( SIN( zrlat ) * SIN( zzrgphi ) & + & + COS( zrlat ) * COS( zzrgphi ) * COS( zzrglam ) ) + + IF(zdist < zrout2) THEN ! calculation of wind only to a given max radius + + ! shape of the wind profile + IF(zdist <= zrmw) THEN ! inside the Radius of Maximum Wind + zztmp = zvmax * (zdist/zrmw)**zn + ELSE + zztmp = zvmax * ( (1-zA) * EXP(- (zdist-zrmw)/zXX1 ) + zA * EXP(- (zdist-zrmw)/zXX2 ) ) + ENDIF + + IF(zdist > zrout1) THEN ! bring to zero between r_out1 and r_out2 + zztmp = zztmp * ( (zrout2-zdist)*1.e-6 ) + ENDIF + + ! !!! KILL EQ WINDS + ! IF(SIGN( 1. , zrlat ) /= zhemi) THEN + ! zztmp = 0. ! winds in other hemisphere + ! IF(ABS(gphit(ji,jj)) <= 5.) zztmp=0. ! kill between 5N-5S + ! ENDIF + ! IF(ABS(gphit(ji,jj)) <= 10. .and. ABS(gphit(ji,jj)) > 5.) THEN + ! zztmp = zztmp * ( 1./5. * (ABS(gphit(ji,jj)) - 5.) ) + ! !linear to zero between 10 and 5 + ! ENDIF + ! !!! / KILL EQ + + IF(ABS(gphit(ji,jj)) >= 55.) zztmp = 0. ! kill weak spurious winds at high latitude + + zwnd_t = COS( zinfl ) * zztmp + zwnd_r = - SIN( zinfl ) * zztmp + + ! Project radial-tangential components on zonal-meridional components + ! ------------------------------------------------------------------- + + ! ztheta = azimuthal angle of the great circle between two points + zztmp = COS( zrlat ) * SIN( zzrgphi ) & + & - SIN( zrlat ) * COS( zzrgphi ) * COS( zzrglam ) + ztheta = ATAN2( COS( zzrgphi ) * SIN( zzrglam ) , zztmp ) + + zwnd_x(ji,jj) = zwnd_x(ji,jj) - zhemi * COS(ztheta)*zwnd_t + SIN(ztheta)*zwnd_r + zwnd_y(ji,jj) = zwnd_y(ji,jj) + zhemi * SIN(ztheta)*zwnd_t + COS(ztheta)*zwnd_r + + ENDIF + END_2D + ENDIF ! / vortex Holland or Wiloughby + ENDIF ! / cyclone is defined in this slot ? yes--> begin + END DO ! / end simultaneous cyclones loop + + CALL rot_rep ( zwnd_x, zwnd_y, 'T', 'en->i', pwnd_i ) !rotation of components on ORCA grid + CALL rot_rep ( zwnd_x, zwnd_y, 'T', 'en->j', pwnd_j ) !rotation of components on ORCA grid + + END SUBROUTINE wnd_cyc + +#endif + + !!====================================================================== +END MODULE cyclone \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/fldread.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/fldread.F90 new file mode 100644 index 0000000..d6b6d94 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/fldread.F90 @@ -0,0 +1,1592 @@ +MODULE fldread + !!====================================================================== + !! *** MODULE fldread *** + !! Ocean forcing: read input field for surface boundary condition + !!===================================================================== + !! History : 2.0 ! 2006-06 (S. Masson, G. Madec) Original code + !! 3.0 ! 2008-05 (S. Alderson) Modified for Interpolation in memory from input grid to model grid + !! 3.4 ! 2013-10 (D. Delrosso, P. Oddo) suppression of land point prior to interpolation + !! ! 12-2015 (J. Harle) Adding BDY on-the-fly interpolation + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! fld_read : read input fields used for the computation of the surface boundary condition + !! fld_init : initialization of field read + !! fld_def : define the record(s) of the file and its name + !! fld_get : read the data + !! fld_map : read global data from file and map onto local data using a general mapping (use for open boundaries) + !! fld_rot : rotate the vector fields onto the local grid direction + !! fld_clopn : close/open the files + !! fld_fill : fill the data structure with the associated information read in namelist + !! wgt_list : manage the weights used for interpolation + !! wgt_print : print the list of known weights + !! fld_weight : create a WGT structure and fill in data from file, restructuring as required + !! apply_seaoverland : fill land with ocean values + !! seaoverland : create shifted matrices for seaoverland application + !! fld_interp : apply weights to input gridded data to create data on model grid + !! fld_filename : define the filename according to a given date + !! ksec_week : function returning seconds between 00h of the beginning of the week and half of the current time step + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constant + USE sbc_oce ! surface boundary conditions : fields + USE geo2ocean ! for vector rotation on to model grid + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE ioipsl , ONLY : ymds2ju, ju2ymds ! for calendar + USE lib_mpp ! MPP library + USE lbclnk ! ocean lateral boundary conditions (online interpolation case) + + IMPLICIT NONE + PRIVATE + + PUBLIC fld_map ! routine called by tides_init + PUBLIC fld_read, fld_fill ! called by sbc... modules + PUBLIC fld_def + + TYPE, PUBLIC :: FLD_N !: Namelist field informations + CHARACTER(len = 256) :: clname ! generic name of the NetCDF flux file + REAL(wp) :: freqh ! frequency of each flux file + CHARACTER(len = 34) :: clvar ! generic name of the variable in the NetCDF flux file + LOGICAL :: ln_tint ! time interpolation or not (T/F) + LOGICAL :: ln_clim ! climatology or not (T/F) + CHARACTER(len = 8) :: clftyp ! type of data file 'daily', 'monthly' or yearly' + CHARACTER(len = 256) :: wname ! generic name of a NetCDF weights file to be used, blank if not + CHARACTER(len = 34) :: vcomp ! symbolic component name if a vector that needs rotation + ! ! a string starting with "U" or "V" for each component + ! ! chars 2 onwards identify which components go together + CHARACTER(len = 34) :: lname ! generic name of a NetCDF land/sea mask file to be used, blank if not + ! ! 0=sea 1=land + END TYPE FLD_N + + TYPE, PUBLIC :: FLD !: Input field related variables + CHARACTER(len = 256) :: clrootname ! generic name of the NetCDF file + CHARACTER(len = 256) :: clname ! current name of the NetCDF file + REAL(wp) :: freqh ! frequency of each flux file + CHARACTER(len = 34) :: clvar ! generic name of the variable in the NetCDF flux file + LOGICAL :: ln_tint ! time interpolation or not (T/F) + LOGICAL :: ln_clim ! climatology or not (T/F) + CHARACTER(len = 8) :: clftyp ! type of data file 'daily', 'monthly' or yearly' + CHARACTER(len = 1) :: cltype ! nature of grid-points: T, U, V... + REAL(wp) :: zsgn ! -1. the sign change across the north fold, = 1. otherwise + INTEGER :: num ! iom id of the jpfld files to be read + INTEGER , DIMENSION(2,2) :: nrec ! before/after record (1: index, 2: second since Jan. 1st 00h of yr nit000) + INTEGER :: nbb ! index of before values + INTEGER :: naa ! index of after values + INTEGER , ALLOCATABLE, DIMENSION(:) :: nrecsec ! + REAL(wp), POINTER, DIMENSION(:,:,: ) :: fnow ! input fields interpolated to now time step + REAL(wp), POINTER, DIMENSION(:,:,:,:) :: fdta ! 2 consecutive record of input fields + CHARACTER(len = 256) :: wgtname ! current name of the NetCDF weight file acting as a key + ! ! into the WGTLIST structure + CHARACTER(len = 34) :: vcomp ! symbolic name for a vector component that needs rotation + LOGICAL, DIMENSION(2) :: rotn ! flag to indicate whether before/after field has been rotated + INTEGER :: nreclast ! last record to be read in the current file + CHARACTER(len = 256) :: lsmname ! current name of the NetCDF mask file acting as a key + ! ! + ! ! Variables related to BDY + INTEGER :: igrd ! grid type for bdy data + INTEGER :: ibdy ! bdy set id number + INTEGER, POINTER, DIMENSION(:) :: imap ! Array of integer pointers to 1D arrays + LOGICAL :: ltotvel ! total velocity or not (T/F) + LOGICAL :: lzint ! T if it requires a vertical interpolation + END TYPE FLD + +!$AGRIF_DO_NOT_TREAT + + !! keep list of all weights variables so they're only read in once + !! need to add AGRIF directives not to process this structure + !! also need to force wgtname to include AGRIF nest number + TYPE :: WGT !: Input weights related variables + CHARACTER(len = 256) :: wgtname ! current name of the NetCDF weight file + INTEGER , DIMENSION(2) :: ddims ! shape of input grid + INTEGER , DIMENSION(2) :: botleft ! top left corner of box in input grid containing + ! ! current processor grid + INTEGER , DIMENSION(2) :: topright ! top right corner of box + INTEGER :: jpiwgt ! width of box on input grid + INTEGER :: jpjwgt ! height of box on input grid + INTEGER :: numwgt ! number of weights (4=bilinear, 16=bicubic) + INTEGER :: nestid ! for agrif, keep track of nest we're in + INTEGER :: overlap ! =0 when cyclic grid has no overlapping EW columns + ! ! =>1 when they have one or more overlapping columns + ! ! =-1 not cyclic + LOGICAL :: cyclic ! east-west cyclic or not + INTEGER, DIMENSION(:,:,:), POINTER :: data_jpi ! array of source integers + INTEGER, DIMENSION(:,:,:), POINTER :: data_jpj ! array of source integers + REAL(wp), DIMENSION(:,:,:), POINTER :: data_wgt ! array of weights on model grid + REAL(wp), DIMENSION(:,:,:), POINTER :: fly_dta ! array of values on input grid + REAL(wp), DIMENSION(:,:,:), POINTER :: col ! temporary array for reading in columns + END TYPE WGT + + INTEGER, PARAMETER :: tot_wgts = 20 + TYPE( WGT ), DIMENSION(tot_wgts) :: ref_wgts ! array of wgts + INTEGER :: nxt_wgt = 1 ! point to next available space in ref_wgts array + INTEGER :: nflag = 0 + REAL(wp), PARAMETER :: undeff_lsm = -999.00_wp + +!$AGRIF_END_DO_NOT_TREAT + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: fldread.F90 15023 2021-06-18 14:35:25Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE fld_read( kt, kn_fsbc, sd, kit, pt_offset, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_read *** + !! + !! ** Purpose : provide at each time step the surface ocean fluxes + !! (momentum, heat, freshwater and runoff) + !! + !! ** Method : READ each input fields in NetCDF files using IOM + !! and intepolate it to the model time-step. + !! Several assumptions are made on the input file: + !! blahblahblah.... + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) + TYPE(FLD), INTENT(inout), DIMENSION(:) :: sd ! input field related variables + INTEGER , INTENT(in ), OPTIONAL :: kit ! subcycle timestep for timesplitting option + REAL(wp) , INTENT(in ), OPTIONAL :: pt_offset ! provide fields at time other than "now" + INTEGER , INTENT(in ), OPTIONAL :: Kmm ! ocean time level index + !! + INTEGER :: imf ! size of the structure sd + INTEGER :: jf ! dummy indices + INTEGER :: isecsbc ! number of seconds between Jan. 1st 00h of nit000 year and the middle of sbc time step + INTEGER :: ibb, iaa ! shorter name for sd(jf)%nbb and sd(jf)%naa + LOGICAL :: ll_firstcall ! true if this is the first call to fld_read for this set of fields + REAL(wp) :: zt_offset ! local time offset variable + REAL(wp) :: ztinta ! ratio applied to after records when doing time interpolation + REAL(wp) :: ztintb ! ratio applied to before records when doing time interpolation + CHARACTER(LEN=1000) :: clfmt ! write format + !!--------------------------------------------------------------------- + ll_firstcall = kt == nit000 + IF( PRESENT(kit) ) ll_firstcall = ll_firstcall .and. kit == 1 + + IF( nn_components == jp_iam_sas ) THEN ; zt_offset = REAL( nn_fsbc, wp ) + ELSE ; zt_offset = 0. + ENDIF + IF( PRESENT(pt_offset) ) zt_offset = pt_offset + + ! Note that all varibles starting by nsec_* are shifted time by +1/2 time step to be centrered + IF( PRESENT(kit) ) THEN ! ignore kn_fsbc in this case + isecsbc = nsec_year + nsec1jan000 + NINT( ( REAL( kit,wp) + zt_offset ) * rn_Dt / REAL(nn_e,wp) ) + ELSE ! middle of sbc time step + ! note: we use kn_fsbc-1 because nsec_year is defined at the middle of the current time step + isecsbc = nsec_year + nsec1jan000 + NINT( ( 0.5*REAL(kn_fsbc-1,wp) + zt_offset ) * rn_Dt ) + ENDIF + imf = SIZE( sd ) + ! + IF( ll_firstcall ) THEN ! initialization + DO jf = 1, imf + IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE + CALL fld_init( isecsbc, sd(jf) ) ! read each before field (put them in after as they will be swapped) + END DO + IF( lwp ) CALL wgt_print() ! control print + ENDIF + ! ! ====================================== ! + IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN ! update field at each kn_fsbc time-step ! + ! ! ====================================== ! + ! + DO jf = 1, imf ! --- loop over field --- ! + ! + IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE + CALL fld_update( isecsbc, sd(jf), Kmm ) + ! + END DO ! --- end loop over field --- ! + + CALL fld_rot( kt, sd ) ! rotate vector before/now/after fields if needed + + DO jf = 1, imf ! --- loop over field --- ! + ! + IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE + ! + ibb = sd(jf)%nbb ; iaa = sd(jf)%naa + ! + IF( sd(jf)%ln_tint ) THEN ! temporal interpolation + IF(lwp .AND. ( kt - nit000 <= 20 .OR. nitend - kt <= 20 ) ) THEN + clfmt = "(' fld_read: var ', a, ' kt = ', i8, ' (', f9.4,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," // & + & "', records b/a: ', i6.4, '/', i6.4, ' (days ', f9.4,'/', f9.4, ')')" + WRITE(numout, clfmt) TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & + & sd(jf)%nrec(1,ibb), sd(jf)%nrec(1,iaa), REAL(sd(jf)%nrec(2,ibb),wp)/rday, REAL(sd(jf)%nrec(2,iaa),wp)/rday + IF( zt_offset /= 0._wp ) WRITE(numout, *) ' zt_offset is : ', zt_offset + ENDIF + ! temporal interpolation weights + ztinta = REAL( isecsbc - sd(jf)%nrec(2,ibb), wp ) / REAL( sd(jf)%nrec(2,iaa) - sd(jf)%nrec(2,ibb), wp ) + ztintb = 1. - ztinta + sd(jf)%fnow(:,:,:) = ztintb * sd(jf)%fdta(:,:,:,ibb) + ztinta * sd(jf)%fdta(:,:,:,iaa) + ELSE ! nothing to do... + IF(lwp .AND. ( kt - nit000 <= 20 .OR. nitend - kt <= 20 ) ) THEN + clfmt = "(' fld_read: var ', a, ' kt = ', i8,' (', f9.4,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," // & + & "', record: ', i6.4, ' (days ', f9.4, ' <-> ', f9.4, ')')" + WRITE(numout, clfmt) TRIM(sd(jf)%clvar), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday, & + & sd(jf)%nrec(1,iaa), REAL(sd(jf)%nrec(2,ibb),wp)/rday, REAL(sd(jf)%nrec(2,iaa),wp)/rday + ENDIF + ENDIF + ! + IF( kt == nitend - kn_fsbc + 1 ) CALL iom_close( sd(jf)%num ) ! Close the input files + + END DO ! --- end loop over field --- ! + ! + ENDIF + ! + END SUBROUTINE fld_read + + + SUBROUTINE fld_init( ksecsbc, sdjf ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_init *** + !! + !! ** Purpose : - first call(s) to fld_def to define before values + !! - open file + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ksecsbc ! + TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables + !!--------------------------------------------------------------------- + ! + IF( nflag == 0 ) nflag = -HUGE(0) + ! + CALL fld_def( sdjf ) + IF( sdjf%ln_tint .AND. ksecsbc < sdjf%nrecsec(1) ) CALL fld_def( sdjf, ldprev = .TRUE. ) + ! + CALL fld_clopn( sdjf ) + sdjf%nrec(:,sdjf%naa) = (/ 1, nflag /) ! default definition to force flp_update to read the file. + ! + END SUBROUTINE fld_init + + + SUBROUTINE fld_update( ksecsbc, sdjf, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_update *** + !! + !! ** Purpose : Compute + !! if sdjf%ln_tint = .TRUE. + !! nrec(:,iaa): record number and its time (nrec(:,ibb) is obtained from nrec(:,iaa) when swapping) + !! if sdjf%ln_tint = .FALSE. + !! nrec(1,iaa): record number + !! nrec(2,ibb) and nrec(2,iaa): time of the beginning and end of the record + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ksecsbc ! + TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables + INTEGER , OPTIONAL, INTENT(in ) :: Kmm ! ocean time level index + ! + INTEGER :: ja ! end of this record (in seconds) + INTEGER :: ibb, iaa ! shorter name for sdjf%nbb and sdjf%naa + !!---------------------------------------------------------------------- + ibb = sdjf%nbb ; iaa = sdjf%naa + ! + IF( ksecsbc > sdjf%nrec(2,iaa) ) THEN ! --> we need to update after data + + ! find where is the new after record... (it is not necessary sdjf%nrec(1,iaa)+1 ) + ja = sdjf%nrec(1,iaa) + DO WHILE ( ksecsbc >= sdjf%nrecsec(ja) .AND. ja < sdjf%nreclast ) ! Warning: make sure ja <= sdjf%nreclast in this test + ja = ja + 1 + END DO + IF( ksecsbc > sdjf%nrecsec(ja) ) ja = ja + 1 ! in case ksecsbc > sdjf%nrecsec(sdjf%nreclast) + + ! if ln_tint and if the new after is not ja+1, we need also to update after data before the swap + ! so, after the swap, sdjf%nrec(2,ibb) will still be the closest value located just before ksecsbc + IF( sdjf%ln_tint .AND. ( ja > sdjf%nrec(1,iaa) + 1 .OR. sdjf%nrec(2,iaa) == nflag ) ) THEN + sdjf%nrec(:,iaa) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! update nrec(:,iaa) with before information + CALL fld_get( sdjf, Kmm ) ! read after data that will be used as before data + ENDIF + + ! if after is in the next file... + IF( ja > sdjf%nreclast ) THEN + + CALL fld_def( sdjf ) + IF( ksecsbc > sdjf%nrecsec(sdjf%nreclast) ) CALL fld_def( sdjf, ldnext = .TRUE. ) + CALL fld_clopn( sdjf ) ! open next file + + ! find where is after in this new file + ja = 1 + DO WHILE ( ksecsbc > sdjf%nrecsec(ja) .AND. ja < sdjf%nreclast ) + ja = ja + 1 + END DO + IF( ksecsbc > sdjf%nrecsec(ja) ) ja = ja + 1 ! in case ksecsbc > sdjf%nrecsec(sdjf%nreclast) + + IF( ja > sdjf%nreclast ) THEN + CALL ctl_stop( "STOP", "fld_def: need next-next file? we should not be there... file: "//TRIM(sdjf%clrootname) ) + ENDIF + + ! if ln_tint and if after is not the first record, we must (potentially again) update after data before the swap + IF( sdjf%ln_tint .AND. ja > 1 ) THEN + IF( sdjf%nrecsec(0) /= nflag ) THEN ! no trick used: after file is not the current file + sdjf%nrec(:,iaa) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! update nrec(:,iaa) with before information + CALL fld_get( sdjf, Kmm ) ! read after data that will be used as before data + ENDIF + ENDIF + + ENDIF + + IF( sdjf%ln_tint ) THEN ! Swap data + sdjf%nbb = sdjf%naa ! swap indices + sdjf%naa = 3 - sdjf%naa ! = 2(1) if naa == 1(2) + ELSE ! No swap + sdjf%nrec(:,ibb) = (/ ja-1, sdjf%nrecsec(ja-1) /) ! only for print + ENDIF + + ! read new after data + sdjf%nrec(:,sdjf%naa) = (/ ja, sdjf%nrecsec(ja) /) ! update nrec(:,naa) as it is used by fld_get + CALL fld_get( sdjf, Kmm ) ! read after data (with nrec(:,naa) informations) + + ENDIF + ! + END SUBROUTINE fld_update + + + SUBROUTINE fld_get( sdjf, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_get *** + !! + !! ** Purpose : read the data + !!---------------------------------------------------------------------- + TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables + INTEGER , OPTIONAL, INTENT(in ) :: Kmm ! ocean time level index + ! + INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) + INTEGER :: iaa ! shorter name for sdjf%naa + INTEGER :: iw ! index into wgts array + INTEGER :: idvar ! variable ID + INTEGER :: idmspc ! number of spatial dimensions + REAL(wp) :: zsgn ! sign used in the call to lbc_lbk called by iom_get + REAL(wp), DIMENSION(:,:,:), POINTER :: dta_alias ! short cut + !!--------------------------------------------------------------------- + iaa = sdjf%naa + ! + IF( sdjf%ln_tint ) THEN ; dta_alias => sdjf%fdta(:,:,:,iaa) + ELSE ; dta_alias => sdjf%fnow(:,:,: ) + ENDIF + ipk = SIZE( dta_alias, 3 ) + ! + IF( LEN_TRIM(sdjf%vcomp) > 0 ) THEN ; zsgn = 1._wp ! geographical vectors -> sign change done later when rotating + ELSE ; zsgn = sdjf%zsgn + ENDIF + ! + IF( ASSOCIATED(sdjf%imap) ) THEN ! BDY case + CALL fld_map( sdjf%num, sdjf%clvar, dta_alias(:,:,:), sdjf%nrec(1,iaa), & + & sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint, Kmm ) + ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN ! On-the-fly interpolation + CALL wgt_list( sdjf, iw ) + CALL fld_interp( sdjf%num, sdjf%clvar, iw, ipk, dta_alias(:,:,:), sdjf%nrec(1,iaa), sdjf%lsmname ) + CALL lbc_lnk( 'fldread', dta_alias(:,:,:), sdjf%cltype, zsgn, kfillmode = jpfillcopy ) + ELSE ! default case + idvar = iom_varid( sdjf%num, sdjf%clvar ) + idmspc = iom_file ( sdjf%num )%ndims( idvar ) + IF( iom_file( sdjf%num )%luld( idvar ) ) idmspc = idmspc - 1 ! id of the last spatial dimension + CALL iom_get( sdjf%num, jpdom_global, sdjf%clvar, dta_alias(:,:,:), sdjf%nrec(1,iaa), & + & sdjf%cltype, CASTDP(zsgn), kfill = jpfillcopy ) + ENDIF + ! + sdjf%rotn(iaa) = .false. ! vector not yet rotated + ! + END SUBROUTINE fld_get + + + SUBROUTINE fld_map( knum, cdvar, pdta, krec, kmap, kgrd, kbdy, ldtotvel, ldzint, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_map *** + !! + !! ** Purpose : read global data from file and map onto local data + !! using a general mapping (for open boundaries) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: knum ! stream number + CHARACTER(LEN=*) , INTENT(in ) :: cdvar ! variable name + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta ! bdy output field on model grid + INTEGER , INTENT(in ) :: krec ! record number to read (ie time slice) + INTEGER , DIMENSION(:) , INTENT(in ) :: kmap ! global-to-local bdy mapping indices + ! optional variables used for vertical interpolation: + INTEGER, OPTIONAL , INTENT(in ) :: kgrd ! grid type (t, u, v) + INTEGER, OPTIONAL , INTENT(in ) :: kbdy ! bdy number + LOGICAL, OPTIONAL , INTENT(in ) :: ldtotvel ! true if total ( = barotrop + barocline) velocity + LOGICAL, OPTIONAL , INTENT(in ) :: ldzint ! true if 3D variable requires a vertical interpolation + INTEGER, OPTIONAL , INTENT(in ) :: Kmm ! ocean time level index + !! + INTEGER :: ipi ! length of boundary data on local process + INTEGER :: ipj ! length of dummy dimension ( = 1 ) + INTEGER :: ipk ! number of vertical levels of pdta ( 2D: ipk=1 ; 3D: ipk=jpk ) + INTEGER :: ipkb ! number of vertical levels in boundary data file + INTEGER :: idvar ! variable ID + INTEGER :: indims ! number of dimensions of the variable + INTEGER, DIMENSION(4) :: idimsz ! size of variable dimensions + REAL(wp) :: zfv ! fillvalue + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zz_read ! work space for global boundary data + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read ! work space local data requiring vertical interpolation + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_z ! work space local data requiring vertical interpolation + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zdta_read_dz ! work space local data requiring vertical interpolation + CHARACTER(LEN=1),DIMENSION(3) :: cltype + LOGICAL :: lluld ! is the variable using the unlimited dimension + LOGICAL :: llzint ! local value of ldzint + !!--------------------------------------------------------------------- + ! + cltype = (/'t','u','v'/) + ! + ipi = SIZE( pdta, 1 ) + ipj = SIZE( pdta, 2 ) ! must be equal to 1 + ipk = SIZE( pdta, 3 ) + ! + llzint = .FALSE. + IF( PRESENT(ldzint) ) llzint = ldzint + ! + idvar = iom_varid( knum, cdvar, kndims = indims, kdimsz = idimsz, lduld = lluld ) + IF( indims == 4 .OR. ( indims == 3 .AND. .NOT. lluld ) ) THEN ; ipkb = idimsz(3) ! xy(zl)t or xy(zl) + ELSE ; ipkb = 1 ! xy or xyt + ENDIF + ! + ALLOCATE( zz_read( idimsz(1), idimsz(2), ipkb ) ) ! ++++++++ !!! this can be very big... + ! + IF( ipk == 1 ) THEN + + IF( ipkb /= 1 ) CALL ctl_stop( 'fld_map : we must have ipkb = 1 to read surface data' ) + CALL iom_get ( knum, jpdom_unknown, cdvar, zz_read(:,:,1), krec ) ! call iom_get with a 2D file + CALL fld_map_core( zz_read, kmap, pdta ) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Do we include something here to adjust barotropic velocities ! + ! in case of a depth difference between bdy files and ! + ! bathymetry in the case ln_totvel = .false. and ipkb>0? ! + ! [as the enveloping and parital cells could change H] ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ELSE + ! + CALL iom_get ( knum, jpdom_unknown, cdvar, zz_read(:,:,:), krec ) ! call iom_get with a 3D file + ! + IF( ipkb /= ipk .OR. llzint ) THEN ! boundary data not on model vertical grid : vertical interpolation + ! + IF( ipk == jpk .AND. iom_varid(knum,'gdep'//cltype(kgrd)) /= -1 .AND. iom_varid(knum,'e3'//cltype(kgrd)) /= -1 ) THEN + + ALLOCATE( zdta_read(ipi,ipj,ipkb), zdta_read_z(ipi,ipj,ipkb), zdta_read_dz(ipi,ipj,ipkb) ) + + CALL fld_map_core( zz_read, kmap, zdta_read ) + CALL iom_get ( knum, jpdom_unknown, 'gdep'//cltype(kgrd), zz_read ) ! read only once? Potential temporal evolution? + CALL fld_map_core( zz_read, kmap, zdta_read_z ) + CALL iom_get ( knum, jpdom_unknown, 'e3'//cltype(kgrd), zz_read ) ! read only once? Potential temporal evolution? + CALL fld_map_core( zz_read, kmap, zdta_read_dz ) + + CALL iom_getatt(knum, '_FillValue', zfv, cdvar=cdvar ) + CALL fld_bdy_interp(zdta_read, zdta_read_z, zdta_read_dz, pdta, kgrd, kbdy, zfv, ldtotvel, Kmm) + DEALLOCATE( zdta_read, zdta_read_z, zdta_read_dz ) + + ELSE + IF( ipk /= jpk ) CALL ctl_stop( 'fld_map : this should be an impossible case...' ) + WRITE(ctmp1,*) 'fld_map : vertical interpolation for bdy variable '//TRIM(cdvar)//' requires ' + IF( iom_varid(knum, 'gdep'//cltype(kgrd)) == -1 ) CALL ctl_stop( ctmp1//'gdep'//cltype(kgrd)//' variable' ) + IF( iom_varid(knum, 'e3'//cltype(kgrd)) == -1 ) CALL ctl_stop( ctmp1// 'e3'//cltype(kgrd)//' variable' ) + + ENDIF + ! + ELSE ! bdy data assumed to be the same levels as bdy variables + ! + CALL fld_map_core( zz_read, kmap, pdta ) + ! + ENDIF ! ipkb /= ipk + ENDIF ! ipk == 1 + + DEALLOCATE( zz_read ) + + END SUBROUTINE fld_map + + + SUBROUTINE fld_map_core( pdta_read, kmap, pdta_bdy ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_map_core *** + !! + !! ** Purpose : inner core of fld_map + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read ! global boundary data + INTEGER, DIMENSION(: ), INTENT(in ) :: kmap ! global-to-local bdy mapping indices + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta_bdy ! bdy output field on model grid + !! + INTEGER, DIMENSION(3) :: idim_read, idim_bdy ! arrays dimensions + INTEGER :: ji, jj, jk, jb ! loop counters + INTEGER :: im1 + !!--------------------------------------------------------------------- + ! + idim_read = SHAPE( pdta_read ) + idim_bdy = SHAPE( pdta_bdy ) + ! + ! in all cases: idim_bdy(2) == 1 .AND. idim_read(1) * idim_read(2) == idim_bdy(1) + ! structured BDY with rimwidth > 1 : idim_read(2) == rimwidth /= 1 + ! structured BDY with rimwidth == 1 or unstructured BDY: idim_read(2) == 1 + ! + IF( idim_read(2) > 1 ) THEN ! structured BDY with rimwidth > 1 + DO jk = 1, idim_bdy(3) + DO jb = 1, idim_bdy(1) + im1 = kmap(jb) - 1 + jj = im1 / idim_read(1) + 1 + ji = MOD( im1, idim_read(1) ) + 1 + pdta_bdy(jb,1,jk) = pdta_read(ji,jj,jk) + END DO + END DO + ELSE + DO jk = 1, idim_bdy(3) + DO jb = 1, idim_bdy(1) ! horizontal remap of bdy data on the local bdy + pdta_bdy(jb,1,jk) = pdta_read(kmap(jb),1,jk) + END DO + END DO + ENDIF + + END SUBROUTINE fld_map_core + + SUBROUTINE fld_bdy_interp(pdta_read, pdta_read_z, pdta_read_dz, pdta, kgrd, kbdy, pfv, ldtotvel, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_bdy_interp *** + !! + !! ** Purpose : on the fly vertical interpolation to allow the use of + !! boundary data from non-native vertical grid + !!---------------------------------------------------------------------- + USE bdy_oce, ONLY: idx_bdy ! indexing for map <-> ij transformation + + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read ! data read in bdy file + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read_z ! depth of the data read in bdy file + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdta_read_dz ! thickness of the levels in bdy file + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdta ! output field on model grid (2 dimensional) + REAL(wp) , INTENT(in ) :: pfv ! fillvalue of the data read in bdy file + LOGICAL , INTENT(in ) :: ldtotvel ! true if toal ( = barotrop + barocline) velocity + INTEGER , INTENT(in ) :: kgrd ! grid type (t, u, v) + INTEGER , INTENT(in ) :: kbdy ! bdy number + INTEGER, OPTIONAL , INTENT(in ) :: Kmm ! ocean time level index + !! + INTEGER :: ipi ! length of boundary data on local process + INTEGER :: ipkb ! number of vertical levels in boundary data file + INTEGER :: ipkmax ! number of vertical levels in boundary data file where no mask + INTEGER :: jb, ji, jj, jk, jkb ! loop counters + REAL(wp) :: zcoef, zi ! + REAL(wp) :: ztrans, ztrans_new ! transports + REAL(wp), DIMENSION(jpk) :: zdepth, zdhalf ! level and half-level depth + !!--------------------------------------------------------------------- + + ipi = SIZE( pdta, 1 ) + ipkb = SIZE( pdta_read, 3 ) + + DO jb = 1, ipi + ji = idx_bdy(kbdy)%nbi(jb,kgrd) + jj = idx_bdy(kbdy)%nbj(jb,kgrd) + ! + ! --- max jk where input data /= FillValue --- ! + ipkmax = 1 + DO jkb = 2, ipkb + IF( pdta_read(jb,1,jkb) /= pfv ) ipkmax = MAX( ipkmax, jkb ) + END DO + ! + ! --- calculate depth at t,u,v points --- ! + SELECT CASE( kgrd ) + CASE(1) ! depth of T points: + zdepth(:) = gdept(ji,jj,:,Kmm) + CASE(2) ! depth of U points: we must not use gdept_n as we don't want to do a communication + ! --> copy what is done for gdept_n in domvvl... + zdhalf(1) = 0.0_wp + zdepth(1) = 0.5_wp * e3uw(ji,jj,1,Kmm) + DO jk = 2, jpk ! vertical sum + ! zcoef = umask - wumask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt + ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) + ! ! 0.5 where jk = mikt + !!gm ??????? BUG ? gdept_n as well as gde3w_n does not include the thickness of ISF ?? + zcoef = ( umask(ji,jj,jk) - wumask(ji,jj,jk) ) + zdhalf(jk) = zdhalf(jk-1) + e3u(ji,jj,jk-1,Kmm) + zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5_wp * e3uw(ji,jj,jk,Kmm)) & + & + (1._wp-zcoef) * ( zdepth(jk-1) + e3uw(ji,jj,jk,Kmm)) + END DO + CASE(3) ! depth of V points: we must not use gdept_n as we don't want to do a communication + ! --> copy what is done for gdept_n in domvvl... + zdhalf(1) = 0.0_wp + zdepth(1) = 0.5_wp * e3vw(ji,jj,1,Kmm) + DO jk = 2, jpk ! vertical sum + ! zcoef = vmask - wvmask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt + ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) + ! ! 0.5 where jk = mikt + !!gm ??????? BUG ? gdept_n as well as gde3w_n does not include the thickness of ISF ?? + zcoef = ( vmask(ji,jj,jk) - wvmask(ji,jj,jk) ) + zdhalf(jk) = zdhalf(jk-1) + e3v(ji,jj,jk-1,Kmm) + zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5_wp * e3vw(ji,jj,jk,Kmm)) & + + (1._wp-zcoef) * ( zdepth(jk-1) + e3vw(ji,jj,jk,Kmm)) + END DO + END SELECT + ! + ! --- interpolate bdy data on the model grid --- ! + DO jk = 1, jpk + IF( zdepth(jk) <= pdta_read_z(jb,1,1) ) THEN ! above the first level of external data + pdta(jb,1,jk) = pdta_read(jb,1,1) + ELSEIF( zdepth(jk) > pdta_read_z(jb,1,ipkmax) ) THEN ! below the last level of external data /= FillValue + pdta(jb,1,jk) = pdta_read(jb,1,ipkmax) + ELSE ! inbetween: vertical interpolation between jkb & jkb+1 + DO jkb = 1, ipkmax-1 + IF( ( ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) * ( zdepth(jk) - pdta_read_z(jb,1,jkb+1) ) ) <= 0._wp ) THEN ! linear interpolation between 2 levels + zi = ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) / ( pdta_read_z(jb,1,jkb+1) - pdta_read_z(jb,1,jkb) ) + pdta(jb,1,jk) = pdta_read(jb,1,jkb) + zi * ( pdta_read(jb,1,jkb+1) - pdta_read(jb,1,jkb) ) + ENDIF + END DO + ENDIF + END DO ! jpk + ! + END DO ! ipi + + ! --- mask data and adjust transport --- ! + SELECT CASE( kgrd ) + + CASE(1) ! mask data (probably unecessary) + DO jb = 1, ipi + ji = idx_bdy(kbdy)%nbi(jb,kgrd) + jj = idx_bdy(kbdy)%nbj(jb,kgrd) + DO jk = 1, jpk + pdta(jb,1,jk) = pdta(jb,1,jk) * tmask(ji,jj,jk) + END DO + END DO + + CASE(2) ! adjust the U-transport term + DO jb = 1, ipi + ji = idx_bdy(kbdy)%nbi(jb,kgrd) + jj = idx_bdy(kbdy)%nbj(jb,kgrd) + ztrans = 0._wp + DO jkb = 1, ipkb ! calculate transport on input grid + IF( pdta_read(jb,1,jkb) /= pfv ) ztrans = ztrans + pdta_read(jb,1,jkb) * pdta_read_dz(jb,1,jkb) + ENDDO + ztrans_new = 0._wp + DO jk = 1, jpk ! calculate transport on model grid + ztrans_new = ztrans_new + pdta(jb,1,jk ) * e3u(ji,jj,jk,Kmm ) * umask(ji,jj,jk) + ENDDO + DO jk = 1, jpk ! make transport correction + IF(ldtotvel) THEN ! bdy data are total velocity so adjust bt transport term to match input data + pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( ztrans - ztrans_new ) * r1_hu(ji,jj,Kmm) ) * umask(ji,jj,jk) + ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero + pdta(jb,1,jk) = pdta(jb,1,jk) + ( 0._wp - ztrans_new ) * r1_hu(ji,jj,Kmm) * umask(ji,jj,jk) + ENDIF + ENDDO + ENDDO + + CASE(3) ! adjust the V-transport term + DO jb = 1, ipi + ji = idx_bdy(kbdy)%nbi(jb,kgrd) + jj = idx_bdy(kbdy)%nbj(jb,kgrd) + ztrans = 0._wp + DO jkb = 1, ipkb ! calculate transport on input grid + IF( pdta_read(jb,1,jkb) /= pfv ) ztrans = ztrans + pdta_read(jb,1,jkb) * pdta_read_dz(jb,1,jkb) + ENDDO + ztrans_new = 0._wp + DO jk = 1, jpk ! calculate transport on model grid + ztrans_new = ztrans_new + pdta(jb,1,jk ) * e3v(ji,jj,jk,Kmm ) * vmask(ji,jj,jk) + ENDDO + DO jk = 1, jpk ! make transport correction + IF(ldtotvel) THEN ! bdy data are total velocity so adjust bt transport term to match input data + pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( ztrans - ztrans_new ) * r1_hv(ji,jj,Kmm) ) * vmask(ji,jj,jk) + ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero + pdta(jb,1,jk) = pdta(jb,1,jk) + ( 0._wp - ztrans_new ) * r1_hv(ji,jj,Kmm) * vmask(ji,jj,jk) + ENDIF + ENDDO + ENDDO + END SELECT + + END SUBROUTINE fld_bdy_interp + + + SUBROUTINE fld_rot( kt, sd ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_rot *** + !! + !! ** Purpose : Vector fields may need to be rotated onto the local grid direction + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + TYPE(FLD), DIMENSION(:), INTENT(inout) :: sd ! input field related variables + ! + INTEGER :: ju, jv, jk, jn ! loop indices + INTEGER :: imf ! size of the structure sd + INTEGER :: ill ! character length + INTEGER :: iv ! indice of V component + CHARACTER (LEN=100) :: clcomp ! dummy weight name + REAL(wp), DIMENSION(jpi,jpj) :: utmp, vtmp ! temporary arrays for vector rotation + REAL(wp), DIMENSION(:,:,:), POINTER :: dta_u, dta_v ! short cut + !!--------------------------------------------------------------------- + ! + !! (sga: following code should be modified so that pairs arent searched for each time + ! + imf = SIZE( sd ) + DO ju = 1, imf + IF( TRIM(sd(ju)%clrootname) == 'NOT USED' ) CYCLE + ill = LEN_TRIM( sd(ju)%vcomp ) + DO jn = 2-COUNT((/sd(ju)%ln_tint/)), 2 + IF( ill > 0 .AND. .NOT. sd(ju)%rotn(jn) ) THEN ! find vector rotations required + IF( sd(ju)%vcomp(1:1) == 'U' ) THEN ! east-west component has symbolic name starting with 'U' + ! look for the north-south component which has same symbolic name but with 'U' replaced with 'V' + clcomp = 'V' // sd(ju)%vcomp(2:ill) ! works even if ill == 1 + iv = -1 + DO jv = 1, imf + IF( TRIM(sd(jv)%clrootname) == 'NOT USED' ) CYCLE + IF( TRIM(sd(jv)%vcomp) == TRIM(clcomp) ) iv = jv + END DO + IF( iv > 0 ) THEN ! fields ju and iv are two components which need to be rotated together + IF( sd(ju)%ln_tint ) THEN ; dta_u => sd(ju)%fdta(:,:,:,jn) ; dta_v => sd(iv)%fdta(:,:,:,jn) + ELSE ; dta_u => sd(ju)%fnow(:,:,: ) ; dta_v => sd(iv)%fnow(:,:,: ) + ENDIF + DO jk = 1, SIZE( sd(ju)%fnow, 3 ) + CALL rot_rep( dta_u(:,:,jk), dta_v(:,:,jk), 'T', 'en->i', utmp(:,:) ) + CALL rot_rep( dta_u(:,:,jk), dta_v(:,:,jk), 'T', 'en->j', vtmp(:,:) ) + dta_u(:,:,jk) = utmp(:,:) ; dta_v(:,:,jk) = vtmp(:,:) + END DO + sd(ju)%rotn(jn) = .TRUE. ! vector was rotated + IF( lwp .AND. kt == nit000 ) WRITE(numout,*) & + & 'fld_read: vector pair ('//TRIM(sd(ju)%clvar)//', '//TRIM(sd(iv)%clvar)//') rotated on to model grid' + ENDIF + ENDIF + ENDIF + END DO + END DO + ! + END SUBROUTINE fld_rot + + + SUBROUTINE fld_def( sdjf, ldprev, ldnext ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_def *** + !! + !! ** Purpose : define the record(s) of the file and its name + !!---------------------------------------------------------------------- + TYPE(FLD) , INTENT(inout) :: sdjf ! input field related variables + LOGICAL, OPTIONAL, INTENT(in ) :: ldprev ! + LOGICAL, OPTIONAL, INTENT(in ) :: ldnext ! + ! + INTEGER :: jt + INTEGER :: idaysec ! number of seconds in 1 day = NINT(rday) + INTEGER :: iyr, imt, idy, isecwk + INTEGER :: indexyr, indexmt + INTEGER :: ireclast + INTEGER :: ishift, istart + INTEGER, DIMENSION(2) :: isave + REAL(wp) :: zfreqs + LOGICAL :: llprev, llnext, llstop + LOGICAL :: llprevmt, llprevyr + LOGICAL :: llnextmt, llnextyr + !!---------------------------------------------------------------------- + idaysec = NINT(rday) + ! + IF( PRESENT(ldprev) ) THEN ; llprev = ldprev + ELSE ; llprev = .FALSE. + ENDIF + IF( PRESENT(ldnext) ) THEN ; llnext = ldnext + ELSE ; llnext = .FALSE. + ENDIF + + ! current file parameters + IF( sdjf%clftyp(1:4) == 'week' ) THEN ! find the day of the beginning of the current week + isecwk = ksec_week( sdjf%clftyp(6:8) ) ! seconds between the beginning of the week and half of current time step + llprevmt = isecwk > nsec_month ! longer time since beginning of the current week than the current month + llprevyr = llprevmt .AND. nmonth == 1 + iyr = nyear - COUNT((/llprevyr/)) + imt = nmonth - COUNT((/llprevmt/)) + 12 * COUNT((/llprevyr/)) + idy = nday + nmonth_len(nmonth-1) * COUNT((/llprevmt/)) - isecwk / idaysec + isecwk = nsec_year - isecwk ! seconds between 00h jan 1st of current year and current week beginning + ELSE + iyr = nyear + imt = nmonth + idy = nday + isecwk = 0 + ENDIF + + ! previous file parameters + IF( llprev ) THEN + IF( sdjf%clftyp(1:4) == 'week' ) THEN ! find the day of the beginning of previous week + isecwk = isecwk + 7 * idaysec ! seconds between the beginning of previous week and half of the time step + llprevmt = isecwk > nsec_month ! longer time since beginning of the previous week than the current month + llprevyr = llprevmt .AND. nmonth == 1 + iyr = nyear - COUNT((/llprevyr/)) + imt = nmonth - COUNT((/llprevmt/)) + 12 * COUNT((/llprevyr/)) + idy = nday + nmonth_len(nmonth-1) * COUNT((/llprevmt/)) - isecwk / idaysec + isecwk = nsec_year - isecwk ! seconds between 00h jan 1st of current year and previous week beginning + ELSE + idy = nday - COUNT((/ sdjf%clftyp == 'daily' /)) + imt = nmonth - COUNT((/ sdjf%clftyp == 'monthly' .OR. idy == 0 /)) + iyr = nyear - COUNT((/ sdjf%clftyp == 'yearly' .OR. imt == 0 /)) + IF( idy == 0 ) idy = nmonth_len(imt) + IF( imt == 0 ) imt = 12 + isecwk = 0 + ENDIF + ENDIF + + ! next file parameters + IF( llnext ) THEN + IF( sdjf%clftyp(1:4) == 'week' ) THEN ! find the day of the beginning of next week + isecwk = 7 * idaysec - isecwk ! seconds between half of the time step and the beginning of next week + llnextmt = isecwk > ( nmonth_len(nmonth)*idaysec - nsec_month ) ! larger than the seconds to the end of the month + llnextyr = llnextmt .AND. nmonth == 12 + iyr = nyear + COUNT((/llnextyr/)) + imt = nmonth + COUNT((/llnextmt/)) - 12 * COUNT((/llnextyr/)) + idy = nday - nmonth_len(nmonth) * COUNT((/llnextmt/)) + isecwk / idaysec + 1 + isecwk = nsec_year + isecwk ! seconds between 00h jan 1st of current year and next week beginning + ELSE + idy = nday + COUNT((/ sdjf%clftyp == 'daily' /)) + imt = nmonth + COUNT((/ sdjf%clftyp == 'monthly' .OR. idy > nmonth_len(nmonth) /)) + iyr = nyear + COUNT((/ sdjf%clftyp == 'yearly' .OR. imt == 13 /)) + IF( idy > nmonth_len(nmonth) ) idy = 1 + IF( imt == 13 ) imt = 1 + isecwk = 0 + ENDIF + ENDIF + ! + ! find the last record to be read -> update sdjf%nreclast + indexyr = iyr - nyear + 1 ! which year are we looking for? previous(0), current(1) or next(2)? + indexmt = imt + 12 * ( indexyr - 1 ) ! which month are we looking for (relatively to current year)? + ! + ! Last record to be read in the current file + ! Predefine the number of record in the file according of its type. + ! We could compare this number with the number of records in the file and make a stop if the 2 numbers do not match... + ! However this would be much less fexible (e.g. for tests) and will force to rewite input files according to nleapy... + IF ( NINT(sdjf%freqh) == -12 ) THEN ; ireclast = 1 ! yearly mean: consider only 1 record + ELSEIF( NINT(sdjf%freqh) == -1 ) THEN ! monthly mean: + IF( sdjf%clftyp == 'monthly' ) THEN ; ireclast = 1 ! consider that the file has 1 record + ELSE ; ireclast = 12 ! consider that the file has 12 record + ENDIF + ELSE ! higher frequency mean (in hours) + IF( sdjf%clftyp == 'monthly' ) THEN ; ireclast = NINT( 24. * REAL(nmonth_len(indexmt), wp) / sdjf%freqh ) + ELSEIF( sdjf%clftyp(1:4) == 'week' ) THEN ; ireclast = NINT( 24. * 7. / sdjf%freqh ) + ELSEIF( sdjf%clftyp == 'daily' ) THEN ; ireclast = NINT( 24. / sdjf%freqh ) + ELSE ; ireclast = NINT( 24. * REAL( nyear_len(indexyr), wp) / sdjf%freqh ) + ENDIF + ENDIF + + sdjf%nreclast = ireclast + ! Allocate arrays for beginning/middle/end of each record (seconds since Jan. 1st 00h of nit000 year) + IF( ALLOCATED(sdjf%nrecsec) ) DEALLOCATE( sdjf%nrecsec ) + ALLOCATE( sdjf%nrecsec( 0:ireclast ) ) + ! + IF ( NINT(sdjf%freqh) == -12 ) THEN ! yearly mean and yearly file + SELECT CASE( indexyr ) + CASE(0) ; sdjf%nrecsec(0) = nsec1jan000 - nyear_len( 0 ) * idaysec + CASE(1) ; sdjf%nrecsec(0) = nsec1jan000 + CASE(2) ; sdjf%nrecsec(0) = nsec1jan000 + nyear_len( 1 ) * idaysec + ENDSELECT + sdjf%nrecsec(1) = sdjf%nrecsec(0) + nyear_len( indexyr ) * idaysec + ELSEIF( NINT(sdjf%freqh) == -1 ) THEN ! monthly mean: + IF( sdjf%clftyp == 'monthly' ) THEN ! monthly file + sdjf%nrecsec(0 ) = nsec1jan000 + nmonth_beg(indexmt ) + sdjf%nrecsec(1 ) = nsec1jan000 + nmonth_beg(indexmt+1) + ELSE ! yearly file + ishift = 12 * ( indexyr - 1 ) + sdjf%nrecsec(0:12) = nsec1jan000 + nmonth_beg(1+ishift:13+ishift) + ENDIF + ELSE ! higher frequency mean (in hours) + IF( sdjf%clftyp == 'monthly' ) THEN ; istart = nsec1jan000 + nmonth_beg(indexmt) + ELSEIF( sdjf%clftyp(1:4) == 'week' ) THEN ; istart = nsec1jan000 + isecwk + ELSEIF( sdjf%clftyp == 'daily' ) THEN ; istart = nsec1jan000 + nmonth_beg(indexmt) + ( idy - 1 ) * idaysec + ELSEIF( indexyr == 0 ) THEN ; istart = nsec1jan000 - nyear_len( 0 ) * idaysec + ELSEIF( indexyr == 2 ) THEN ; istart = nsec1jan000 + nyear_len( 1 ) * idaysec + ELSE ; istart = nsec1jan000 + ENDIF + zfreqs = sdjf%freqh * rhhmm * rmmss + DO jt = 0, sdjf%nreclast + sdjf%nrecsec(jt) = istart + NINT( zfreqs * REAL(jt,wp) ) + END DO + ENDIF + ! + IF( sdjf%ln_tint ) THEN ! record time defined in the middle of the record, computed using an implementation + ! of the rounded average that is valid over the full integer range + sdjf%nrecsec(1:sdjf%nreclast) = sdjf%nrecsec(0:sdjf%nreclast-1) / 2 + sdjf%nrecsec(1:sdjf%nreclast) / 2 + & + & MAX( MOD( sdjf%nrecsec(0:sdjf%nreclast-1), 2 ), MOD( sdjf%nrecsec(1:sdjf%nreclast), 2 ) ) + END IF + ! + sdjf%clname = fld_filename( sdjf, idy, imt, iyr ) + ! + END SUBROUTINE fld_def + + + SUBROUTINE fld_clopn( sdjf ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_clopn *** + !! + !! ** Purpose : close/open the files + !!---------------------------------------------------------------------- + TYPE(FLD) , INTENT(inout) :: sdjf ! input field related variables + ! + INTEGER :: isave + LOGICAL :: llprev, llnext, llstop + !!---------------------------------------------------------------------- + ! + llprev = sdjf%nrecsec(sdjf%nreclast) < nsec000_1jan000 ! file ends before the beginning of the job -> file may not exist + llnext = sdjf%nrecsec( 1 ) > nsecend_1jan000 ! file begins after the end of the job -> file may not exist + + llstop = sdjf%ln_clim .OR. .NOT. ( llprev .OR. llnext ) + + IF( sdjf%num <= 0 .OR. .NOT. sdjf%ln_clim ) THEN + IF( sdjf%num > 0 ) CALL iom_close( sdjf%num ) ! close file if already open + CALL iom_open( sdjf%clname, sdjf%num, ldstop = llstop, ldiof = LEN_TRIM(sdjf%wgtname) > 0 ) + ENDIF + ! + IF( sdjf%num <= 0 .AND. .NOT. llstop ) THEN ! file not found but we do accept this... + ! + IF( llprev ) THEN ! previous file does not exist : go back to current and accept to read only the first record + CALL ctl_warn('previous file: '//TRIM(sdjf%clname)//' not found -> go back to current year/month/week/day file') + isave = sdjf%nrecsec(sdjf%nreclast) ! save previous file info + CALL fld_def( sdjf ) ! go back to current file + sdjf%nreclast = 1 ! force to use only the first record (do as if other were not existing...) + ENDIF + ! + IF( llnext ) THEN ! next file does not exist : go back to current and accept to read only the last record + CALL ctl_warn('next file: '//TRIM(sdjf%clname)//' not found -> go back to current year/month/week/day file') + isave = sdjf%nrecsec(1) ! save next file info + CALL fld_def( sdjf ) ! go back to current file + ENDIF + ! -> read "last" record but keep record info from the first record of next file + sdjf%nrecsec( sdjf%nreclast ) = isave + sdjf%nrecsec(0:sdjf%nreclast-1) = nflag + ! + CALL iom_open( sdjf%clname, sdjf%num, ldiof = LEN_TRIM(sdjf%wgtname) > 0 ) + ! + ENDIF + ! + END SUBROUTINE fld_clopn + + + SUBROUTINE fld_fill( sdf, sdf_n, cdir, cdcaller, cdtitle, cdnam, knoprint ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_fill *** + !! + !! ** Purpose : fill the data structure (sdf) with the associated information + !! read in namelist (sdf_n) and control print + !!---------------------------------------------------------------------- + TYPE(FLD) , DIMENSION(:) , INTENT(inout) :: sdf ! structure of input fields (file informations, fields read) + TYPE(FLD_N), DIMENSION(:) , INTENT(in ) :: sdf_n ! array of namelist information structures + CHARACTER(len=*) , INTENT(in ) :: cdir ! Root directory for location of flx files + CHARACTER(len=*) , INTENT(in ) :: cdcaller ! name of the calling routine + CHARACTER(len=*) , INTENT(in ) :: cdtitle ! description of the calling routine + CHARACTER(len=*) , INTENT(in ) :: cdnam ! name of the namelist from which sdf_n comes + INTEGER , OPTIONAL, INTENT(in ) :: knoprint ! no calling routine information printed + ! + INTEGER :: jf ! dummy indices + !!--------------------------------------------------------------------- + ! + DO jf = 1, SIZE(sdf) + sdf(jf)%clrootname = sdf_n(jf)%clname + IF( TRIM(sdf_n(jf)%clname) /= 'NOT USED' ) sdf(jf)%clrootname = TRIM( cdir )//sdf(jf)%clrootname + sdf(jf)%clname = "not yet defined" + sdf(jf)%freqh = sdf_n(jf)%freqh + sdf(jf)%clvar = sdf_n(jf)%clvar + sdf(jf)%ln_tint = sdf_n(jf)%ln_tint + sdf(jf)%ln_clim = sdf_n(jf)%ln_clim + sdf(jf)%clftyp = sdf_n(jf)%clftyp + sdf(jf)%cltype = 'T' ! by default don't do any call to lbc_lnk in iom_get + sdf(jf)%zsgn = 1. ! by default don't do change signe across the north fold + sdf(jf)%num = -1 + sdf(jf)%nbb = 1 ! start with before data in 1 + sdf(jf)%naa = 2 ! start with after data in 2 + sdf(jf)%wgtname = " " + IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 ) sdf(jf)%wgtname = TRIM( cdir )//sdf_n(jf)%wname + sdf(jf)%lsmname = " " + IF( LEN( TRIM(sdf_n(jf)%lname) ) > 0 ) sdf(jf)%lsmname = TRIM( cdir )//sdf_n(jf)%lname + sdf(jf)%vcomp = sdf_n(jf)%vcomp + sdf(jf)%rotn(:) = .TRUE. ! pretend to be rotated -> won't try to rotate data before the first call to fld_get + IF( sdf(jf)%clftyp(1:4) == 'week' .AND. nn_leapy == 0 ) & + & CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs nn_leapy = 1') + IF( sdf(jf)%clftyp(1:4) == 'week' .AND. sdf(jf)%ln_clim ) & + & CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs ln_clim = .FALSE.') + sdf(jf)%nreclast = -1 ! Set to non zero default value to avoid errors, is updated to meaningful value during fld_clopn + sdf(jf)%igrd = 0 + sdf(jf)%ibdy = 0 + sdf(jf)%imap => NULL() + sdf(jf)%ltotvel = .FALSE. + sdf(jf)%lzint = .FALSE. + END DO + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + IF( .NOT.PRESENT( knoprint) ) THEN + WRITE(numout,*) TRIM( cdcaller )//' : '//TRIM( cdtitle ) + WRITE(numout,*) (/ ('~', jf = 1, LEN_TRIM( cdcaller ) ) /) + ENDIF + WRITE(numout,*) ' fld_fill : fill data structure with information from namelist '//TRIM( cdnam ) + WRITE(numout,*) ' ~~~~~~~~' + WRITE(numout,*) ' list of files and frequency (>0: in hours ; <0 in months)' + DO jf = 1, SIZE(sdf) + WRITE(numout,*) ' root filename: ' , TRIM( sdf(jf)%clrootname ), ' variable name: ', TRIM( sdf(jf)%clvar ) + WRITE(numout,*) ' frequency: ' , sdf(jf)%freqh , & + & ' time interp: ' , sdf(jf)%ln_tint , & + & ' climatology: ' , sdf(jf)%ln_clim + WRITE(numout,*) ' weights: ' , TRIM( sdf(jf)%wgtname ), & + & ' pairing: ' , TRIM( sdf(jf)%vcomp ), & + & ' data type: ' , sdf(jf)%clftyp , & + & ' land/sea mask:' , TRIM( sdf(jf)%lsmname ) + call flush(numout) + END DO + ENDIF + ! + END SUBROUTINE fld_fill + + + SUBROUTINE wgt_list( sd, kwgt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE wgt_list *** + !! + !! ** Purpose : search array of WGTs and find a weights file entry, + !! or return a new one adding it to the end if new entry. + !! the weights data is read in and restructured (fld_weight) + !!---------------------------------------------------------------------- + TYPE( FLD ), INTENT(in ) :: sd ! field with name of weights file + INTEGER , INTENT( out) :: kwgt ! index of weights + ! + INTEGER :: kw, nestid ! local integer + !!---------------------------------------------------------------------- + ! + !! search down linked list + !! weights filename is either present or we hit the end of the list + ! + !! because agrif nest part of filenames are now added in iom_open + !! to distinguish between weights files on the different grids, need to track + !! nest number explicitly + nestid = 0 +#if defined key_agrif + nestid = Agrif_Fixed() +#endif + DO kw = 1, nxt_wgt-1 + IF( ref_wgts(kw)%wgtname == sd%wgtname .AND. & + ref_wgts(kw)%nestid == nestid) THEN + kwgt = kw + RETURN + ENDIF + END DO + kwgt = nxt_wgt + CALL fld_weight( sd ) + ! + END SUBROUTINE wgt_list + + + SUBROUTINE wgt_print( ) + !!--------------------------------------------------------------------- + !! *** ROUTINE wgt_print *** + !! + !! ** Purpose : print the list of known weights + !!---------------------------------------------------------------------- + INTEGER :: kw ! + !!---------------------------------------------------------------------- + ! + DO kw = 1, nxt_wgt-1 + WRITE(numout,*) 'weight file: ',TRIM(ref_wgts(kw)%wgtname) + WRITE(numout,*) ' ddims: ',ref_wgts(kw)%ddims(1),ref_wgts(kw)%ddims(2) + WRITE(numout,*) ' numwgt: ',ref_wgts(kw)%numwgt + WRITE(numout,*) ' jpiwgt: ',ref_wgts(kw)%jpiwgt + WRITE(numout,*) ' jpjwgt: ',ref_wgts(kw)%jpjwgt + WRITE(numout,*) ' botleft: ',ref_wgts(kw)%botleft + WRITE(numout,*) ' topright: ',ref_wgts(kw)%topright + IF( ref_wgts(kw)%cyclic ) THEN + WRITE(numout,*) ' cyclical' + IF( ref_wgts(kw)%overlap > 0 ) WRITE(numout,*) ' with overlap of ', ref_wgts(kw)%overlap + ELSE + WRITE(numout,*) ' not cyclical' + ENDIF + IF( ASSOCIATED(ref_wgts(kw)%data_wgt) ) WRITE(numout,*) ' allocated' + END DO + ! + END SUBROUTINE wgt_print + + + SUBROUTINE fld_weight( sd ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_weight *** + !! + !! ** Purpose : create a new WGT structure and fill in data from file, + !! restructuring as required + !!---------------------------------------------------------------------- + TYPE( FLD ), INTENT(in) :: sd ! field with name of weights file + !! + INTEGER :: ji,jj,jn ! dummy loop indices + INTEGER :: inum ! local logical unit + INTEGER :: id ! local variable id + INTEGER :: ipk ! local vertical dimension + INTEGER :: zwrap ! local integer + LOGICAL :: cyclical ! + CHARACTER (len=5) :: clname ! + INTEGER , DIMENSION(4) :: ddims + INTEGER :: isrc + REAL(dp), DIMENSION(jpi,jpj) :: data_tmp + !!---------------------------------------------------------------------- + ! + IF( nxt_wgt > tot_wgts ) THEN + CALL ctl_stop("fld_weight: weights array size exceeded, increase tot_wgts") + ENDIF + ! + !! new weights file entry, add in extra information + !! a weights file represents a 2D grid of a certain shape, so we assume that the current + !! input data file is representative of all other files to be opened and processed with the + !! current weights file + + !! get data grid dimensions + id = iom_varid( sd%num, sd%clvar, ddims ) + + !! now open the weights file + CALL iom_open ( sd%wgtname, inum ) ! interpolation weights + IF( inum > 0 ) THEN + + !! determine whether we have an east-west cyclic grid + !! from global attribute called "ew_wrap" in the weights file + !! note that if not found, iom_getatt returns -999 and cyclic with no overlap is assumed + !! since this is the most common forcing configuration + + CALL iom_getatt(inum, 'ew_wrap', zwrap) + IF( zwrap >= 0 ) THEN + cyclical = .TRUE. + ELSE IF( zwrap == -999 ) THEN + cyclical = .TRUE. + zwrap = 0 + ELSE + cyclical = .FALSE. + ENDIF + + ref_wgts(nxt_wgt)%ddims(1) = ddims(1) + ref_wgts(nxt_wgt)%ddims(2) = ddims(2) + ref_wgts(nxt_wgt)%wgtname = sd%wgtname + ref_wgts(nxt_wgt)%overlap = zwrap + ref_wgts(nxt_wgt)%cyclic = cyclical + ref_wgts(nxt_wgt)%nestid = 0 +#if defined key_agrif + ref_wgts(nxt_wgt)%nestid = Agrif_Fixed() +#endif + !! weights file is stored as a set of weights (wgt01->wgt04 or wgt01->wgt16) + !! for each weight wgtNN there is an integer array srcNN which gives the point in + !! the input data grid which is to be multiplied by the weight + !! they are both arrays on the model grid so the result of the multiplication is + !! added into an output array on the model grid as a running sum + + !! two possible cases: bilinear (4 weights) or bicubic (16 weights) + id = iom_varid(inum, 'src05', ldstop=.FALSE.) + IF( id <= 0 ) THEN ; ref_wgts(nxt_wgt)%numwgt = 4 + ELSE ; ref_wgts(nxt_wgt)%numwgt = 16 + ENDIF + + ALLOCATE( ref_wgts(nxt_wgt)%data_jpi(Nis0:Nie0,Njs0:Nje0,4) ) + ALLOCATE( ref_wgts(nxt_wgt)%data_jpj(Nis0:Nie0,Njs0:Nje0,4) ) + ALLOCATE( ref_wgts(nxt_wgt)%data_wgt(Nis0:Nie0,Njs0:Nje0,ref_wgts(nxt_wgt)%numwgt) ) + + DO jn = 1,4 + WRITE(clname,'(a3,i2.2)') 'src',jn + CALL iom_get ( inum, jpdom_global, clname, data_tmp(:,:), cd_type = 'Z' ) ! no call to lbc_lnk + DO_2D( 0, 0, 0, 0 ) + isrc = NINT(data_tmp(ji,jj)) - 1 + ref_wgts(nxt_wgt)%data_jpi(ji,jj,jn) = 1 + MOD(isrc, ref_wgts(nxt_wgt)%ddims(1)) + ref_wgts(nxt_wgt)%data_jpj(ji,jj,jn) = 1 + isrc / ref_wgts(nxt_wgt)%ddims(1) + END_2D + END DO + + DO jn = 1, ref_wgts(nxt_wgt)%numwgt + WRITE(clname,'(a3,i2.2)') 'wgt',jn + CALL iom_get ( inum, jpdom_global, clname, data_tmp(:,:), cd_type = 'Z' ) ! no call to lbc_lnk + DO_2D( 0, 0, 0, 0 ) + ref_wgts(nxt_wgt)%data_wgt(ji,jj,jn) = data_tmp(ji,jj) + END_2D + END DO + CALL iom_close (inum) + + ! find min and max indices in grid + ref_wgts(nxt_wgt)%botleft( 1) = MINVAL(ref_wgts(nxt_wgt)%data_jpi(:,:,:)) + ref_wgts(nxt_wgt)%botleft( 2) = MINVAL(ref_wgts(nxt_wgt)%data_jpj(:,:,:)) + ref_wgts(nxt_wgt)%topright(1) = MAXVAL(ref_wgts(nxt_wgt)%data_jpi(:,:,:)) + ref_wgts(nxt_wgt)%topright(2) = MAXVAL(ref_wgts(nxt_wgt)%data_jpj(:,:,:)) + + ! and therefore dimensions of the input box + ref_wgts(nxt_wgt)%jpiwgt = ref_wgts(nxt_wgt)%topright(1) - ref_wgts(nxt_wgt)%botleft(1) + 1 + ref_wgts(nxt_wgt)%jpjwgt = ref_wgts(nxt_wgt)%topright(2) - ref_wgts(nxt_wgt)%botleft(2) + 1 + + ! shift indexing of source grid + ref_wgts(nxt_wgt)%data_jpi(:,:,:) = ref_wgts(nxt_wgt)%data_jpi(:,:,:) - ref_wgts(nxt_wgt)%botleft(1) + 1 + ref_wgts(nxt_wgt)%data_jpj(:,:,:) = ref_wgts(nxt_wgt)%data_jpj(:,:,:) - ref_wgts(nxt_wgt)%botleft(2) + 1 + + ! create input grid, give it a halo to allow gradient calculations + ! SA: +3 stencil is a patch to avoid out-of-bound computation in some configuration. + ! a more robust solution will be given in next release + ipk = SIZE(sd%fnow, 3) + ALLOCATE( ref_wgts(nxt_wgt)%fly_dta(ref_wgts(nxt_wgt)%jpiwgt+3, ref_wgts(nxt_wgt)%jpjwgt+3 ,ipk) ) + IF( ref_wgts(nxt_wgt)%cyclic ) ALLOCATE( ref_wgts(nxt_wgt)%col(1,ref_wgts(nxt_wgt)%jpjwgt+3,ipk) ) + ! + nxt_wgt = nxt_wgt + 1 + ! + ELSE + CALL ctl_stop( ' fld_weight : unable to read the file ' ) + ENDIF + ! + END SUBROUTINE fld_weight + + + SUBROUTINE apply_seaoverland( clmaskfile, zfieldo, jpi1_lsm, jpi2_lsm, jpj1_lsm, & + & jpj2_lsm, itmpi, itmpj, itmpz, rec1_lsm, recn_lsm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE apply_seaoverland *** + !! + !! ** Purpose : avoid spurious fluxes in coastal or near-coastal areas + !! due to the wrong usage of "land" values from the coarse + !! atmospheric model when spatial interpolation is required + !! D. Delrosso INGV + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: itmpi,itmpj,itmpz ! lengths + INTEGER, INTENT(in ) :: jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm ! temporary indices + INTEGER, DIMENSION(3), INTENT(in ) :: rec1_lsm,recn_lsm ! temporary arrays for start and length + REAL(wp),DIMENSION (:,:,:),INTENT(inout) :: zfieldo ! input/output array for seaoverland application + CHARACTER (len=100), INTENT(in ) :: clmaskfile ! land/sea mask file name + ! + INTEGER :: inum,jni,jnj,jnz,jc ! local indices + REAL(wp),DIMENSION (:,:,:),ALLOCATABLE :: zslmec1 ! local array for land point detection + REAL(wp),DIMENSION (:,:), ALLOCATABLE :: zfieldn ! array of forcing field with undeff for land points + REAL(wp),DIMENSION (:,:), ALLOCATABLE :: zfield ! array of forcing field + !!--------------------------------------------------------------------- + ! + ALLOCATE ( zslmec1(itmpi,itmpj,itmpz), zfieldn(itmpi,itmpj), zfield(itmpi,itmpj) ) + ! + ! Retrieve the land sea mask data + CALL iom_open( clmaskfile, inum ) + SELECT CASE( SIZE(zfieldo(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),3) ) + CASE(1) + CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1), & + & 1, kstart = rec1_lsm, kcount = recn_lsm) + CASE DEFAULT + CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), & + & 1, kstart = rec1_lsm, kcount = recn_lsm) + END SELECT + CALL iom_close( inum ) + ! + DO jnz=1,rec1_lsm(3) !! Loop over k dimension + ! + DO jni = 1, itmpi !! copy the original field into a tmp array + DO jnj = 1, itmpj !! substituting undeff over land points + zfieldn(jni,jnj) = zfieldo(jni,jnj,jnz) + IF( zslmec1(jni,jnj,jnz) == 1. ) zfieldn(jni,jnj) = undeff_lsm + END DO + END DO + ! + CALL seaoverland( zfieldn, itmpi, itmpj, zfield ) + DO jc = 1, nn_lsm + CALL seaoverland( zfield, itmpi, itmpj, zfield ) + END DO + ! + ! Check for Undeff and substitute original values + IF( ANY(zfield==undeff_lsm) ) THEN + DO jni = 1, itmpi + DO jnj = 1, itmpj + IF( zfield(jni,jnj)==undeff_lsm ) zfield(jni,jnj) = zfieldo(jni,jnj,jnz) + END DO + END DO + ENDIF + ! + zfieldo(:,:,jnz) = zfield(:,:) + ! + END DO !! End Loop over k dimension + ! + DEALLOCATE ( zslmec1, zfieldn, zfield ) + ! + END SUBROUTINE apply_seaoverland + + + SUBROUTINE seaoverland( zfieldn, ileni, ilenj, zfield ) + !!--------------------------------------------------------------------- + !! *** ROUTINE seaoverland *** + !! + !! ** Purpose : create shifted matrices for seaoverland application + !! D. Delrosso INGV + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ileni,ilenj ! lengths + REAL(wp), DIMENSION (ileni,ilenj), INTENT(in ) :: zfieldn ! array of forcing field with undeff for land points + REAL(wp), DIMENSION (ileni,ilenj), INTENT( out) :: zfield ! array of forcing field + ! + REAL(wp) , DIMENSION (ileni,ilenj) :: zmat1, zmat2, zmat3, zmat4 ! local arrays + REAL(wp) , DIMENSION (ileni,ilenj) :: zmat5, zmat6, zmat7, zmat8 ! - - + REAL(wp) , DIMENSION (ileni,ilenj) :: zlsm2d ! - - + REAL(wp) , DIMENSION (ileni,ilenj,8) :: zlsm3d ! - - + LOGICAL , DIMENSION (ileni,ilenj,8) :: ll_msknan3d ! logical mask for undeff detection + LOGICAL , DIMENSION (ileni,ilenj) :: ll_msknan2d ! logical mask for undeff detection + !!---------------------------------------------------------------------- + zmat8 = eoshift( zfieldn , SHIFT=-1 , BOUNDARY = (/zfieldn(:,1)/) , DIM=2 ) + zmat1 = eoshift( zmat8 , SHIFT=-1 , BOUNDARY = (/zmat8(1,:)/) , DIM=1 ) + zmat2 = eoshift( zfieldn , SHIFT=-1 , BOUNDARY = (/zfieldn(1,:)/) , DIM=1 ) + zmat4 = eoshift( zfieldn , SHIFT= 1 , BOUNDARY = (/zfieldn(:,ilenj)/) , DIM=2 ) + zmat3 = eoshift( zmat4 , SHIFT=-1 , BOUNDARY = (/zmat4(1,:)/) , DIM=1 ) + zmat5 = eoshift( zmat4 , SHIFT= 1 , BOUNDARY = (/zmat4(ileni,:)/) , DIM=1 ) + zmat6 = eoshift( zfieldn , SHIFT= 1 , BOUNDARY = (/zfieldn(ileni,:)/) , DIM=1 ) + zmat7 = eoshift( zmat8 , SHIFT= 1 , BOUNDARY = (/zmat8(ileni,:)/) , DIM=1 ) + ! + zlsm3d = RESHAPE( (/ zmat1, zmat2, zmat3, zmat4, zmat5, zmat6, zmat7, zmat8 /), (/ ileni, ilenj, 8 /)) + ll_msknan3d = .NOT.( zlsm3d == undeff_lsm ) + ll_msknan2d = .NOT.( zfieldn == undeff_lsm ) ! FALSE where is Undeff (land) + zlsm2d = SUM( zlsm3d, 3 , ll_msknan3d ) / MAX( 1 , COUNT( ll_msknan3d , 3 ) ) + WHERE( COUNT( ll_msknan3d , 3 ) == 0._wp ) zlsm2d = undeff_lsm + zfield = MERGE( zfieldn, zlsm2d, ll_msknan2d ) + ! + END SUBROUTINE seaoverland + + + SUBROUTINE fld_interp( num, clvar, kw, kk, dta, nrec, lsmfile) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_interp *** + !! + !! ** Purpose : apply weights to input gridded data to create data + !! on model grid + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: num ! stream number + CHARACTER(LEN=*) , INTENT(in ) :: clvar ! variable name + INTEGER , INTENT(in ) :: kw ! weights number + INTEGER , INTENT(in ) :: kk ! vertical dimension of kk + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: dta ! output field on model grid + INTEGER , INTENT(in ) :: nrec ! record number to read (ie time slice) + CHARACTER(LEN=*) , INTENT(in ) :: lsmfile ! land sea mask file name + ! + INTEGER, DIMENSION(3) :: rec1, recn ! temporary arrays for start and length + INTEGER, DIMENSION(3) :: rec1_lsm, recn_lsm ! temporary arrays for start and length in case of seaoverland + INTEGER :: ii_lsm1,ii_lsm2,ij_lsm1,ij_lsm2 ! temporary indices + INTEGER :: ji, jj, jk, jn, jir, jjr ! loop counters + INTEGER :: ipk + INTEGER :: ni, nj ! lengths + INTEGER :: jpimin,jpiwid ! temporary indices + INTEGER :: jpimin_lsm,jpiwid_lsm ! temporary indices + INTEGER :: jpjmin,jpjwid ! temporary indices + INTEGER :: jpjmin_lsm,jpjwid_lsm ! temporary indices + INTEGER :: jpi1,jpi2,jpj1,jpj2 ! temporary indices + INTEGER :: jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm ! temporary indices + INTEGER :: itmpi,itmpj,itmpz ! lengths + REAL(wp),DIMENSION(:,:,:), ALLOCATABLE :: ztmp_fly_dta ! local array of values on input grid + !!---------------------------------------------------------------------- + ipk = SIZE(dta, 3) + ! + !! for weighted interpolation we have weights at four corners of a box surrounding + !! a model grid point, each weight is multiplied by a grid value (bilinear case) + !! or by a grid value and gradients at the corner point (bicubic case) + !! so we need to have a 4 by 4 subgrid surrounding each model point to cover both cases + + !! sub grid from non-model input grid which encloses all grid points in this nemo process + jpimin = ref_wgts(kw)%botleft(1) + jpjmin = ref_wgts(kw)%botleft(2) + jpiwid = ref_wgts(kw)%jpiwgt + jpjwid = ref_wgts(kw)%jpjwgt + + !! when reading in, expand this sub-grid by one halo point all the way round for calculating gradients + rec1(1) = MAX( jpimin-1, 1 ) + rec1(2) = MAX( jpjmin-1, 1 ) + rec1(3) = 1 + recn(1) = MIN( jpiwid+2, ref_wgts(kw)%ddims(1)-rec1(1)+1 ) + recn(2) = MIN( jpjwid+2, ref_wgts(kw)%ddims(2)-rec1(2)+1 ) + recn(3) = kk + + !! where we need to put it in the non-nemo grid fly_dta + !! note that jpi1 and jpj1 only differ from 1 when jpimin and jpjmin are 1 + !! (ie at the extreme west or south of the whole input grid) and similarly for jpi2 and jpj2 + jpi1 = 2 + rec1(1) - jpimin + jpj1 = 2 + rec1(2) - jpjmin + jpi2 = jpi1 + recn(1) - 1 + jpj2 = jpj1 + recn(2) - 1 + + + IF( LEN_TRIM(lsmfile) > 0 ) THEN + !! indeces for ztmp_fly_dta + ! -------------------------- + rec1_lsm(1)=MAX(rec1(1)-nn_lsm,1) ! starting index for enlarged external data, x direction + rec1_lsm(2)=MAX(rec1(2)-nn_lsm,1) ! starting index for enlarged external data, y direction + rec1_lsm(3) = 1 ! vertical dimension + recn_lsm(1)=MIN(rec1(1)-rec1_lsm(1)+recn(1)+nn_lsm,ref_wgts(kw)%ddims(1)-rec1_lsm(1)) ! n points in x direction + recn_lsm(2)=MIN(rec1(2)-rec1_lsm(2)+recn(2)+nn_lsm,ref_wgts(kw)%ddims(2)-rec1_lsm(2)) ! n points in y direction + recn_lsm(3) = kk ! number of vertical levels in the input file + + ! Avoid out of bound + jpimin_lsm = MAX( rec1_lsm(1)+1, 1 ) + jpjmin_lsm = MAX( rec1_lsm(2)+1, 1 ) + jpiwid_lsm = MIN( recn_lsm(1)-2,ref_wgts(kw)%ddims(1)-rec1(1)+1) + jpjwid_lsm = MIN( recn_lsm(2)-2,ref_wgts(kw)%ddims(2)-rec1(2)+1) + + jpi1_lsm = 2+rec1_lsm(1)-jpimin_lsm + jpj1_lsm = 2+rec1_lsm(2)-jpjmin_lsm + jpi2_lsm = jpi1_lsm + recn_lsm(1) - 1 + jpj2_lsm = jpj1_lsm + recn_lsm(2) - 1 + + + itmpi=jpi2_lsm-jpi1_lsm+1 + itmpj=jpj2_lsm-jpj1_lsm+1 + itmpz=kk + ALLOCATE(ztmp_fly_dta(itmpi,itmpj,itmpz)) + ztmp_fly_dta(:,:,:) = 0.0 + SELECT CASE( SIZE(ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),3) ) + CASE(1) + CALL iom_get( num, jpdom_unknown, clvar, ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,1), & + & nrec, kstart = rec1_lsm, kcount = recn_lsm) + CASE DEFAULT + CALL iom_get( num, jpdom_unknown, clvar, ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), & + & nrec, kstart = rec1_lsm, kcount = recn_lsm) + END SELECT + CALL apply_seaoverland(lsmfile,ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), & + & jpi1_lsm,jpi2_lsm,jpj1_lsm,jpj2_lsm, & + & itmpi,itmpj,itmpz,rec1_lsm,recn_lsm) + + + ! Relative indeces for remapping + ii_lsm1 = (rec1(1)-rec1_lsm(1))+1 + ii_lsm2 = (ii_lsm1+recn(1))-1 + ij_lsm1 = (rec1(2)-rec1_lsm(2))+1 + ij_lsm2 = (ij_lsm1+recn(2))-1 + + ref_wgts(kw)%fly_dta(:,:,:) = 0.0 + ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:) = ztmp_fly_dta(ii_lsm1:ii_lsm2,ij_lsm1:ij_lsm2,:) + DEALLOCATE(ztmp_fly_dta) + + ELSE + + ref_wgts(kw)%fly_dta(:,:,:) = 0.0 + CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:), nrec, kstart = rec1, kcount = recn) + ENDIF + + + !! first four weights common to both bilinear and bicubic + !! data_jpi, data_jpj have already been shifted to (1,1) corresponding to botleft + !! note that we have to offset by 1 into fly_dta array because of halo added to fly_dta (rec1 definition) + dta(:,:,:) = 0._wp + DO jn = 1,4 + DO_3D( 0, 0, 0, 0, 1,ipk ) + ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + 1 + nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + 1 + dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn) * ref_wgts(kw)%fly_dta(ni,nj,jk) + END_3D + END DO + + IF(ref_wgts(kw)%numwgt .EQ. 16) THEN + + !! fix up halo points that we couldnt read from file + IF( jpi1 == 2 ) THEN + ref_wgts(kw)%fly_dta(jpi1-1,:,:) = ref_wgts(kw)%fly_dta(jpi1,:,:) + ENDIF + IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN + ref_wgts(kw)%fly_dta(jpi2+1,:,:) = ref_wgts(kw)%fly_dta(jpi2,:,:) + ENDIF + IF( jpj1 == 2 ) THEN + ref_wgts(kw)%fly_dta(:,jpj1-1,:) = ref_wgts(kw)%fly_dta(:,jpj1,:) + ENDIF + IF( jpj2 + jpjmin - 1 == ref_wgts(kw)%ddims(2)+1 .AND. jpj2 .LT. jpjwid+2 ) THEN + ref_wgts(kw)%fly_dta(:,jpj2+1,:) = 2.0*ref_wgts(kw)%fly_dta(:,jpj2,:) - ref_wgts(kw)%fly_dta(:,jpj2-1,:) + ENDIF + + !! if data grid is cyclic we can do better on east-west edges + !! but have to allow for whether first and last columns are coincident + IF( ref_wgts(kw)%cyclic ) THEN + rec1(2) = MAX( jpjmin-1, 1 ) + recn(1) = 1 + recn(2) = MIN( jpjwid+2, ref_wgts(kw)%ddims(2)-rec1(2)+1 ) + jpj1 = 2 + rec1(2) - jpjmin + jpj2 = jpj1 + recn(2) - 1 + IF( jpi1 == 2 ) THEN + rec1(1) = ref_wgts(kw)%ddims(1) - ref_wgts(kw)%overlap + CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, kstart = rec1, kcount = recn) + ref_wgts(kw)%fly_dta(jpi1-1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:) + ENDIF + IF( jpi2 + jpimin - 1 == ref_wgts(kw)%ddims(1)+1 ) THEN + rec1(1) = 1 + ref_wgts(kw)%overlap + CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, kstart = rec1, kcount = recn) + ref_wgts(kw)%fly_dta(jpi2+1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:) + ENDIF + ENDIF + ! +!!$ DO jn = 1,4 +!!$ DO_3D( 0, 0, 0, 0, 1,ipk ) +!!$ ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + 1 +!!$ nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + 1 +!!$ dta(ji,jj,jk) = dta(ji,jj,jk) & +!!$ ! gradient in the i direction +!!$ & + ref_wgts(kw)%data_wgt(ji,jj,jn+4) * 0.5_wp * & +!!$ & (ref_wgts(kw)%fly_dta(ni+1,nj ,jk) - ref_wgts(kw)%fly_dta(ni-1,nj ,jk)) & +!!$ ! gradient in the j direction +!!$ & + ref_wgts(kw)%data_wgt(ji,jj,jn+8) * 0.5_wp * & +!!$ & (ref_wgts(kw)%fly_dta(ni ,nj+1,jk) - ref_wgts(kw)%fly_dta(ni ,nj-1,jk)) & +!!$ ! gradient in the ij direction +!!$ & + ref_wgts(kw)%data_wgt(ji,jj,jn+12) * 0.25_wp * & +!!$ & ((ref_wgts(kw)%fly_dta(ni+1,nj+1,jk) - ref_wgts(kw)%fly_dta(ni-1,nj+1,jk)) - & +!!$ & (ref_wgts(kw)%fly_dta(ni+1,nj-1,jk) - ref_wgts(kw)%fly_dta(ni-1,nj-1,jk))) +!!$ END_3D +!!$ END DO + ! + DO jn = 1,4 + DO_3D( 0, 0, 0, 0, 1,ipk ) + ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + ! gradient in the i direction + dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+4) * 0.5_wp * & + & (ref_wgts(kw)%fly_dta(ni+2,nj+1,jk) - ref_wgts(kw)%fly_dta(ni ,nj+1,jk)) + END_3D + END DO + DO jn = 1,4 + DO_3D( 0, 0, 0, 0, 1,ipk ) + ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + ! gradient in the j direction + dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+8) * 0.5_wp * & + & (ref_wgts(kw)%fly_dta(ni+1,nj+2,jk) - ref_wgts(kw)%fly_dta(ni+1,nj ,jk)) + END_3D + END DO + DO jn = 1,4 + DO_3D( 0, 0, 0, 0, 1,ipk ) + ni = ref_wgts(kw)%data_jpi(ji,jj,jn) + nj = ref_wgts(kw)%data_jpj(ji,jj,jn) + ! gradient in the ij direction + dta(ji,jj,jk) = dta(ji,jj,jk) + ref_wgts(kw)%data_wgt(ji,jj,jn+12) * 0.25_wp * ( & + & (ref_wgts(kw)%fly_dta(ni+2,nj+2,jk) - ref_wgts(kw)%fly_dta(ni ,nj+2,jk)) - & + & (ref_wgts(kw)%fly_dta(ni+2,nj ,jk) - ref_wgts(kw)%fly_dta(ni ,nj ,jk))) + END_3D + END DO + ! + ENDIF + ! + END SUBROUTINE fld_interp + + + FUNCTION fld_filename( sdjf, kday, kmonth, kyear ) + !!--------------------------------------------------------------------- + !! *** FUNCTION fld_filename *** + !! + !! ** Purpose : define the filename according to a given date + !!--------------------------------------------------------------------- + TYPE(FLD), INTENT(in) :: sdjf ! input field related variables + INTEGER , INTENT(in) :: kday, kmonth, kyear + ! + CHARACTER(len = 256) :: clname, fld_filename + !!--------------------------------------------------------------------- + + + ! build the new filename if not climatological data + clname=TRIM(sdjf%clrootname) + ! + ! note that sdjf%ln_clim is is only acting on the presence of the year in the file name + IF( .NOT. sdjf%ln_clim ) THEN + WRITE(clname, '(a,"_y",i4.4)' ) TRIM( sdjf%clrootname ), kyear ! add year + IF( sdjf%clftyp /= 'yearly' ) WRITE(clname, '(a, "m",i2.2)' ) TRIM( clname ), kmonth ! add month + ELSE + ! build the new filename if climatological data + IF( sdjf%clftyp /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( sdjf%clrootname ), kmonth ! add month + ENDIF + IF( sdjf%clftyp == 'daily' .OR. sdjf%clftyp(1:4) == 'week' ) & + & WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname ), kday ! add day + + fld_filename = clname + + END FUNCTION fld_filename + + + FUNCTION ksec_week( cdday ) + !!--------------------------------------------------------------------- + !! *** FUNCTION ksec_week *** + !! + !! ** Purpose : seconds between 00h of the beginning of the week and half of the current time step + !!--------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdday ! first 3 letters of the first day of the weekly file + !! + INTEGER :: ksec_week ! output variable + INTEGER :: ijul, ishift ! local integer + CHARACTER(len=3),DIMENSION(7) :: cl_week + !!---------------------------------------------------------------------- + cl_week = (/"sun","sat","fri","thu","wed","tue","mon"/) + DO ijul = 1, 7 + IF( cl_week(ijul) == TRIM(cdday) ) EXIT + END DO + IF( ijul .GT. 7 ) CALL ctl_stop( 'ksec_week: wrong day for sdjf%clftyp(6:8): '//TRIM(cdday) ) + ! + ishift = ijul * NINT(rday) + ! + ksec_week = nsec_monday + ishift + ksec_week = MOD( ksec_week, 7*NINT(rday) ) + ! + END FUNCTION ksec_week + + !!====================================================================== +END MODULE fldread diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/geo2ocean.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/geo2ocean.F90 new file mode 100644 index 0000000..83d25ae --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/geo2ocean.F90 @@ -0,0 +1,463 @@ +MODULE geo2ocean + !!====================================================================== + !! *** MODULE geo2ocean *** + !! Ocean mesh : ??? + !!====================================================================== + !! History : OPA ! 07-1996 (O. Marti) Original code + !! NEMO 1.0 ! 06-2006 (G. Madec ) Free form, F90 + opt. + !! ! 04-2007 (S. Masson) angle: Add T, F points and bugfix in cos lateral boundary + !! 3.0 ! 07-2008 (G. Madec) geo2oce suppress lon/lat agruments + !! 3.7 ! 11-2015 (G. Madec) remove the unused repere and repcmo routines + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! rot_rep : Rotate the Repere: geographic grid <==> stretched coordinates grid + !! angle : + !! geo2oce : + !! oce2geo : + !!---------------------------------------------------------------------- + USE dom_oce ! mesh and scale factors + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC rot_rep ! called in sbccpl, fldread, and cyclone + PUBLIC geo2oce ! called in sbccpl + PUBLIC oce2geo ! called in sbccpl + PUBLIC obs_rot ! called in obs_rot_vel and obs_write + + ! ! cos/sin between model grid lines and NP direction + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsint, gcost ! at T point + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinu, gcosu ! at U point + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinv, gcosv ! at V point + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: gsinf, gcosf ! at F point + + LOGICAL , SAVE, DIMENSION(4) :: linit = .FALSE. + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gsinlon, gcoslon, gsinlat, gcoslat + + LOGICAL :: lmust_init = .TRUE. !: used to initialize the cos/sin variables (see above) + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: geo2ocean.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE rot_rep ( pxin, pyin, cd_type, cdtodo, prot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE rot_rep *** + !! + !! ** Purpose : Rotate the Repere: Change vector componantes between + !! geographic grid <--> stretched coordinates grid. + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pxin, pyin ! vector componantes + CHARACTER(len=1), INTENT(in ) :: cd_type ! define the nature of pt2d array grid-points + CHARACTER(len=5), INTENT(in ) :: cdtodo ! type of transpormation: + ! ! 'en->i' = east-north to i-component + ! ! 'en->j' = east-north to j-component + ! ! 'ij->e' = (i,j) components to east + ! ! 'ij->n' = (i,j) components to north + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: prot + !!---------------------------------------------------------------------- + ! + IF( lmust_init ) THEN ! at 1st call only: set gsin. & gcos. + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' rot_rep: coordinate transformation : geographic <==> model (i,j)-components' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~ ' + ! + CALL angle( glamt, gphit, glamu, gphiu, glamv, gphiv, glamf, gphif ) ! initialization of the transformation + lmust_init = .FALSE. + ENDIF + ! + SELECT CASE( cdtodo ) ! type of rotation + ! + CASE( 'en->i' ) ! east-north to i-component + SELECT CASE (cd_type) + CASE ('T') ; prot(:,:) = pxin(:,:) * gcost(:,:) + pyin(:,:) * gsint(:,:) + CASE ('U') ; prot(:,:) = pxin(:,:) * gcosu(:,:) + pyin(:,:) * gsinu(:,:) + CASE ('V') ; prot(:,:) = pxin(:,:) * gcosv(:,:) + pyin(:,:) * gsinv(:,:) + CASE ('F') ; prot(:,:) = pxin(:,:) * gcosf(:,:) + pyin(:,:) * gsinf(:,:) + CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) + END SELECT + CASE ('en->j') ! east-north to j-component + SELECT CASE (cd_type) + CASE ('T') ; prot(:,:) = pyin(:,:) * gcost(:,:) - pxin(:,:) * gsint(:,:) + CASE ('U') ; prot(:,:) = pyin(:,:) * gcosu(:,:) - pxin(:,:) * gsinu(:,:) + CASE ('V') ; prot(:,:) = pyin(:,:) * gcosv(:,:) - pxin(:,:) * gsinv(:,:) + CASE ('F') ; prot(:,:) = pyin(:,:) * gcosf(:,:) - pxin(:,:) * gsinf(:,:) + CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) + END SELECT + CASE ('ij->e') ! (i,j)-components to east + SELECT CASE (cd_type) + CASE ('T') ; prot(:,:) = pxin(:,:) * gcost(:,:) - pyin(:,:) * gsint(:,:) + CASE ('U') ; prot(:,:) = pxin(:,:) * gcosu(:,:) - pyin(:,:) * gsinu(:,:) + CASE ('V') ; prot(:,:) = pxin(:,:) * gcosv(:,:) - pyin(:,:) * gsinv(:,:) + CASE ('F') ; prot(:,:) = pxin(:,:) * gcosf(:,:) - pyin(:,:) * gsinf(:,:) + CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) + END SELECT + CASE ('ij->n') ! (i,j)-components to north + SELECT CASE (cd_type) + CASE ('T') ; prot(:,:) = pyin(:,:) * gcost(:,:) + pxin(:,:) * gsint(:,:) + CASE ('U') ; prot(:,:) = pyin(:,:) * gcosu(:,:) + pxin(:,:) * gsinu(:,:) + CASE ('V') ; prot(:,:) = pyin(:,:) * gcosv(:,:) + pxin(:,:) * gsinv(:,:) + CASE ('F') ; prot(:,:) = pyin(:,:) * gcosf(:,:) + pxin(:,:) * gsinf(:,:) + CASE DEFAULT ; CALL ctl_stop( 'Only T, U, V and F grid points are coded' ) + END SELECT + CASE DEFAULT ; CALL ctl_stop( 'rot_rep: Syntax Error in the definition of cdtodo' ) + ! + END SELECT + ! + END SUBROUTINE rot_rep + + + SUBROUTINE angle( plamt, pphit, plamu, pphiu, plamv, pphiv, plamf, pphif ) + !!---------------------------------------------------------------------- + !! *** ROUTINE angle *** + !! + !! ** Purpose : Compute angles between model grid lines and the North direction + !! + !! ** Method : sinus and cosinus of the angle between the north-south axe + !! and the j-direction at t, u, v and f-points + !! dot and cross products are used to obtain cos and sin, resp. + !! + !! ** Action : - gsint, gcost, gsinu, gcosu, gsinv, gcosv, gsinf, gcosf + !!---------------------------------------------------------------------- + ! WARNING: for an unexplained reason, we need to pass all glam, gphi arrays as input parameters in + ! order to get AGRIF working with -03 compilation option + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: plamt, pphit, plamu, pphiu, plamv, pphiv, plamf, pphif + ! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ierr ! local integer + REAL(wp) :: zlam, zphi ! local scalars + REAL(wp) :: zlan, zphh ! - - + REAL(wp) :: zxnpt, zynpt, znnpt ! x,y components and norm of the vector: T point to North Pole + REAL(wp) :: zxnpu, zynpu, znnpu ! x,y components and norm of the vector: U point to North Pole + REAL(wp) :: zxnpv, zynpv, znnpv ! x,y components and norm of the vector: V point to North Pole + REAL(wp) :: zxnpf, zynpf, znnpf ! x,y components and norm of the vector: F point to North Pole + REAL(wp) :: zxvvt, zyvvt, znvvt ! x,y components and norm of the vector: between V points below and above a T point + REAL(wp) :: zxffu, zyffu, znffu ! x,y components and norm of the vector: between F points below and above a U point + REAL(wp) :: zxffv, zyffv, znffv ! x,y components and norm of the vector: between F points left and right a V point + REAL(wp) :: zxuuf, zyuuf, znuuf ! x,y components and norm of the vector: between U points below and above a F point + !!---------------------------------------------------------------------- + ! + ALLOCATE( gsint(jpi,jpj), gcost(jpi,jpj), & + & gsinu(jpi,jpj), gcosu(jpi,jpj), & + & gsinv(jpi,jpj), gcosv(jpi,jpj), & + & gsinf(jpi,jpj), gcosf(jpi,jpj), STAT=ierr ) + CALL mpp_sum( 'geo2ocean', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'angle: unable to allocate arrays' ) + ! + ! ============================= ! + ! Compute the cosinus and sinus ! + ! ============================= ! + ! (computation done on the north stereographic polar plane) + ! + DO_2D( 0, 1, 0, 0 ) + ! + zlam = plamt(ji,jj) ! north pole direction & modulous (at t-point) + zphi = pphit(ji,jj) + zxnpt = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + zynpt = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + znnpt = zxnpt*zxnpt + zynpt*zynpt + ! + zlam = plamu(ji,jj) ! north pole direction & modulous (at u-point) + zphi = pphiu(ji,jj) + zxnpu = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + zynpu = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + znnpu = zxnpu*zxnpu + zynpu*zynpu + ! + zlam = plamv(ji,jj) ! north pole direction & modulous (at v-point) + zphi = pphiv(ji,jj) + zxnpv = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + zynpv = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + znnpv = zxnpv*zxnpv + zynpv*zynpv + ! + zlam = plamf(ji,jj) ! north pole direction & modulous (at f-point) + zphi = pphif(ji,jj) + zxnpf = 0. - 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + zynpf = 0. - 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) + znnpf = zxnpf*zxnpf + zynpf*zynpf + ! + zlam = plamv(ji,jj ) ! j-direction: v-point segment direction (around t-point) + zphi = pphiv(ji,jj ) + zlan = plamv(ji,jj-1) + zphh = pphiv(ji,jj-1) + zxvvt = 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + zyvvt = 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + znvvt = SQRT( znnpt * ( zxvvt*zxvvt + zyvvt*zyvvt ) ) + znvvt = MAX( znvvt, 1.e-14 ) + ! + zlam = plamf(ji,jj ) ! j-direction: f-point segment direction (around u-point) + zphi = pphif(ji,jj ) + zlan = plamf(ji,jj-1) + zphh = pphif(ji,jj-1) + zxffu = 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + zyffu = 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + znffu = SQRT( znnpu * ( zxffu*zxffu + zyffu*zyffu ) ) + znffu = MAX( znffu, 1.e-14 ) + ! + zlam = plamf(ji ,jj) ! i-direction: f-point segment direction (around v-point) + zphi = pphif(ji ,jj) + zlan = plamf(ji-1,jj) + zphh = pphif(ji-1,jj) + zxffv = 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + zyffv = 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + znffv = SQRT( znnpv * ( zxffv*zxffv + zyffv*zyffv ) ) + znffv = MAX( znffv, 1.e-14 ) + ! + zlam = plamu(ji,jj+1) ! j-direction: u-point segment direction (around f-point) + zphi = pphiu(ji,jj+1) + zlan = plamu(ji,jj ) + zphh = pphiu(ji,jj ) + zxuuf = 2. * COS( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * COS( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + zyuuf = 2. * SIN( rad*zlam ) * TAN( rpi/4. - rad*zphi/2. ) & + & - 2. * SIN( rad*zlan ) * TAN( rpi/4. - rad*zphh/2. ) + znuuf = SQRT( znnpf * ( zxuuf*zxuuf + zyuuf*zyuuf ) ) + znuuf = MAX( znuuf, 1.e-14 ) + ! + ! ! cosinus and sinus using dot and cross products + gsint(ji,jj) = ( zxnpt*zyvvt - zynpt*zxvvt ) / znvvt + gcost(ji,jj) = ( zxnpt*zxvvt + zynpt*zyvvt ) / znvvt + ! + gsinu(ji,jj) = ( zxnpu*zyffu - zynpu*zxffu ) / znffu + gcosu(ji,jj) = ( zxnpu*zxffu + zynpu*zyffu ) / znffu + ! + gsinf(ji,jj) = ( zxnpf*zyuuf - zynpf*zxuuf ) / znuuf + gcosf(ji,jj) = ( zxnpf*zxuuf + zynpf*zyuuf ) / znuuf + ! + gsinv(ji,jj) = ( zxnpv*zxffv + zynpv*zyffv ) / znffv + gcosv(ji,jj) =-( zxnpv*zyffv - zynpv*zxffv ) / znffv ! (caution, rotation of 90 degres) + ! + END_2D + + ! =============== ! + ! Geographic mesh ! + ! =============== ! + + DO_2D( 0, 1, 0, 0 ) + IF( MOD( ABS( plamv(ji,jj) - plamv(ji,jj-1) ), 360. ) < 1.e-8 ) THEN + gsint(ji,jj) = 0. + gcost(ji,jj) = 1. + ENDIF + IF( MOD( ABS( plamf(ji,jj) - plamf(ji,jj-1) ), 360. ) < 1.e-8 ) THEN + gsinu(ji,jj) = 0. + gcosu(ji,jj) = 1. + ENDIF + IF( ABS( pphif(ji,jj) - pphif(ji-1,jj) ) < 1.e-8 ) THEN + gsinv(ji,jj) = 0. + gcosv(ji,jj) = 1. + ENDIF + IF( MOD( ABS( plamu(ji,jj) - plamu(ji,jj+1) ), 360. ) < 1.e-8 ) THEN + gsinf(ji,jj) = 0. + gcosf(ji,jj) = 1. + ENDIF + END_2D + + ! =========================== ! + ! Lateral boundary conditions ! + ! =========================== ! + ! ! lateral boundary cond.: T-, U-, V-, F-pts, sgn + CALL lbc_lnk( 'geo2ocean', gcost, 'T', -1.0_wp, gsint, 'T', -1.0_wp, gcosu, 'U', -1.0_wp, gsinu, 'U', -1.0_wp, & + & gcosv, 'V', -1.0_wp, gsinv, 'V', -1.0_wp, gcosf, 'F', -1.0_wp, gsinf, 'F', -1.0_wp ) + ! + END SUBROUTINE angle + + + SUBROUTINE geo2oce ( pxx, pyy, pzz, cgrid, pte, ptn ) + !!---------------------------------------------------------------------- + !! *** ROUTINE geo2oce *** + !! + !! ** Purpose : + !! + !! ** Method : Change a vector from geocentric to east/north + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pxx, pyy, pzz + CHARACTER(len=1) , INTENT(in ) :: cgrid + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pte, ptn + ! + REAL(wp), PARAMETER :: rpi = 3.141592653e0 + REAL(wp), PARAMETER :: rad = rpi / 180.e0 + INTEGER :: ig ! + INTEGER :: ierr ! local integer + !!---------------------------------------------------------------------- + ! + IF( .NOT. ALLOCATED( gsinlon ) ) THEN + ALLOCATE( gsinlon(jpi,jpj,4) , gcoslon(jpi,jpj,4) , & + & gsinlat(jpi,jpj,4) , gcoslat(jpi,jpj,4) , STAT=ierr ) + CALL mpp_sum( 'geo2ocean', ierr ) + IF( ierr /= 0 ) CALL ctl_stop('geo2oce: unable to allocate arrays' ) + ENDIF + ! + SELECT CASE( cgrid) + CASE ( 'T' ) + ig = 1 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamt(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamt(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphit(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphit(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'U' ) + ig = 2 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamu(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamu(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphiu(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphiu(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'V' ) + ig = 3 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamv(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamv(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphiv(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphiv(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'F' ) + ig = 4 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamf(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamf(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphif(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphif(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE default + WRITE(ctmp1,*) 'geo2oce : bad grid argument : ', cgrid + CALL ctl_stop( ctmp1 ) + END SELECT + ! + pte = - gsinlon(:,:,ig) * pxx + gcoslon(:,:,ig) * pyy + ptn = - gcoslon(:,:,ig) * gsinlat(:,:,ig) * pxx & + & - gsinlon(:,:,ig) * gsinlat(:,:,ig) * pyy & + & + gcoslat(:,:,ig) * pzz + ! + END SUBROUTINE geo2oce + + + SUBROUTINE oce2geo ( pte, ptn, cgrid, pxx , pyy , pzz ) + !!---------------------------------------------------------------------- + !! *** ROUTINE oce2geo *** + !! + !! ** Purpose : + !! + !! ** Method : Change vector from east/north to geocentric + !! + !! History : ! (A. Caubel) oce2geo - Original code + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( IN ) :: pte, ptn + CHARACTER(len=1) , INTENT( IN ) :: cgrid + REAL(wp), DIMENSION(jpi,jpj), INTENT( OUT ) :: pxx , pyy , pzz + !! + REAL(wp), PARAMETER :: rpi = 3.141592653E0 + REAL(wp), PARAMETER :: rad = rpi / 180.e0 + INTEGER :: ig ! + INTEGER :: ierr ! local integer + !!---------------------------------------------------------------------- + + IF( .NOT. ALLOCATED( gsinlon ) ) THEN + ALLOCATE( gsinlon(jpi,jpj,4) , gcoslon(jpi,jpj,4) , & + & gsinlat(jpi,jpj,4) , gcoslat(jpi,jpj,4) , STAT=ierr ) + CALL mpp_sum( 'geo2ocean', ierr ) + IF( ierr /= 0 ) CALL ctl_stop('oce2geo: unable to allocate arrays' ) + ENDIF + + SELECT CASE( cgrid) + CASE ( 'T' ) + ig = 1 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamt(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamt(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphit(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphit(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'U' ) + ig = 2 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamu(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamu(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphiu(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphiu(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'V' ) + ig = 3 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamv(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamv(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphiv(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphiv(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE ( 'F' ) + ig = 4 + IF( .NOT. linit(ig) ) THEN + gsinlon(:,:,ig) = SIN( rad * glamf(:,:) ) + gcoslon(:,:,ig) = COS( rad * glamf(:,:) ) + gsinlat(:,:,ig) = SIN( rad * gphif(:,:) ) + gcoslat(:,:,ig) = COS( rad * gphif(:,:) ) + linit(ig) = .TRUE. + ENDIF + CASE default + WRITE(ctmp1,*) 'geo2oce : bad grid argument : ', cgrid + CALL ctl_stop( ctmp1 ) + END SELECT + ! + pxx = - gsinlon(:,:,ig) * pte - gcoslon(:,:,ig) * gsinlat(:,:,ig) * ptn + pyy = gcoslon(:,:,ig) * pte - gsinlon(:,:,ig) * gsinlat(:,:,ig) * ptn + pzz = gcoslat(:,:,ig) * ptn + ! + END SUBROUTINE oce2geo + + + SUBROUTINE obs_rot( psinu, pcosu, psinv, pcosv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE obs_rot *** + !! + !! ** Purpose : Copy gsinu, gcosu, gsinv and gsinv + !! to input data for rotations of + !! current at observation points + !! + !! History : 9.2 ! 09-02 (K. Mogensen) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT( OUT ):: psinu, pcosu, psinv, pcosv ! copy of data + !!---------------------------------------------------------------------- + ! + ! Initialization of gsin* and gcos* at first call + ! ----------------------------------------------- + IF( lmust_init ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' obs_rot : geographic <--> stretched' + IF(lwp) WRITE(numout,*) ' ~~~~~~~ coordinate transformation' + CALL angle( glamt, gphit, glamu, gphiu, glamv, gphiv, glamf, gphif ) ! initialization of the transformation + lmust_init = .FALSE. + ENDIF + ! + psinu(:,:) = gsinu(:,:) + pcosu(:,:) = gcosu(:,:) + psinv(:,:) = gsinv(:,:) + pcosv(:,:) = gcosv(:,:) + ! + END SUBROUTINE obs_rot + + !!====================================================================== +END MODULE geo2ocean \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/ocealb.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/ocealb.F90 new file mode 100644 index 0000000..74d55aa --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/ocealb.F90 @@ -0,0 +1,48 @@ +MODULE ocealb + !!====================================================================== + !! *** MODULE ocealb *** + !! Ocean forcing: bulk thermohaline forcing of the ocean + !!===================================================================== + !! History : + !! NEMO 4.0 ! 2017-07 (C. Rousset) Split ocean and ice albedos + !!---------------------------------------------------------------------- + !! oce_alb : albedo for ocean (clear and overcast skies) + !!---------------------------------------------------------------------- + USE phycst ! physical constants + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC oce_alb ! routine called by sbccpl + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: ocealb.F90 10069 2018-08-28 14:12:24Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE oce_alb( palb_os , palb_cs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE oce_alb *** + !! + !! ** Purpose : Computation of the albedo of the ocean + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), INTENT(out) :: palb_os ! albedo of ocean under overcast sky + REAL(wp), DIMENSION(:,:), INTENT(out) :: palb_cs ! albedo of ocean under clear sky + !! + REAL(wp) :: zcoef + REAL(wp) :: rmue = 0.40 ! cosine of local solar altitude + !!---------------------------------------------------------------------- + ! + zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 ) ! Parameterization of Briegled and Ramanathan, 1982 + palb_cs(:,:) = zcoef + palb_os(:,:) = 0.06 ! Parameterization of Kondratyev, 1969 and Payne, 1972 + ! + END SUBROUTINE oce_alb + + !!====================================================================== +END MODULE ocealb \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbc_ice.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbc_ice.F90 new file mode 100644 index 0000000..8197e17 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbc_ice.F90 @@ -0,0 +1,203 @@ +MODULE sbc_ice + !!====================================================================== + !! *** MODULE sbc_ice *** + !! Surface module - SI3 & CICE: parameters & variables defined in memory + !!====================================================================== + !! History : 3.0 ! 2006-08 (G. Madec) Surface module + !! 3.2 ! 2009-06 (S. Masson) merge with ice_oce + !! 3.3.1 ! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation + !! 3.4 ! 2011-11 (C. Harris) CICE added as an option + !! 4.0 ! 2018 (many people) SI3 compatibility + !!---------------------------------------------------------------------- +#if defined key_si3 || defined key_cice + !!---------------------------------------------------------------------- + !! 'key_si3' or 'key_cice' : SI3 or CICE sea-ice model + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE sbc_oce ! surface boundary condition: ocean +# if defined key_si3 + USE ice ! SI3 parameters +# endif +# if defined key_cice + USE ice_domain_size, only: ncat +#endif + USE lib_mpp ! MPP library + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_ice_alloc ! called in sbcmod.F90 or sbcice_cice.F90 + +# if defined key_si3 + LOGICAL , PUBLIC, PARAMETER :: lk_si3 = .TRUE. !: SI3 ice model + LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE +# endif +# if defined key_cice + LOGICAL , PUBLIC, PARAMETER :: lk_si3 = .FALSE. !: no SI3 + LOGICAL , PUBLIC, PARAMETER :: lk_cice = .TRUE. !: CICE ice model +# endif + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qns_ice !: non solar heat flux over ice [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice !: solar heat flux over ice [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qla_ice !: latent flux over ice [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dqla_ice !: latent sensibility over ice [W/m2/K] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dqns_ice !: non solar heat flux over ice (LW+SEN+LA) [W/m2/K] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_ice !: ice surface temperature [K] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: alb_ice !: ice albedo [-] + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qml_ice !: heat available for snow / ice surface melting [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qcn_ice !: heat conduction flux in the layer below surface [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qtr_ice_top !: solar flux transmitted below the ice surface [W/m2] + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_ice !: atmos-ice u-stress. VP: I-pt ; EVP: U,V-pts [N/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtau_ice !: atmos-ice v-stress. VP: I-pt ; EVP: U,V-pts [N/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice !: sublimation - precip over sea ice [kg/m2/s] + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: topmelt !: category topmelt + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: botmelt !: category botmelt + +#if defined key_si3 + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: evap_ice !: sublimation [kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: devap_ice !: sublimation sensitivity [kg/m2/s/K] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns_oce !: non solar heat flux over ocean [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_oce !: non solar heat flux over ocean [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qemp_oce !: heat flux of precip and evap over ocean [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qemp_ice !: heat flux of precip and evap over ice [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qevap_ice !: heat flux of evap over ice [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qprec_ice !: enthalpy of precip over ice [J/m3] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_oce !: evap - precip over ocean [kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm_ice !: wind speed module at T-point [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sstfrz !: sea surface freezing temperature [degC] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rCdU_ice !: ice-ocean drag at T-point (<0) [m/s] +#endif + +#if defined key_cice + ! + ! for consistency with SI3, these are declared with three dimensions + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qlw_ice !: incoming long-wave + ! + ! other forcing arrays are two dimensional + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ss_iou !: x ice-ocean surface stress at NEMO U point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ss_iov !: y ice-ocean surface stress at NEMO V point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qatm_ice !: specific humidity + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndi_ice !: i wind at T point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndj_ice !: j wind at T point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nfrzmlt !: NEMO frzmlt + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_iu !: ice fraction at NEMO U point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_iv !: ice fraction at NEMO V point + + ! variables used in the coupled interface + INTEGER , PUBLIC, PARAMETER :: jpl = ncat + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice + + ! already defined in ice.F90 for SI3 + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_i, h_s + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tatm_ice !: air temperature [K] +#endif + + !! arrays relating to embedding ice in the ocean + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass !: mass of snow and ice at current ice time step [Kg/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass_b !: mass of snow and ice at previous ice time step [Kg/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_fmass !: time evolution of mass of snow+ice [Kg/m2/s] + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbc_ice.F90 14072 2020-12-04 07:48:38Z laurent $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_ice_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_ice_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(4) + !!---------------------------------------------------------------------- + ierr(:) = 0 + + ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(1) ) + +#if defined key_si3 + ALLOCATE( qns_ice (jpi,jpj,jpl) , qsr_ice (jpi,jpj,jpl) , & + & qla_ice (jpi,jpj,jpl) , dqla_ice (jpi,jpj,jpl) , & + & dqns_ice(jpi,jpj,jpl) , tn_ice (jpi,jpj,jpl) , alb_ice (jpi,jpj,jpl) , & + & qml_ice (jpi,jpj,jpl) , qcn_ice (jpi,jpj,jpl) , qtr_ice_top(jpi,jpj,jpl) , & + & utau_ice(jpi,jpj) , vtau_ice (jpi,jpj) , wndm_ice (jpi,jpj) , & + & evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice (jpi,jpj) , & + & qemp_ice(jpi,jpj) , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) , & + & qns_oce (jpi,jpj) , qsr_oce (jpi,jpj) , emp_oce (jpi,jpj) , & + & emp_ice (jpi,jpj) , sstfrz (jpi,jpj) , rCdU_ice (jpi,jpj) , STAT= ierr(2) ) +#endif + +#if defined key_cice + ALLOCATE( qla_ice(jpi,jpj,1) , qlw_ice(jpi,jpj,1) , qsr_ice(jpi,jpj,1) , & + wndi_ice(jpi,jpj) , tatm_ice(jpi,jpj) , qatm_ice(jpi,jpj) , & + wndj_ice(jpi,jpj) , nfrzmlt(jpi,jpj) , ss_iou(jpi,jpj) , & + ss_iov(jpi,jpj) , fr_iu(jpi,jpj) , fr_iv(jpi,jpj) , & + a_i(jpi,jpj,ncat) , topmelt(jpi,jpj,ncat) , botmelt(jpi,jpj,ncat) , & + STAT= ierr(2) ) + IF( ln_cpl ) ALLOCATE( u_ice(jpi,jpj) , tn_ice (jpi,jpj,1) , & + & v_ice(jpi,jpj) , alb_ice(jpi,jpj,1) , & + & emp_ice(jpi,jpj) , qns_ice(jpi,jpj,1) , dqns_ice(jpi,jpj,1) , & + & STAT= ierr(3) ) + IF( ln_cpl ) ALLOCATE( h_i(jpi,jpj,jpl) , h_s(jpi,jpj,jpl) , STAT=ierr(4) ) +#endif + + sbc_ice_alloc = MAXVAL( ierr ) + CALL mpp_sum ( 'sbc_ice', sbc_ice_alloc ) + IF( sbc_ice_alloc > 0 ) CALL ctl_warn('sbc_ice_alloc: allocation of arrays failed') + END FUNCTION sbc_ice_alloc + +#else + !!---------------------------------------------------------------------- + !! Default option NO SI3 or CICE sea-ice model + !!---------------------------------------------------------------------- + USE lib_mpp ! MPP library + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_ice_alloc ! + + LOGICAL , PUBLIC, PARAMETER :: lk_si3 = .FALSE. !: no SI3 ice model + LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE ice model + + INTEGER , PUBLIC, PARAMETER :: jpl = 1 + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice ! jpi, jpj + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_ice, alb_ice, qns_ice, dqns_ice ! (jpi,jpj,jpl) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_i, h_s + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: topmelt, botmelt + ! + !! arrays related to embedding ice in the ocean. + !! These arrays need to be declared even if no ice model is required. + !! In the no ice model or traditional levitating ice cases they contain only zeros + !! --------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass !: mass of snow and ice at current ice time step [Kg/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass_b !: mass of snow and ice at previous ice time step [Kg/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_fmass !: time evolution of mass of snow+ice [Kg/m2/s] + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_ice_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_ice_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(1) + !!---------------------------------------------------------------------- + ierr(:) = 0 + ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(1) ) + sbc_ice_alloc = MAXVAL( ierr ) + CALL mpp_sum ( 'sbc_ice', sbc_ice_alloc ) + IF( sbc_ice_alloc > 0 ) CALL ctl_warn('sbc_ice_alloc: allocation of arrays failed') + END FUNCTION sbc_ice_alloc +#endif + + !!====================================================================== +END MODULE sbc_ice \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbc_oce.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbc_oce.F90 new file mode 100644 index 0000000..17aefe7 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbc_oce.F90 @@ -0,0 +1,235 @@ +MODULE sbc_oce + !!====================================================================== + !! *** MODULE sbc_oce *** + !! Surface module : variables defined in core memory + !!====================================================================== + !! History : 3.0 ! 2006-06 (G. Madec) Original code + !! - ! 2008-08 (G. Madec) namsbc moved from sbcmod + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) Forcing averaged over 2 time steps + !! - ! 2010-11 (G. Madec) ice-ocean stress always computed at each ocean time-step + !! 3.3 ! 2010-10 (J. Chanut, C. Bricaud) add the surface pressure forcing + !! 4.0 ! 2012-05 (C. Rousset) add attenuation coef for use in ice model + !! 4.0 ! 2016-06 (L. Brodeau) new unified bulk routine (based on AeroBulk) + !! 4.0 ! 2019-03 (F. Lemarié, G. Samson) add compatibility with ABL mode + !! 4.2 ! 2020-12 (G. Madec, E. Clementi) modified wave parameters in namelist + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_oce_alloc : allocation of sbc arrays + !! sbc_tau2wnd : wind speed estimated from wind stress + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_oce_alloc ! routine called in sbcmod.F90 + PUBLIC sbc_tau2wnd ! routine called in several sbc modules + + !!---------------------------------------------------------------------- + !! Namelist for the Ocean Surface Boundary Condition + !!---------------------------------------------------------------------- + ! !!* namsbc namelist * + LOGICAL , PUBLIC :: ln_usr !: user defined formulation + LOGICAL , PUBLIC :: ln_flx !: flux formulation + LOGICAL , PUBLIC :: ln_blk !: bulk formulation + LOGICAL , PUBLIC :: ln_abl !: Atmospheric boundary layer model + LOGICAL , PUBLIC :: ln_wave !: wave in the system (forced or coupled) +#if defined key_oasis3 + LOGICAL , PUBLIC :: lk_oasis = .TRUE. !: OASIS used +#else + LOGICAL , PUBLIC :: lk_oasis = .FALSE. !: OASIS unused +#endif + LOGICAL , PUBLIC :: ln_cpl !: ocean-atmosphere coupled formulation + LOGICAL , PUBLIC :: ln_mixcpl !: ocean-atmosphere forced-coupled mixed formulation + LOGICAL , PUBLIC :: ln_dm2dc !: Daily mean to Diurnal Cycle short wave (qsr) + LOGICAL , PUBLIC :: ln_rnf !: runoffs / runoff mouths + LOGICAL , PUBLIC :: ln_ssr !: Sea Surface restoring on SST and/or SSS + LOGICAL , PUBLIC :: ln_apr_dyn !: Atmospheric pressure forcing used on dynamics (ocean & ice) + INTEGER , PUBLIC :: nn_ice !: flag for ice in the surface boundary condition (=0/1/2/3) + LOGICAL , PUBLIC :: ln_ice_embd !: flag for levitating/embedding sea-ice in the ocean + ! !: =F levitating ice (no presure effect) with mass and salt exchanges + ! !: =T embedded sea-ice (pressure effect + mass and salt exchanges) + INTEGER , PUBLIC :: nn_components !: flag for sbc module (including sea-ice) coupling mode (see component definition below) + INTEGER , PUBLIC :: nn_fwb !: FreshWater Budget: + ! !: = 0 unchecked + ! !: = 1 global mean of e-p-r set to zero at each nn_fsbc time step + ! !: = 2 annual global mean of e-p-r set to zero + LOGICAL , PUBLIC :: ln_icebergs !: Icebergs + ! + INTEGER , PUBLIC :: nn_lsm !: Number of iteration if seaoverland is applied + ! + ! !!* namsbc_cpl namelist * + INTEGER , PUBLIC :: nn_cats_cpl !: Number of sea ice categories over which the coupling is carried out + ! + ! !!* namsbc_wave namelist * + LOGICAL , PUBLIC :: ln_sdw !: =T 3d stokes drift from wave model + LOGICAL , PUBLIC :: ln_stcor !: =T if Stokes-Coriolis and tracer advection terms are used + LOGICAL , PUBLIC :: ln_cdgw !: =T neutral drag coefficient from wave model + LOGICAL , PUBLIC :: ln_tauoc !: =T if normalized stress from wave is used + LOGICAL , PUBLIC :: ln_wave_test !: =T wave test case (constant Stokes drift) + LOGICAL , PUBLIC :: ln_charn !: =T Chranock coefficient from wave model + LOGICAL , PUBLIC :: ln_taw !: =T wind stress corrected by wave intake + LOGICAL , PUBLIC :: ln_phioc !: =T TKE surface BC from wave model + LOGICAL , PUBLIC :: ln_bern_srfc !: Bernoulli head, waves' inuced pressure + LOGICAL , PUBLIC :: ln_breivikFV_2016 !: Breivik 2016 profile + LOGICAL , PUBLIC :: ln_vortex_force !: vortex force activation + LOGICAL , PUBLIC :: ln_stshear !: Stoked Drift shear contribution in zdftke + ! + !!---------------------------------------------------------------------- + !! switch definition (improve readability) + !!---------------------------------------------------------------------- + INTEGER , PUBLIC, PARAMETER :: jp_usr = 1 !: user defined formulation + INTEGER , PUBLIC, PARAMETER :: jp_flx = 2 !: flux formulation + INTEGER , PUBLIC, PARAMETER :: jp_blk = 3 !: bulk formulation + INTEGER , PUBLIC, PARAMETER :: jp_abl = 4 !: Atmospheric boundary layer formulation + INTEGER , PUBLIC, PARAMETER :: jp_purecpl = 5 !: Pure ocean-atmosphere Coupled formulation + INTEGER , PUBLIC, PARAMETER :: jp_none = 6 !: for OCE when doing coupling via SAS module + ! + !!---------------------------------------------------------------------- + !! component definition + !!---------------------------------------------------------------------- + INTEGER , PUBLIC, PARAMETER :: jp_iam_nemo = 0 !: Initial single executable configuration + ! (no internal OASIS coupling) + INTEGER , PUBLIC, PARAMETER :: jp_iam_oce = 1 !: Multi executable configuration - OCE component + ! (internal OASIS coupling) + INTEGER , PUBLIC, PARAMETER :: jp_iam_sas = 2 !: Multi executable configuration - SAS component + ! (internal OASIS coupling) + !!---------------------------------------------------------------------- + !! Ocean Surface Boundary Condition fields + !!---------------------------------------------------------------------- + INTEGER , PUBLIC :: ncpl_qsr_freq = 0 !: qsr coupling frequency per days from atmosphere (used by top) + ! + !! !! now ! before !! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau , utau_b !: sea surface i-stress (ocean referential) [N/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtau , vtau_b !: sea surface j-stress (ocean referential) [N/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_icb, vtau_icb !: sea surface (i,j)-stress used by icebergs [N/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: taum !: module of sea surface stress (at T-point) [N/m2] + !! wndm is used compute surface gases exchanges in ice-free ocean or leads + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm !: wind speed module at T-point (=|U10m-Uoce|) [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhoa !: air density at "rn_zu" m above the sea [kg/m3] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr !: sea heat flux: solar [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns , qns_b !: sea heat flux: non solar [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_tot !: total solar heat flux (over sea and ice) [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns_tot !: total non solar heat flux (over sea and ice) [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp , emp_b !: freshwater budget: volume flux [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx , sfx_b !: salt flux [PSS.kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_tot !: total E-P over ocean and ice [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fmmflx !: freshwater budget: freezing/melting [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnf , rnf_b !: river runoff [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fwficb , fwficb_b !: iceberg melting [Kg/m2/s] + !! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sbc_tsc, sbc_tsc_b !: sbc content trend [K.m/s] jpi,jpj,jpts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_hc , qsr_hc_b !: heat content trend due to qsr flux [K.m/s] jpi,jpj,jpk + !! + !! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tprecip !: total precipitation [Kg/m2/s] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sprecip !: solid precipitation [Kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_i !: ice fraction = 1 - lead fraction (between 0 to 1) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: atm_co2 !: atmospheric pCO2 [ppm] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xcplmask !: coupling mask for ln_mixcpl (warning: allocated in sbccpl) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: cloud_fra !: cloud cover (fraction of cloud in a gridcell) [-] + + !!--------------------------------------------------------------------- + !! ABL Vertical Domain size + !!--------------------------------------------------------------------- + INTEGER , PUBLIC :: jpka = 2 !: ABL number of vertical levels (default definition) + INTEGER , PUBLIC :: jpkam1 = 1 !: jpka-1 + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ght_abl, ghw_abl !: ABL geopotential height (needed for iom) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: e3t_abl, e3w_abl !: ABL vertical scale factors (needed for iom) + + !!---------------------------------------------------------------------- + !! Sea Surface Mean fields + !!---------------------------------------------------------------------- + INTEGER , PUBLIC :: nn_fsbc !: frequency of sbc computation (as well as sea-ice model) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssu_m !: mean (nn_fsbc time-step) surface sea i-current (U-point) [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssv_m !: mean (nn_fsbc time-step) surface sea j-current (V-point) [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sst_m !: mean (nn_fsbc time-step) surface sea temperature [Celsius] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sss_m !: mean (nn_fsbc time-step) surface sea salinity [psu] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssh_m !: mean (nn_fsbc time-step) sea surface height [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tsk_m !: mean (nn_fsbc time-step) SKIN surface sea temp. [Celsius] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3t_m !: mean (nn_fsbc time-step) sea surface layer thickness [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_m !: mean (nn_fsbc time-step) fraction of solar net radiation absorbed in the 1st T level [-] + + !!---------------------------------------------------------------------- + !! Surface atmospheric fields + !!---------------------------------------------------------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_air_zt !: specific humidity of air at z=zt [kg/kg]ww + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: theta_air_zt !: potential temperature of air at z=zt [K] + + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbc_oce.F90 15372 2021-10-14 15:47:24Z davestorkey $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_oce_alloc() + !!--------------------------------------------------------------------- + !! *** FUNCTION sbc_oce_alloc *** + !!--------------------------------------------------------------------- + INTEGER :: ierr(6) + !!--------------------------------------------------------------------- + ierr(:) = 0 + ! + ALLOCATE( utau(jpi,jpj) , utau_b(jpi,jpj) , taum(jpi,jpj) , & + & vtau(jpi,jpj) , vtau_b(jpi,jpj) , wndm(jpi,jpj) , rhoa(jpi,jpj) , STAT=ierr(1) ) + ! + ALLOCATE( qns_tot(jpi,jpj) , qns (jpi,jpj) , qns_b(jpi,jpj), & + & qsr_tot(jpi,jpj) , qsr (jpi,jpj) , & + & emp (jpi,jpj) , emp_b(jpi,jpj) , & + & sfx (jpi,jpj) , sfx_b(jpi,jpj) , emp_tot(jpi,jpj), fmmflx(jpi,jpj), STAT=ierr(2) ) + ! + ALLOCATE( rnf (jpi,jpj) , sbc_tsc (jpi,jpj,jpts) , qsr_hc (jpi,jpj,jpk) , & + & rnf_b(jpi,jpj) , sbc_tsc_b(jpi,jpj,jpts) , qsr_hc_b(jpi,jpj,jpk) , & + & fwficb (jpi,jpj), fwficb_b(jpi,jpj), STAT=ierr(3) ) + ! + ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) , & + & atm_co2(jpi,jpj) , tsk_m(jpi,jpj) , cloud_fra(jpi,jpj), & + & ssu_m (jpi,jpj) , sst_m(jpi,jpj) , frq_m(jpi,jpj) , & + & ssv_m (jpi,jpj) , sss_m(jpi,jpj) , ssh_m(jpi,jpj) , STAT=ierr(4) ) + ! + ALLOCATE( e3t_m(jpi,jpj) , STAT=ierr(5) ) + ! + ALLOCATE( q_air_zt(jpi,jpj) , theta_air_zt(jpi,jpj) , STAT=ierr(6) ) !#LB + ! + sbc_oce_alloc = MAXVAL( ierr ) + CALL mpp_sum ( 'sbc_oce', sbc_oce_alloc ) + IF( sbc_oce_alloc > 0 ) CALL ctl_warn('sbc_oce_alloc: allocation of arrays failed') + ! + END FUNCTION sbc_oce_alloc + + + SUBROUTINE sbc_tau2wnd + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_tau2wnd *** + !! + !! ** Purpose : Estimation of wind speed as a function of wind stress + !! + !! ** Method : |tau|=rhoa*Cd*|U|^2 + !!--------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: ztx, zty, ztau, zcoef ! temporary variables + INTEGER :: ji, jj ! dummy indices + !!--------------------------------------------------------------------- + zcoef = 0.5 / ( zrhoa * zcdrag ) + DO_2D( 0, 0, 0, 0 ) + ztx = utau(ji-1,jj ) + utau(ji,jj) + zty = vtau(ji ,jj-1) + vtau(ji,jj) + ztau = SQRT( ztx * ztx + zty * zty ) + wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask(ji,jj,1) + END_2D + CALL lbc_lnk( 'sbc_oce', wndm(:,:) , 'T', 1.0_wp ) + ! + END SUBROUTINE sbc_tau2wnd + + !!====================================================================== +END MODULE sbc_oce diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbc_phy.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbc_phy.F90 new file mode 100644 index 0000000..b2bfb45 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbc_phy.F90 @@ -0,0 +1,1277 @@ +MODULE sbc_phy + !!====================================================================== + !! *** MODULE sbc_phy *** + !! A set of functions to compute air themodynamics parameters + !! needed by Aerodynamic Bulk Formulas + !!===================================================================== + !! 4.x ! 2020 L. Brodeau from AeroBulk package (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------- + + !! virt_temp : virtual (aka sensible) temperature (potential or absolute) + !! rho_air : density of (moist) air (depends on T_air, q_air and SLP + !! visc_air : kinematic viscosity (aka Nu_air) of air from temperature + !! L_vap : latent heat of vaporization of water as a function of temperature + !! cp_air : specific heat of (moist) air (depends spec. hum. q_air) + !! gamma_moist : adiabatic lapse-rate of moist air + !! One_on_L : 1. / ( Obukhov length ) + !! Ri_bulk : bulk Richardson number aka BRN + !! q_sat : saturation humidity as a function of SLP and temperature + !! q_air_rh : specific humidity as a function of RH (fraction, not %), t_air and SLP + + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + + IMPLICIT NONE + PUBLIC !! Haleluja that was the solution for AGRIF + + INTEGER , PARAMETER, PUBLIC :: nb_iter0 = 5 ! Default number of itterations in bulk-param algorithms (can be overriden b.m.o `nb_iter` optional argument) + + !! (mainly removed from sbcblk.F90) + REAL(wp), PARAMETER, PUBLIC :: rCp_dry = 1005.0_wp !: Specic heat of dry air, constant pressure [J/K/kg] + REAL(wp), PARAMETER, PUBLIC :: rCp_vap = 1860.0_wp !: Specic heat of water vapor, constant pressure [J/K/kg] + REAL(wp), PARAMETER, PUBLIC :: R_dry = 287.05_wp !: Specific gas constant for dry air [J/K/kg] + REAL(wp), PARAMETER, PUBLIC :: R_vap = 461.495_wp !: Specific gas constant for water vapor [J/K/kg] + REAL(wp), PARAMETER, PUBLIC :: reps0 = R_dry/R_vap !: ratio of gas constant for dry air and water vapor => ~ 0.622 + REAL(wp), PARAMETER, PUBLIC :: rctv0 = R_vap/R_dry - 1._wp !: for virtual temperature (== (1-eps)/eps) => ~ 0.608 + REAL(wp), PARAMETER, PUBLIC :: rCp_air = 1000.5_wp !: specific heat of air (only used for ice fluxes now...) + REAL(wp), PARAMETER, PUBLIC :: albo = 0.066_wp !: ocean albedo assumed to be constant + REAL(wp), PARAMETER, PUBLIC :: R_gas = 8.314510_wp !: Universal molar gas constant [J/mol/K] + REAL(wp), PARAMETER, PUBLIC :: rmm_dryair = 28.9647e-3_wp !: dry air molar mass / molecular weight [kg/mol] + REAL(wp), PARAMETER, PUBLIC :: rmm_water = 18.0153e-3_wp !: water molar mass / molecular weight [kg/mol] + REAL(wp), PARAMETER, PUBLIC :: rmm_ratio = rmm_water / rmm_dryair + REAL(wp), PARAMETER, PUBLIC :: rgamma_dry = R_gas / ( rmm_dryair * rCp_dry ) !: Poisson constant for dry air + REAL(wp), PARAMETER, PUBLIC :: rpref = 1.e5_wp !: reference air pressure for exner function [Pa] + ! + REAL(wp), PARAMETER, PUBLIC :: rho0_a = 1.2_wp !: Approx. of density of air [kg/m^3] + REAL(wp), PARAMETER, PUBLIC :: rho0_w = 1025._wp !: Density of sea-water (ECMWF->1025) [kg/m^3] + REAL(wp), PARAMETER, PUBLIC :: radrw = rho0_a/rho0_w !: Density ratio + REAL(wp), PARAMETER, PUBLIC :: sq_radrw = SQRT(rho0_a/rho0_w) + REAL(wp), PARAMETER, PUBLIC :: rCp0_w = 4190._wp !: Specific heat capacity of seawater (ECMWF 4190) [J/K/kg] + REAL(wp), PARAMETER, PUBLIC :: rnu0_w = 1.e-6_wp !: kinetic viscosity of water [m^2/s] + REAL(wp), PARAMETER, PUBLIC :: rk0_w = 0.6_wp !: thermal conductivity of water (at 20C) [W/m/K] + ! + REAL(wp), PARAMETER, PUBLIC :: emiss_w = 0.98_wp !: Long-wave (thermal) emissivity of sea-water [] + ! + REAL(wp), PARAMETER, PUBLIC :: emiss_i = 0.996_wp !: " for ice and snow => but Rees 1993 suggests can be lower in winter on fresh snow... 0.72 ... + + REAL(wp), PARAMETER, PUBLIC :: wspd_thrshld_ice = 0.2_wp !: minimum scalar wind speed accepted over sea-ice... [m/s] + + ! + REAL(wp), PARAMETER, PUBLIC :: rdct_qsat_salt = 0.98_wp !: reduction factor on specific humidity at saturation (q_sat(T_s)) due to salt + REAL(wp), PARAMETER, PUBLIC :: rtt0 = 273.16_wp !: triple point of temperature [K] + ! + REAL(wp), PARAMETER, PUBLIC :: rcst_cs = -16._wp*9.80665_wp*rho0_w*rCp0_w*rnu0_w*rnu0_w*rnu0_w/(rk0_w*rk0_w) !: for cool-skin parameterizations... (grav = 9.80665_wp) + ! => see eq.(14) in Fairall et al. 1996 (eq.(6) of Zeng aand Beljaars is WRONG! (typo?) + + REAL(wp), PARAMETER, PUBLIC :: z0_sea_max = 0.0025_wp !: maximum realistic value for roughness length of sea-surface... [m] + + REAL(wp), PUBLIC, SAVE :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] + + + REAL(wp), PARAMETER, PUBLIC :: Cx_min = 0.1E-3_wp ! smallest value allowed for bulk transfer coefficients (usually in stable conditions with now wind) + + REAL(wp), PARAMETER :: & + !! Constants for Goff formula in the presence of ice: + & rAg_i = -9.09718_wp, & + & rBg_i = -3.56654_wp, & + & rCg_i = 0.876793_wp, & + & rDg_i = LOG10(6.1071_wp) + + REAL(wp), PARAMETER :: rc_louis = 5._wp + REAL(wp), PARAMETER :: rc2_louis = rc_louis * rc_louis + REAL(wp), PARAMETER :: ram_louis = 2. * rc_louis + REAL(wp), PARAMETER :: rah_louis = 3. * rc_louis + + + INTERFACE virt_temp + MODULE PROCEDURE virt_temp_vctr, virt_temp_sclr + END INTERFACE virt_temp + + INTERFACE pres_temp + MODULE PROCEDURE pres_temp_vctr, pres_temp_sclr + END INTERFACE pres_temp + + INTERFACE theta_exner + MODULE PROCEDURE theta_exner_vctr, theta_exner_sclr + END INTERFACE theta_exner + + INTERFACE visc_air + MODULE PROCEDURE visc_air_vctr, visc_air_sclr + END INTERFACE visc_air + + INTERFACE gamma_moist + MODULE PROCEDURE gamma_moist_vctr, gamma_moist_sclr + END INTERFACE gamma_moist + + INTERFACE e_sat + MODULE PROCEDURE e_sat_vctr, e_sat_sclr + END INTERFACE e_sat + + INTERFACE e_sat_ice + MODULE PROCEDURE e_sat_ice_vctr, e_sat_ice_sclr + END INTERFACE e_sat_ice + + INTERFACE de_sat_dt_ice + MODULE PROCEDURE de_sat_dt_ice_vctr, de_sat_dt_ice_sclr + END INTERFACE de_sat_dt_ice + + INTERFACE Ri_bulk + MODULE PROCEDURE Ri_bulk_vctr, Ri_bulk_sclr + END INTERFACE Ri_bulk + + INTERFACE q_sat + MODULE PROCEDURE q_sat_vctr, q_sat_sclr + END INTERFACE q_sat + + INTERFACE dq_sat_dt_ice + MODULE PROCEDURE dq_sat_dt_ice_vctr, dq_sat_dt_ice_sclr + END INTERFACE dq_sat_dt_ice + + INTERFACE L_vap + MODULE PROCEDURE L_vap_vctr, L_vap_sclr + END INTERFACE L_vap + + INTERFACE rho_air + MODULE PROCEDURE rho_air_vctr, rho_air_sclr + END INTERFACE rho_air + + INTERFACE cp_air + MODULE PROCEDURE cp_air_vctr, cp_air_sclr + END INTERFACE cp_air + + INTERFACE alpha_sw + MODULE PROCEDURE alpha_sw_vctr, alpha_sw_sclr + END INTERFACE alpha_sw + + INTERFACE bulk_formula + MODULE PROCEDURE bulk_formula_vctr, bulk_formula_sclr + END INTERFACE bulk_formula + + INTERFACE qlw_net + MODULE PROCEDURE qlw_net_vctr, qlw_net_sclr + END INTERFACE qlw_net + + INTERFACE f_m_louis + MODULE PROCEDURE f_m_louis_vctr, f_m_louis_sclr + END INTERFACE f_m_louis + + INTERFACE f_h_louis + MODULE PROCEDURE f_h_louis_vctr, f_h_louis_sclr + END INTERFACE f_h_louis + + + PUBLIC virt_temp + PUBLIC pres_temp + PUBLIC theta_exner + PUBLIC rho_air + PUBLIC visc_air + PUBLIC L_vap + PUBLIC cp_air + PUBLIC gamma_moist + PUBLIC One_on_L + PUBLIC Ri_bulk + PUBLIC q_sat + PUBLIC q_air_rh + PUBLIC dq_sat_dt_ice + ! + PUBLIC update_qnsol_tau + PUBLIC alpha_sw + PUBLIC bulk_formula + PUBLIC qlw_net + ! + PUBLIC f_m_louis, f_h_louis + PUBLIC z0_from_Cd + PUBLIC Cd_from_z0 + PUBLIC UN10_from_ustar + PUBLIC UN10_from_CD + PUBLIC z0tq_LKB + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcblk.F90 10535 2019-01-16 17:36:47Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + + FUNCTION virt_temp_sclr( pta, pqa ) + !!------------------------------------------------------------------------ + !! + !! Compute the (absolute/potential) VIRTUAL temperature, based on the + !! (absolute/potential) temperature and specific humidity + !! + !! If input temperature is absolute then output virtual temperature is absolute + !! If input temperature is potential then output virtual temperature is potential + !! + !! Author: L. Brodeau, June 2019 / AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------ + REAL(wp) :: virt_temp_sclr !: virtual temperature [K] + REAL(wp), INTENT(in) :: pta !: absolute or potential air temperature [K] + REAL(wp), INTENT(in) :: pqa !: specific humidity of air [kg/kg] + !!------------------------------------------------------------------- + ! + virt_temp_sclr = pta * (1._wp + rctv0*pqa) + !! + !! This is exactly the same thing as: + !! virt_temp_sclr = pta * ( pwa + reps0) / (reps0*(1.+pwa)) + !! with wpa (mixing ration) defined as : pwa = pqa/(1.-pqa) + ! + END FUNCTION virt_temp_sclr + + FUNCTION virt_temp_vctr( pta, pqa ) + + REAL(wp), DIMENSION(jpi,jpj) :: virt_temp_vctr !: virtual temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute or potential air temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: specific humidity of air [kg/kg] + + virt_temp_vctr(:,:) = pta(:,:) * (1._wp + rctv0*pqa(:,:)) + + END FUNCTION virt_temp_vctr + + + FUNCTION pres_temp_sclr( pqspe, pslp, pz, ptpot, pta, l_ice ) + + !!------------------------------------------------------------------------------- + !! *** FUNCTION pres_temp *** + !! + !! ** Purpose : compute air pressure using barometric equation + !! from either potential or absolute air temperature + !! ** Author: G. Samson, Feb 2021 + !!------------------------------------------------------------------------------- + + REAL(wp) :: pres_temp_sclr ! air pressure [Pa] + REAL(wp), INTENT(in ) :: pqspe ! air specific humidity [kg/kg] + REAL(wp), INTENT(in ) :: pslp ! sea-level pressure [Pa] + REAL(wp), INTENT(in ) :: pz ! height above surface [m] + REAL(wp), INTENT(in ) , OPTIONAL :: ptpot ! air potential temperature [K] + REAL(wp), INTENT(inout), OPTIONAL :: pta ! air absolute temperature [K] + REAL(wp) :: ztpot, zta, zpa, zxm, zmask, zqsat + INTEGER :: it, niter = 3 ! iteration indice and number + LOGICAL , INTENT(in) , OPTIONAL :: l_ice ! sea-ice presence + LOGICAL :: lice ! sea-ice presence + + IF( PRESENT(ptpot) ) THEN + zmask = 1._wp + ztpot = ptpot + zta = 0._wp + ELSE + zmask = 0._wp + ztpot = 0._wp + zta = pta + ENDIF + + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + + zpa = pslp ! air pressure first guess [Pa] + DO it = 1, niter + zta = ztpot * ( zpa / rpref )**rgamma_dry * zmask + (1._wp - zmask) * zta + zqsat = q_sat( zta, zpa, l_ice=lice ) ! saturation specific humidity [kg/kg] + zxm = (1._wp - pqspe/zqsat) * rmm_dryair + pqspe/zqsat * rmm_water ! moist air molar mass [kg/mol] + zpa = pslp * EXP( -grav * zxm * pz / ( R_gas * zta ) ) + END DO + + pres_temp_sclr = zpa + IF(( PRESENT(pta) ).AND.( PRESENT(ptpot) )) pta = zta + + END FUNCTION pres_temp_sclr + + + FUNCTION pres_temp_vctr( pqspe, pslp, pz, ptpot, pta, l_ice ) + + !!------------------------------------------------------------------------------- + !! *** FUNCTION pres_temp *** + !! + !! ** Purpose : compute air pressure using barometric equation + !! from either potential or absolute air temperature + !! ** Author: G. Samson, Feb 2021 + !!------------------------------------------------------------------------------- + + REAL(wp), DIMENSION(jpi,jpj) :: pres_temp_vctr ! air pressure [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pqspe ! air specific humidity [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pslp ! sea-level pressure [Pa] + REAL(wp), INTENT(in ) :: pz ! height above surface [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) , OPTIONAL :: ptpot ! air potential temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout), OPTIONAL :: pta ! air absolute temperature [K] + INTEGER :: ji, jj ! loop indices + LOGICAL , INTENT(in) , OPTIONAL :: l_ice ! sea-ice presence + LOGICAL :: lice ! sea-ice presence + + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + + IF( PRESENT(ptpot) ) THEN + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + pres_temp_vctr(ji,jj) = pres_temp_sclr( pqspe(ji,jj), pslp(ji,jj), pz, ptpot=ptpot(ji,jj), pta=pta(ji,jj), l_ice=lice ) + END_2D + ELSE + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + pres_temp_vctr(ji,jj) = pres_temp_sclr( pqspe(ji,jj), pslp(ji,jj), pz, pta=pta(ji,jj), l_ice=lice ) + END_2D + ENDIF + + END FUNCTION pres_temp_vctr + + + FUNCTION theta_exner_sclr( pta, ppa ) + + !!------------------------------------------------------------------------------- + !! *** FUNCTION theta_exner *** + !! + !! ** Purpose : compute air/surface potential temperature from absolute temperature + !! and pressure using Exner function + !! ** Author: G. Samson, Feb 2021 + !!------------------------------------------------------------------------------- + + REAL(wp) :: theta_exner_sclr ! air/surface potential temperature [K] + REAL(wp), INTENT(in) :: pta ! air/surface absolute temperature [K] + REAL(wp), INTENT(in) :: ppa ! air/surface pressure [Pa] + + theta_exner_sclr = pta * ( rpref / ppa ) ** rgamma_dry + + END FUNCTION theta_exner_sclr + + FUNCTION theta_exner_vctr( pta, ppa ) + + !!------------------------------------------------------------------------------- + !! *** FUNCTION theta_exner *** + !! + !! ** Purpose : compute air/surface potential temperature from absolute temperature + !! and pressure using Exner function + !! ** Author: G. Samson, Feb 2021 + !!------------------------------------------------------------------------------- + + REAL(wp), DIMENSION(jpi,jpj) :: theta_exner_vctr ! air/surface potential temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta ! air/surface absolute temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! air/surface pressure [Pa] + INTEGER :: ji, jj ! loop indices + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + theta_exner_vctr(ji,jj) = theta_exner_sclr( pta(ji,jj), ppa(ji,jj) ) + END_2D + + END FUNCTION theta_exner_vctr + + + FUNCTION rho_air_vctr( ptak, pqa, ppa ) + !!------------------------------------------------------------------------------- + !! *** FUNCTION rho_air_vctr *** + !! + !! ** Purpose : compute density of (moist) air using the eq. of state of the atmosphere + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! pressure in [Pa] + REAL(wp), DIMENSION(jpi,jpj) :: rho_air_vctr ! density of moist air [kg/m^3] + !!------------------------------------------------------------------------------- + + rho_air_vctr = MAX( ppa / (R_dry*ptak * ( 1._wp + rctv0*pqa )) , 0.8_wp ) + + END FUNCTION rho_air_vctr + + FUNCTION rho_air_sclr( ptak, pqa, ppa ) + !!------------------------------------------------------------------------------- + !! *** FUNCTION rho_air_sclr *** + !! + !! ** Purpose : compute density of (moist) air using the eq. of state of the atmosphere + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------------- + REAL(wp), INTENT(in) :: ptak ! air temperature [K] + REAL(wp), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp), INTENT(in) :: ppa ! pressure in [Pa] + REAL(wp) :: rho_air_sclr ! density of moist air [kg/m^3] + !!------------------------------------------------------------------------------- + rho_air_sclr = MAX( ppa / (R_dry*ptak * ( 1._wp + rctv0*pqa )) , 0.8_wp ) + + END FUNCTION rho_air_sclr + + + FUNCTION visc_air_sclr(ptak) + !!---------------------------------------------------------------------------------- + !! Air kinetic viscosity (m^2/s) given from air temperature in Kelvin + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: visc_air_sclr ! kinetic viscosity (m^2/s) + REAL(wp), INTENT(in) :: ptak ! air temperature in (K) + ! + REAL(wp) :: ztc, ztc2 ! local scalar + !!---------------------------------------------------------------------------------- + ! + ztc = ptak - rt0 ! air temp, in deg. C + ztc2 = ztc*ztc + visc_air_sclr = 1.326e-5*(1. + 6.542E-3*ztc + 8.301e-6*ztc2 - 4.84e-9*ztc2*ztc) + ! + END FUNCTION visc_air_sclr + + FUNCTION visc_air_vctr(ptak) + + REAL(wp), DIMENSION(jpi,jpj) :: visc_air_vctr ! kinetic viscosity (m^2/s) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature in (K) + INTEGER :: ji, jj ! dummy loop indices + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + visc_air_vctr(ji,jj) = visc_air_sclr( ptak(ji,jj) ) + END_2D + + END FUNCTION visc_air_vctr + + + FUNCTION L_vap_vctr( psst ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION L_vap_vctr *** + !! + !! ** Purpose : Compute the latent heat of vaporization of water from temperature + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: L_vap_vctr ! latent heat of vaporization [J/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! water temperature [K] + !!---------------------------------------------------------------------------------- + ! + L_vap_vctr = ( 2.501_wp - 0.00237_wp * ( psst(:,:) - rt0) ) * 1.e6_wp + ! + END FUNCTION L_vap_vctr + + FUNCTION L_vap_sclr( psst ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION L_vap_sclr *** + !! + !! ** Purpose : Compute the latent heat of vaporization of water from temperature + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: L_vap_sclr ! latent heat of vaporization [J/kg] + REAL(wp), INTENT(in) :: psst ! water temperature [K] + !!---------------------------------------------------------------------------------- + ! + L_vap_sclr = ( 2.501_wp - 0.00237_wp * ( psst - rt0) ) * 1.e6_wp + ! + END FUNCTION L_vap_sclr + + + FUNCTION cp_air_vctr( pqa ) + !!------------------------------------------------------------------------------- + !! *** FUNCTION cp_air_vctr *** + !! + !! ** Purpose : Compute specific heat (Cp) of moist air + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp), DIMENSION(jpi,jpj) :: cp_air_vctr ! specific heat of moist air [J/K/kg] + !!------------------------------------------------------------------------------- + + cp_air_vctr = rCp_dry + rCp_vap * pqa + + END FUNCTION cp_air_vctr + + FUNCTION cp_air_sclr( pqa ) + !!------------------------------------------------------------------------------- + !! *** FUNCTION cp_air_sclr *** + !! + !! ** Purpose : Compute specific heat (Cp) of moist air + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp) :: cp_air_sclr ! specific heat of moist air [J/K/kg] + !!------------------------------------------------------------------------------- + + cp_air_sclr = rCp_dry + rCp_vap * pqa + + END FUNCTION cp_air_sclr + + + FUNCTION gamma_moist_sclr( ptak, pqa ) + !!---------------------------------------------------------------------------------- + !! ** Purpose : Compute the moist adiabatic lapse-rate. + !! => http://glossary.ametsoc.org/wiki/Moist-adiabatic_lapse_rate + !! => http://www.geog.ucsb.edu/~joel/g266_s10/lecture_notes/chapt03/oh10_3_01/oh10_3_01.html + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: gamma_moist_sclr ! [K/m] + REAL(wp), INTENT(in) :: ptak ! absolute air temperature [K] !#LB: double check it's absolute !!! + REAL(wp), INTENT(in) :: pqa ! specific humidity [kg/kg] + ! + REAL(wp) :: zta, zqa, zwa, ziRT, zLvap ! local scalars + !!---------------------------------------------------------------------------------- + zta = MAX( ptak, 180._wp) ! prevents screw-up over masked regions where field == 0. + zqa = MAX( pqa, 1.E-6_wp) ! " " " + !! + zwa = zqa / (1._wp - zqa) ! w is mixing ratio w = q/(1-q) | q = w/(1+w) + ziRT = 1._wp / (R_dry*zta) ! 1/RT + zLvap = L_vap_sclr( ptak ) + !! + gamma_moist_sclr = grav * ( 1._wp + zLvap*zwa*ziRT ) / ( rCp_dry + zLvap*zLvap*zwa*reps0*ziRT/zta ) + !! + END FUNCTION gamma_moist_sclr + + FUNCTION gamma_moist_vctr( ptak, pqa ) + + REAL(wp), DIMENSION(jpi,jpj) :: gamma_moist_vctr + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa + INTEGER :: ji, jj + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + gamma_moist_vctr(ji,jj) = gamma_moist_sclr( ptak(ji,jj), pqa(ji,jj) ) + END_2D + + END FUNCTION gamma_moist_vctr + + + FUNCTION One_on_L( ptha, pqa, pus, pts, pqs ) + !!------------------------------------------------------------------------ + !! + !! Evaluates the 1./(Obukhov length) from air temperature, + !! air specific humidity, and frictional scales u*, t* and q* + !! + !! Author: L. Brodeau, June 2019 / AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------------ + REAL(wp), DIMENSION(jpi,jpj) :: One_on_L !: 1./(Obukhov length) [m^-1] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha !: reference potential temperature of air [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa !: reference specific humidity of air [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus !: u*: friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pts, pqs !: \theta* and q* friction aka turb. scales for temp. and spec. hum. + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zqa ! local scalar + !!------------------------------------------------------------------- + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zqa = (1._wp + rctv0*pqa(ji,jj)) + ! + ! The main concern is to know whether, the vertical turbulent flux of virtual temperature, < u' theta_v' > is estimated with: + ! a/ -u* [ theta* (1 + 0.61 q) + 0.61 theta q* ] => this is the one that seems correct! chose this one! + ! or + ! b/ -u* [ theta* + 0.61 theta q* ] + ! + One_on_L(ji,jj) = grav*vkarmn*( pts(ji,jj)*zqa + rctv0*ptha(ji,jj)*pqs(ji,jj) ) & + & / MAX( pus(ji,jj)*pus(ji,jj)*ptha(ji,jj)*zqa , 1.E-9_wp ) + END_2D + ! + One_on_L = SIGN( MIN(ABS(One_on_L),200._wp), One_on_L ) ! (prevent FPE from stupid values over masked regions...) + ! + END FUNCTION One_on_L + + + FUNCTION Ri_bulk_sclr( pz, psst, ptha, pssq, pqa, pub, pta_layer, pqa_layer ) + !!---------------------------------------------------------------------------------- + !! Bulk Richardson number according to "wide-spread equation"... + !! + !! Reminder: the Richardson number is the ratio "buoyancy" / "shear" + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: Ri_bulk_sclr + REAL(wp), INTENT(in) :: pz ! height above the sea (aka "delta z") [m] + REAL(wp), INTENT(in) :: psst ! potential SST [K] + REAL(wp), INTENT(in) :: ptha ! pot. air temp. at height "pz" [K] + REAL(wp), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg] + REAL(wp), INTENT(in) :: pqa ! air spec. hum. at height "pz" [kg/kg] + REAL(wp), INTENT(in) :: pub ! bulk wind speed [m/s] + REAL(wp), INTENT(in), OPTIONAL :: pta_layer ! when possible, a better guess of absolute temperature WITHIN the layer [K] + REAL(wp), INTENT(in), OPTIONAL :: pqa_layer ! when possible, a better guess of specific humidity WITHIN the layer [kg/kg] + !! + LOGICAL :: l_ptqa_l_prvd = .FALSE. + REAL(wp) :: zqa, zta, zgamma, zdthv, ztv, zsstv ! local scalars + REAL(wp) :: ztptv + !!------------------------------------------------------------------- + IF( PRESENT(pta_layer) .AND. PRESENT(pqa_layer) ) l_ptqa_l_prvd = .TRUE. + ! + zsstv = virt_temp_sclr( psst, pssq ) ! virtual potential SST + ztptv = virt_temp_sclr( ptha, pqa ) ! virtual potential air temperature + zdthv = ztptv - zsstv ! air-sea delta of "virtual potential temperature" + ! + Ri_bulk_sclr = grav * zdthv * pz / ( ztptv * pub * pub ) ! the usual definition of Ri_bulk_sclr + ! + END FUNCTION Ri_bulk_sclr + + FUNCTION Ri_bulk_vctr( pz, psst, ptha, pssq, pqa, pub, pta_layer, pqa_layer ) + + REAL(wp), DIMENSION(jpi,jpj) :: Ri_bulk_vctr + REAL(wp) , INTENT(in) :: pz ! height above the sea (aka "delta z") [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! SST [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha ! pot. air temp. at height "pz" [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pssq ! 0.98*q_sat(SST) [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air spec. hum. at height "pz" [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub ! bulk wind speed [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pta_layer ! when possible, a better guess of absolute temperature WITHIN the layer [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pqa_layer ! when possible, a better guess of specific humidity WITHIN the layer [kg/kg] + !! + LOGICAL :: l_ptqa_l_prvd = .FALSE. + INTEGER :: ji, jj + + IF( PRESENT(pta_layer) .AND. PRESENT(pqa_layer) ) l_ptqa_l_prvd = .TRUE. + IF( l_ptqa_l_prvd ) THEN + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + Ri_bulk_vctr(ji,jj) = Ri_bulk_sclr( pz, psst(ji,jj), ptha(ji,jj), pssq(ji,jj), pqa(ji,jj), pub(ji,jj), & + & pta_layer=pta_layer(ji,jj ), pqa_layer=pqa_layer(ji,jj ) ) + END_2D + ELSE + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + Ri_bulk_vctr(ji,jj) = Ri_bulk_sclr( pz, psst(ji,jj), ptha(ji,jj), pssq(ji,jj), pqa(ji,jj), pub(ji,jj) ) + END_2D + END IF + + END FUNCTION Ri_bulk_vctr + + + FUNCTION e_sat_sclr( ptak ) + !!---------------------------------------------------------------------------------- + !! *** FUNCTION e_sat_sclr *** + !! < SCALAR argument version > + !! ** Purpose : water vapor at saturation in [Pa] + !! Based on accurate estimate by Goff, 1957 + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !! + !! Note: what rt0 should be here, is 273.16 (triple point of water) and not 273.15 like here + !!---------------------------------------------------------------------------------- + REAL(wp) :: e_sat_sclr ! water vapor at saturation [kg/kg] + REAL(wp), INTENT(in) :: ptak ! air temperature [K] + REAL(wp) :: zta, ztmp ! local scalar + !!---------------------------------------------------------------------------------- + zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... + ztmp = rt0 / zta !#LB: rt0 or rtt0 ???? (273.15 vs 273.16 ) + ! + ! Vapour pressure at saturation [Pa] : WMO, (Goff, 1957) + e_sat_sclr = 100.*( 10.**( 10.79574*(1. - ztmp) - 5.028*LOG10(zta/rt0) & + & + 1.50475*10.**(-4)*(1. - 10.**(-8.2969*(zta/rt0 - 1.)) ) & + & + 0.42873*10.**(-3)*(10.**(4.76955*(1. - ztmp)) - 1.) + 0.78614) ) + ! + END FUNCTION e_sat_sclr + + FUNCTION e_sat_vctr(ptak) + REAL(wp), DIMENSION(jpi,jpj) :: e_sat_vctr !: vapour pressure at saturation [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak !: temperature (K) + INTEGER :: ji, jj ! dummy loop indices + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + e_sat_vctr(ji,jj) = e_sat_sclr(ptak(ji,jj)) + END_2D + END FUNCTION e_sat_vctr + + + FUNCTION e_sat_ice_sclr(ptak) + !!--------------------------------------------------------------------------------- + !! Same as "e_sat" but over ice rather than water! + !!--------------------------------------------------------------------------------- + REAL(wp) :: e_sat_ice_sclr !: vapour pressure at saturation in presence of ice [Pa] + REAL(wp), INTENT(in) :: ptak + !! + REAL(wp) :: zta, zle, ztmp + !!--------------------------------------------------------------------------------- + zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... + ztmp = rtt0/zta + !! + zle = rAg_i*(ztmp - 1._wp) + rBg_i*LOG10(ztmp) + rCg_i*(1._wp - zta/rtt0) + rDg_i + !! + e_sat_ice_sclr = 100._wp * 10._wp**zle + + END FUNCTION e_sat_ice_sclr + + FUNCTION e_sat_ice_vctr(ptak) + !! Same as "e_sat" but over ice rather than water! + REAL(wp), DIMENSION(jpi,jpj) :: e_sat_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + e_sat_ice_vctr(ji,jj) = e_sat_ice_sclr( ptak(ji,jj) ) + END_2D + + END FUNCTION e_sat_ice_vctr + + + FUNCTION de_sat_dt_ice_sclr(ptak) + !!--------------------------------------------------------------------------------- + !! d [ e_sat_ice ] / dT (derivative / temperature) + !! Analytical exact formulation: double checked!!! + !! => DOUBLE-check possible / finite-difference version with "./bin/test_phymbl.x" + !!--------------------------------------------------------------------------------- + REAL(wp) :: de_sat_dt_ice_sclr !: [Pa/K] + REAL(wp), INTENT(in) :: ptak + !! + REAL(wp) :: zta, zde + !!--------------------------------------------------------------------------------- + zta = MAX( ptak , 180._wp ) ! air temp., prevents fpe0 errors dute to unrealistically low values over masked regions... + !! + zde = -(rAg_i*rtt0)/(zta*zta) - rBg_i/(zta*LOG(10._wp)) - rCg_i/rtt0 + !! + de_sat_dt_ice_sclr = LOG(10._wp) * zde * e_sat_ice_sclr(zta) + END FUNCTION de_sat_dt_ice_sclr + + FUNCTION de_sat_dt_ice_vctr(ptak) + !! Same as "e_sat" but over ice rather than water! + REAL(wp), DIMENSION(jpi,jpj) :: de_sat_dt_ice_vctr !: vapour pressure at saturation in presence of ice [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + de_sat_dt_ice_vctr(ji,jj) = de_sat_dt_ice_sclr( ptak(ji,jj) ) + END_2D + + END FUNCTION de_sat_dt_ice_vctr + + + FUNCTION q_sat_sclr( pta, ppa, l_ice ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION q_sat_sclr *** + !! + !! ** Purpose : Conputes specific humidity of air at saturation + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: q_sat_sclr + REAL(wp), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), INTENT(in) :: ppa !: atmospheric pressure [Pa] + LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice + REAL(wp) :: ze_s + LOGICAL :: lice + !!---------------------------------------------------------------------------------- + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + IF( lice ) THEN + ze_s = e_sat_ice( pta ) + ELSE + ze_s = e_sat( pta ) ! Vapour pressure at saturation (Goff) : + END IF + q_sat_sclr = reps0*ze_s/(ppa - (1._wp - reps0)*ze_s) + + END FUNCTION q_sat_sclr + + FUNCTION q_sat_vctr( pta, ppa, l_ice ) + + REAL(wp), DIMENSION(jpi,jpj) :: q_sat_vctr + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] + LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice + LOGICAL :: lice + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + q_sat_vctr(ji,jj) = q_sat_sclr( pta(ji,jj) , ppa(ji,jj), l_ice=lice ) + END_2D + + END FUNCTION q_sat_vctr + + + FUNCTION dq_sat_dt_ice_sclr( pta, ppa ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION dq_sat_dt_ice_sclr *** + !! => d [ q_sat_ice(T) ] / dT + !! Analytical exact formulation: double checked!!! + !! => DOUBLE-check possible / finite-difference version with "./bin/test_phymbl.x" + !!---------------------------------------------------------------------------------- + REAL(wp) :: dq_sat_dt_ice_sclr + REAL(wp), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), INTENT(in) :: ppa !: atmospheric pressure [Pa] + REAL(wp) :: ze_s, zde_s_dt, ztmp + !!---------------------------------------------------------------------------------- + ze_s = e_sat_ice_sclr( pta ) ! Vapour pressure at saturation in presence of ice (Goff) + zde_s_dt = de_sat_dt_ice( pta ) + ! + ztmp = (reps0 - 1._wp)*ze_s + ppa + ! + dq_sat_dt_ice_sclr = reps0*ppa*zde_s_dt / ( ztmp*ztmp ) + ! + END FUNCTION dq_sat_dt_ice_sclr + + FUNCTION dq_sat_dt_ice_vctr( pta, ppa ) + + REAL(wp), DIMENSION(jpi,jpj) :: dq_sat_dt_ice_vctr + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pta !: absolute temperature of air [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + dq_sat_dt_ice_vctr(ji,jj) = dq_sat_dt_ice_sclr( pta(ji,jj) , ppa(ji,jj) ) + END_2D + + END FUNCTION dq_sat_dt_ice_vctr + + + FUNCTION q_air_rh(prha, ptak, ppa) + !!---------------------------------------------------------------------------------- + !! Specific humidity of air out of Relative Humidity + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: q_air_rh + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prha !: relative humidity [fraction, not %!!!] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak !: air temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa !: atmospheric pressure [Pa] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: ze ! local scalar + !!---------------------------------------------------------------------------------- + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ze = prha(ji,jj)*e_sat_sclr(ptak(ji,jj)) + q_air_rh(ji,jj) = ze*reps0/(ppa(ji,jj) - (1. - reps0)*ze) + END_2D + ! + END FUNCTION q_air_rh + + + SUBROUTINE UPDATE_QNSOL_TAU( pzu, pTs, pqs, pTa, pqa, pust, ptst, pqst, pwnd, pUb, ppa, prlw, prhoa, & + & pQns, pTau, & + & Qlat) + !!---------------------------------------------------------------------------------- + !! Purpose: returns the non-solar heat flux to the ocean aka "Qlat + Qsen + Qlw" + !! and the module of the wind stress => pTau = Tau + !! ** Author: L. Brodeau, Sept. 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pust ! u* + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptst ! t* + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqst ! q* + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prlw ! downwelling longwave radiative flux [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prhoa ! air density [kg/m3] + ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQns ! non-solar heat flux to the ocean aka "Qlat + Qsen + Qlw" [W/m^2]] + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pTau ! module of the wind stress [N/m^2] + ! + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(out) :: Qlat + ! + REAL(wp) :: zdt, zdq, zCd, zCh, zCe, zz0, zQlat, zQsen, zQlw + INTEGER :: ji, jj ! dummy loop indices + !!---------------------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + + zdt = pTa(ji,jj) - pTs(ji,jj) ; zdt = SIGN( MAX(ABS(zdt),1.E-6_wp), zdt ) + zdq = pqa(ji,jj) - pqs(ji,jj) ; zdq = SIGN( MAX(ABS(zdq),1.E-9_wp), zdq ) + zz0 = pust(ji,jj)/pUb(ji,jj) + zCd = zz0*zz0 + zCh = zz0*ptst(ji,jj)/zdt + zCe = zz0*pqst(ji,jj)/zdq + + CALL bulk_formula( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), zCd, zCh, zCe, & + & pwnd(ji,jj), pUb(ji,jj), ppa(ji,jj), prhoa(ji,jj), & + & pTau(ji,jj), zQsen, zQlat ) + + zQlw = qlw_net_sclr( prlw(ji,jj), pTs(ji,jj) ) ! Net longwave flux + + pQns(ji,jj) = zQlat + zQsen + zQlw + + IF( PRESENT(Qlat) ) Qlat(ji,jj) = zQlat + + END_2D + + END SUBROUTINE UPDATE_QNSOL_TAU + + + SUBROUTINE bulk_formula_sclr( pzu, pTs, pqs, pTa, pqa, & + & pCd, pCh, pCe, & + & pwnd, pUb, ppa, prhoa, & + & pTau, pQsen, pQlat, & + & pEvap, pfact_evap ) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) + REAL(wp), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] + REAL(wp), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] + REAL(wp), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] + REAL(wp), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] + REAL(wp), INTENT(in) :: pCd + REAL(wp), INTENT(in) :: pCh + REAL(wp), INTENT(in) :: pCe + REAL(wp), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] + REAL(wp), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] + REAL(wp), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] + REAL(wp), INTENT(in) :: prhoa ! Air density at z=pzu [kg/m^3] + !! + REAL(wp), INTENT(out) :: pTau ! module of the wind stress [N/m^2] + REAL(wp), INTENT(out) :: pQsen ! [W/m^2] + REAL(wp), INTENT(out) :: pQlat ! [W/m^2] + !! + REAL(wp), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] + REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) + !! + REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap + INTEGER :: jq + !!---------------------------------------------------------------------------------- + zfact_evap = 1._wp + IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap + + zUrho = pUb*MAX(prhoa, 1._wp) ! rho*U10 + + pTau = zUrho * pCd * pwnd ! Wind stress module + + zevap = zUrho * pCe * (pqa - pqs) + pQsen = zUrho * pCh * (pTa - pTs) * cp_air(pqa) + pQlat = L_vap(pTs) * zevap + + IF( PRESENT(pEvap) ) pEvap = - zfact_evap * zevap + + END SUBROUTINE bulk_formula_sclr + + SUBROUTINE bulk_formula_vctr( pzu, pTs, pqs, pTa, pqa, & + & pCd, pCh, pCe, & + & pwnd, pUb, ppa, prhoa, & + & pTau, pQsen, pQlat, & + & pEvap, pfact_evap ) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pzu ! height above the sea-level where all this takes place (normally 10m) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTs ! water temperature at the air-sea interface [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqs ! satur. spec. hum. at T=pTs [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTa ! potential air temperature at z=pzu [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity at z=pzu [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCh + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCe + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed module at z=pzu [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb ! bulk wind speed at z=pzu (inc. pot. effect of gustiness etc) [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppa ! sea-level atmospheric pressure [Pa] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: prhoa ! Air density at z=pzu [kg/m^3] + !! + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pTau ! module of the wind stress [N/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQsen ! [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: pQlat ! [W/m^2] + !! + REAL(wp), DIMENSION(jpi,jpj), INTENT(out), OPTIONAL :: pEvap ! Evaporation [kg/m^2/s] + REAL(wp), INTENT(in) , OPTIONAL :: pfact_evap ! ABOMINATION: corrective factor for evaporation (doing this against my will! /laurent) + !! + REAL(wp) :: ztaa, zgamma, zrho, zUrho, zevap, zfact_evap + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + zfact_evap = 1._wp + IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + + CALL bulk_formula_sclr( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), & + & pCd(ji,jj), pCh(ji,jj), pCe(ji,jj), & + & pwnd(ji,jj), pUb(ji,jj), ppa(ji,jj), prhoa(ji,jj), & + & pTau(ji,jj), pQsen(ji,jj), pQlat(ji,jj), & + & pEvap=zevap, pfact_evap=zfact_evap ) + + IF( PRESENT(pEvap) ) pEvap(ji,jj) = zevap + END_2D + + END SUBROUTINE bulk_formula_vctr + + + FUNCTION alpha_sw_vctr( psst ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION alpha_sw_vctr *** + !! + !! ** Purpose : ROUGH estimate of the thermal expansion coefficient of sea-water at the surface (P =~ 1010 hpa) + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: alpha_sw_vctr ! thermal expansion coefficient of sea-water [1/K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! water temperature [K] + !!---------------------------------------------------------------------------------- + alpha_sw_vctr = 2.1e-5_wp * MAX(psst(:,:)-rt0 + 3.2_wp, 0._wp)**0.79 + + END FUNCTION alpha_sw_vctr + + FUNCTION alpha_sw_sclr( psst ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION alpha_sw_sclr *** + !! + !! ** Purpose : ROUGH estimate of the thermal expansion coefficient of sea-water at the surface (P =~ 1010 hpa) + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp) :: alpha_sw_sclr ! thermal expansion coefficient of sea-water [1/K] + REAL(wp), INTENT(in) :: psst ! sea-water temperature [K] + !!---------------------------------------------------------------------------------- + alpha_sw_sclr = 2.1e-5_wp * MAX(psst-rt0 + 3.2_wp, 0._wp)**0.79 + + END FUNCTION alpha_sw_sclr + + + FUNCTION qlw_net_sclr( pdwlw, pts, l_ice ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION qlw_net_sclr *** + !! + !! ** Purpose : Estimate of the net longwave flux at the surface + !!---------------------------------------------------------------------------------- + REAL(wp) :: qlw_net_sclr + REAL(wp), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2] + REAL(wp), INTENT(in) :: pts !: surface temperature [K] + LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice + REAL(wp) :: zemiss, zt2 + LOGICAL :: lice + !!---------------------------------------------------------------------------------- + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + IF( lice ) THEN + zemiss = emiss_i + ELSE + zemiss = emiss_w + END IF + zt2 = pts*pts + qlw_net_sclr = zemiss*( pdwlw - stefan*zt2*zt2) ! zemiss used both as the IR albedo and IR emissivity... + + END FUNCTION qlw_net_sclr + + FUNCTION qlw_net_vctr( pdwlw, pts, l_ice ) + + REAL(wp), DIMENSION(jpi,jpj) :: qlw_net_vctr + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pdwlw !: downwelling longwave (aka infrared, aka thermal) radiation [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pts !: surface temperature [K] + LOGICAL, INTENT(in), OPTIONAL :: l_ice !: we are above ice + LOGICAL :: lice + INTEGER :: ji, jj + !!---------------------------------------------------------------------------------- + lice = .FALSE. + IF( PRESENT(l_ice) ) lice = l_ice + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + qlw_net_vctr(ji,jj) = qlw_net_sclr( pdwlw(ji,jj) , pts(ji,jj), l_ice=lice ) + END_2D + + END FUNCTION qlw_net_vctr + + + FUNCTION z0_from_Cd( pzu, pCd, ppsi ) + + REAL(wp), DIMENSION(jpi,jpj) :: z0_from_Cd !: roughness length [m] + REAL(wp) , INTENT(in) :: pzu !: reference height zu [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: (neutral or non-neutral) drag coefficient [] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + !! + !! If pCd is the NEUTRAL-STABILITY drag coefficient then ppsi must be 0 or not given + !! If pCd is the drag coefficient (in stable or unstable conditions) then pssi must be provided + !!---------------------------------------------------------------------------------- + IF( PRESENT(ppsi) ) THEN + !! Cd provided is the actual Cd (not the neutral-stability CdN) : + z0_from_Cd = pzu * EXP( - ( vkarmn/SQRT(pCd(:,:)) + ppsi(:,:) ) ) !LB: ok, double-checked! + ELSE + !! Cd provided is the neutral-stability Cd, aka CdN : + z0_from_Cd = pzu * EXP( - vkarmn/SQRT(pCd(:,:)) ) !LB: ok, double-checked! + END IF + + END FUNCTION z0_from_Cd + + + FUNCTION Cd_from_z0( pzu, pz0, ppsi ) + + REAL(wp), DIMENSION(jpi,jpj) :: Cd_from_z0 !: (neutral or non-neutral) drag coefficient [] + REAL(wp) , INTENT(in) :: pzu !: reference height zu [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + !! + !! If we want to return the NEUTRAL-STABILITY drag coefficient then ppsi must be 0 or not given + !! If we want to return the stability-corrected Cd (i.e. in stable or unstable conditions) then pssi must be provided + !!---------------------------------------------------------------------------------- + IF( PRESENT(ppsi) ) THEN + !! The Cd we return is the actual Cd (not the neutral-stability CdN) : + Cd_from_z0 = 1._wp / ( LOG( pzu / pz0(:,:) ) - ppsi(:,:) ) + ELSE + !! The Cd we return is the neutral-stability Cd, aka CdN : + Cd_from_z0 = 1._wp / LOG( pzu / pz0(:,:) ) + END IF + Cd_from_z0 = vkarmn2 * Cd_from_z0 * Cd_from_z0 + + END FUNCTION Cd_from_z0 + + + FUNCTION f_m_louis_sclr( pzu, pRib, pCdn, pz0 ) + !!---------------------------------------------------------------------------------- + !! Stability correction function for MOMENTUM + !! Louis (1979) + !!---------------------------------------------------------------------------------- + REAL(wp) :: f_m_louis_sclr ! term "f_m" in Eq.(6) when option "Louis" rather than "Psi(zeta) is chosen, Lupkes & Gryanik (2015), + REAL(wp), INTENT(in) :: pzu ! reference height (height for pwnd) [m] + REAL(wp), INTENT(in) :: pRib ! Bulk Richardson number + REAL(wp), INTENT(in) :: pCdn ! neutral drag coefficient + REAL(wp), INTENT(in) :: pz0 ! roughness length [m] + !!---------------------------------------------------------------------------------- + REAL(wp) :: ztu, zts, zstab + !!---------------------------------------------------------------------------------- + zstab = 0.5 + SIGN(0.5_wp, pRib) ; ! Unstable (Ri<0) => zstab = 0 | Stable (Ri>0) => zstab = 1 + ! + ztu = pRib / ( 1._wp + 3._wp * rc2_louis * pCdn * SQRT( ABS( -pRib * ( pzu / pz0 + 1._wp) ) ) ) ! ABS is just here for when it's stable conditions and ztu is not used anyways + zts = pRib / SQRT( ABS( 1._wp + pRib ) ) ! ABS is just here for when it's UNstable conditions and zts is not used anyways + ! + f_m_louis_sclr = (1._wp - zstab) * ( 1._wp - ram_louis * ztu ) & ! Unstable Eq.(A6) + & + zstab * 1._wp / ( 1._wp + ram_louis * zts ) ! Stable Eq.(A7) + ! + END FUNCTION f_m_louis_sclr + + FUNCTION f_m_louis_vctr( pzu, pRib, pCdn, pz0 ) + + REAL(wp), DIMENSION(jpi,jpj) :: f_m_louis_vctr + REAL(wp), INTENT(in) :: pzu + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRib + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCdn + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 + INTEGER :: ji, jj + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + f_m_louis_vctr(ji,jj) = f_m_louis_sclr( pzu, pRib(ji,jj), pCdn(ji,jj), pz0(ji,jj) ) + END_2D + + END FUNCTION f_m_louis_vctr + + + FUNCTION f_h_louis_sclr( pzu, pRib, pChn, pz0 ) + !!---------------------------------------------------------------------------------- + !! Stability correction function for HEAT + !! Louis (1979) + !!---------------------------------------------------------------------------------- + REAL(wp) :: f_h_louis_sclr ! term "f_h" in Eq.(6) when option "Louis" rather than "Psi(zeta) is chosen, Lupkes & Gryanik (2015), + REAL(wp), INTENT(in) :: pzu ! reference height (height for pwnd) [m] + REAL(wp), INTENT(in) :: pRib ! Bulk Richardson number + REAL(wp), INTENT(in) :: pChn ! neutral heat transfer coefficient + REAL(wp), INTENT(in) :: pz0 ! roughness length [m] + !!---------------------------------------------------------------------------------- + REAL(wp) :: ztu, zts, zstab + !!---------------------------------------------------------------------------------- + zstab = 0.5 + SIGN(0.5_wp, pRib) ; ! Unstable (Ri<0) => zstab = 0 | Stable (Ri>0) => zstab = 1 + ! + ztu = pRib / ( 1._wp + 3._wp * rc2_louis * pChn * SQRT( ABS(-pRib * ( pzu / pz0 + 1._wp) ) ) ) + zts = pRib / SQRT( ABS( 1._wp + pRib ) ) + ! + f_h_louis_sclr = (1._wp - zstab) * ( 1._wp - rah_louis * ztu ) & ! Unstable Eq.(A6) + & + zstab * 1._wp / ( 1._wp + rah_louis * zts ) ! Stable Eq.(A7) !#LB: in paper it's "ram_louis" and not "rah_louis" typo or what???? + ! + END FUNCTION f_h_louis_sclr + + FUNCTION f_h_louis_vctr( pzu, pRib, pChn, pz0 ) + + REAL(wp), DIMENSION(jpi,jpj) :: f_h_louis_vctr + REAL(wp), INTENT(in) :: pzu + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRib + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pChn + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 + INTEGER :: ji, jj + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + f_h_louis_vctr(ji,jj) = f_h_louis_sclr( pzu, pRib(ji,jj), pChn(ji,jj), pz0(ji,jj) ) + END_2D + + END FUNCTION f_h_louis_vctr + + + FUNCTION UN10_from_ustar( pzu, pUzu, pus, ppsi ) + !!---------------------------------------------------------------------------------- + !! Provides the neutral-stability wind speed at 10 m + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: UN10_from_ustar !: neutral stability wind speed at 10m [m/s] + REAL(wp), INTENT(in) :: pzu !: measurement heigh of wind speed [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUzu !: bulk wind speed at height pzu m [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus !: friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + !!---------------------------------------------------------------------------------- + UN10_from_ustar(:,:) = pUzu(:,:) - pus(:,:)/vkarmn * ( LOG(pzu/10._wp) - ppsi(:,:) ) + !! + END FUNCTION UN10_from_ustar + + + FUNCTION UN10_from_CD( pzu, pUb, pCd, ppsi ) + !!---------------------------------------------------------------------------------- + !! Provides the neutral-stability wind speed at 10 m + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: UN10_from_CD !: [m/s] + REAL(wp), INTENT(in) :: pzu !: measurement heigh of bulk wind speed + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pUb !: bulk wind speed at height pzu m [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pCd !: drag coefficient + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ppsi !: "Psi_m(pzu/L)" stability correction profile for momentum [] + !!---------------------------------------------------------------------------------- + !! Reminder: UN10 = u*/vkarmn * log(10/z0) + !! and: u* = sqrt(Cd) * Ub + !! u*/vkarmn * log( 10 / z0 ) + UN10_from_CD(:,:) = SQRT(pCd(:,:))*pUb/vkarmn * LOG( 10._wp / z0_from_Cd( pzu, pCd(:,:), ppsi=ppsi(:,:) ) ) + !! + END FUNCTION UN10_from_CD + + + FUNCTION z0tq_LKB( iflag, pRer, pz0 ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION z0tq_LKB *** + !! + !! ** Purpose : returns the "temperature/humidity roughness lengths" + !! * iflag==1 => temperature => returns: z_{0t} + !! * iflag==2 => humidity => returns: z_{0q} + !! from roughness reynold number "pRer" (i.e. [z_0 u*]/Nu_{air}) + !! between 0 and 1000. Out of range "pRer" indicated by prt=-999. + !! and roughness length (for momentum) + !! + !! Based on Liu et al. (1979) JAS 36 1722-1723s + !! + !! Note: this is what is used into COARE 2.5 to estimate z_{0t} and z_{0q} + !! + !! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: z0tq_LKB + INTEGER, INTENT(in) :: iflag !: 1 => dealing with temperature; 2 => dealing with humidity + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pRer !: roughness Reynolds number [z_0 u*]/Nu_{air} + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 !: roughness length (for momentum) [m] + !------------------------------------------------------------------- + ! Scalar Re_r relation from Liu et al. + REAL(wp), DIMENSION(8,2), PARAMETER :: & + & XA = RESHAPE( (/ 0.177, 1.376, 1.026, 1.625, 4.661, 34.904, 1667.19, 5.88e5, & + & 0.292, 1.808, 1.393, 1.956, 4.994, 30.709, 1448.68, 2.98e5 /), (/8,2/) ) + !! + REAL(wp), DIMENSION(8,2), PARAMETER :: & + & XB = RESHAPE( (/ 0., 0.929, -0.599, -1.018, -1.475, -2.067, -2.907, -3.935, & + & 0., 0.826, -0.528, -0.870, -1.297, -1.845, -2.682, -3.616 /), (/8,2/) ) + !! + REAL(wp), DIMENSION(0:8), PARAMETER :: & + & XRAN = (/ 0., 0.11, 0.825, 3.0, 10.0, 30.0, 100., 300., 1000. /) + !------------------------------------------------------------------- + ! + !------------------------------------------------------------------- + ! Scalar Re_r relation from Moana Wave data. + ! + ! real*8 A(9,2),B(9,2),RAN(9),pRer,prt + ! integer iflag + ! DATA A/0.177,2.7e3,1.03,1.026,1.625,4.661,34.904,1667.19,5.88E5, + ! & 0.292,3.7e3,1.4,1.393,1.956,4.994,30.709,1448.68,2.98E5/ + ! DATA B/0.,4.28,0,-0.599,-1.018,-1.475,-2.067,-2.907,-3.935, + ! & 0.,4.28,0,-0.528,-0.870,-1.297,-1.845,-2.682,-3.616/ + ! DATA RAN/0.11,.16,1.00,3.0,10.0,30.0,100.,300.,1000./ + !------------------------------------------------------------------- + + LOGICAL :: lfound=.FALSE. + REAL(wp) :: zrr + INTEGER :: ji, jj, jm + + z0tq_LKB(:,:) = -999._wp + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + + zrr = pRer(ji,jj) + lfound = .FALSE. + + IF( (zrr > 0.).AND.(zrr < 1000.) ) THEN + jm = 0 + DO WHILE ( .NOT. lfound ) + jm = jm + 1 + lfound = ( (zrr > XRAN(jm-1)) .AND. (zrr <= XRAN(jm)) ) + END DO + + z0tq_LKB(ji,jj) = XA(jm,iflag)*zrr**XB(jm,iflag) * pz0(ji,jj)/zrr + + END IF + + END_2D + + z0tq_LKB(:,:) = MIN( MAX(ABS(z0tq_LKB(:,:)), 1.E-9) , 0.05_wp ) + + END FUNCTION z0tq_LKB + + + +END MODULE sbc_phy \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcabl.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcabl.F90 new file mode 100644 index 0000000..3ac8f37 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcabl.F90 @@ -0,0 +1,51 @@ +MODULE sbcabl + !!====================================================================== + !! *** MODULE sbcabl *** + !! Ocean forcing: momentum, heat and freshwater flux formulation + !! derived from an ABL model + !!===================================================================== + !! History : 4.0 ! 2019-03 (F. Lemarié & G. Samson) Original code + !!---------------------------------------------------------------------- + USE sbc_oce, ONLY : ght_abl, ghw_abl, e3t_abl, e3w_abl + USE lib_mpp, ONLY : ctl_stop + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_abl_init ! routine called in sbcmod module + PUBLIC sbc_abl ! routine called in sbcmod module + + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.7 , NEMO-consortium (2014) + !! $Id: sbcabl.F90 6416 2016-04-01 12:22:17Z clem $ + !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_abl_init + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_abl_init *** + !! + !! ** Purposes : dummy routine for compilation + !! + !!---------------------------------------------------------------------- + CALL ctl_stop( 'STOP', 'ln_abl = .true. but ABL source directory was not included', & + & '(Either switch to ln_abl = .false. or modify your cfg.txt file and recompile)' ) + !! + END SUBROUTINE sbc_abl_init + + + SUBROUTINE sbc_abl( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_abl *** + !! + !! ** Purposes : dummy routine for compilation + !! + !!--------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time step + !! + END SUBROUTINE sbc_abl + + + !!====================================================================== +END MODULE sbcabl \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcapr.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcapr.F90 new file mode 100644 index 0000000..30af75b --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcapr.F90 @@ -0,0 +1,171 @@ +MODULE sbcapr + !!====================================================================== + !! *** MODULE sbcapr *** + !! Surface module : atmospheric pressure forcing + !!====================================================================== + !! History : 3.3 ! 2010-09 (J. Chanut, C. Bricaud, G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_apr : read atmospheric pressure in netcdf files + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface boundary condition + USE phycst ! physical constants + ! + USE fldread ! read input fields + USE in_out_manager ! I/O manager + USE lib_fortran ! distribued memory computing library + USE iom ! IOM library + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_apr ! routine called in sbcmod + PUBLIC sbc_apr_init ! routine called in sbcmod + + ! !!* namsbc_apr namelist (Atmospheric PRessure) * + LOGICAL, PUBLIC :: ln_apr_obc = .false. !: inverse barometer added to OBC ssh data + LOGICAL, PUBLIC :: ln_ref_apr !: ref. pressure: global mean Patm (F) or a constant (F) + REAL(wp) :: rn_pref ! reference atmospheric pressure [N/m2] + + REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: ssh_ib ! Inverse barometer now sea surface height [m] + REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: ssh_ibb ! Inverse barometer before sea surface height [m] + REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: apr ! atmospheric pressure at kt [N/m2] + + REAL(wp) :: tarea ! whole domain mean masked ocean surface + REAL(wp) :: r1_grau ! = 1.e0 / (grav * rho0) + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_apr ! structure of input fields (file informations, fields read) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcapr.F90 14072 2020-12-04 07:48:38Z laurent $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_apr_init + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_apr *** + !! + !! ** Purpose : read atmospheric pressure fields in netcdf files. + !! + !! ** Method : - Read namelist namsbc_apr + !! - Read Patm fields in netcdf files + !! - Compute reference atmospheric pressure + !! - Compute inverse barometer ssh + !! ** action : apr : atmospheric pressure at kt + !! ssh_ib : inverse barometer ssh at kt + !!--------------------------------------------------------------------- + INTEGER :: ierror ! local integer + INTEGER :: ios ! Local integer output status for namelist read + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files + TYPE(FLD_N) :: sn_apr ! informations about the fields to be read + !! + NAMELIST/namsbc_apr/ cn_dir, sn_apr, ln_ref_apr, rn_pref, ln_apr_obc + !!---------------------------------------------------------------------- + READ ( numnam_ref, namsbc_apr, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_apr in reference namelist' ) + + READ ( numnam_cfg, namsbc_apr, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_apr in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_apr ) + ! + ALLOCATE( sf_apr(1), STAT=ierror ) !* allocate and fill sf_sst (forcing structure) with sn_sst + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_apr: unable to allocate sf_apr structure' ) + ! + CALL fld_fill( sf_apr, (/ sn_apr /), cn_dir, 'sbc_apr', 'Atmospheric pressure ', 'namsbc_apr' ) + ALLOCATE( sf_apr(1)%fnow(jpi,jpj,1) ) + IF( sn_apr%ln_tint ) ALLOCATE( sf_apr(1)%fdta(jpi,jpj,1,2) ) + ALLOCATE( ssh_ib(jpi,jpj) , ssh_ibb(jpi,jpj) ) + ALLOCATE( apr (jpi,jpj) ) + ! + IF( lwp )THEN !* control print + WRITE(numout,*) + WRITE(numout,*) ' Namelist namsbc_apr : Atmospheric PRessure as extrenal forcing' + WRITE(numout,*) ' ref. pressure: global mean Patm (T) or a constant (F) ln_ref_apr = ', ln_ref_apr + ENDIF + ! + IF( ln_ref_apr ) THEN !* Compute whole inner domain mean masked ocean surface + tarea = glob_sum( 'sbcapr', e1e2t(:,:) ) + IF(lwp) WRITE(numout,*) ' Variable ref. Patm computed over a ocean surface of ', tarea*1e-6, 'km2' + ELSE + IF(lwp) WRITE(numout,*) ' Reference Patm used : ', rn_pref, ' N/m2' + ENDIF + ! + r1_grau = 1.e0 / (grav * rho0) !* constant for optimization + ! + ! !* control check + IF( ln_apr_obc ) THEN + IF(lwp) WRITE(numout,*) ' Inverse barometer added to OBC ssh data' + ENDIF +!jc: stop below should rather be a warning + IF( ln_apr_obc .AND. .NOT.ln_apr_dyn ) & + CALL ctl_warn( 'sbc_apr: use inverse barometer ssh at open boundary ONLY requires ln_apr_dyn=T' ) + ! + END SUBROUTINE sbc_apr_init + + SUBROUTINE sbc_apr( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_apr *** + !! + !! ** Purpose : read atmospheric pressure fields in netcdf files. + !! + !! ** Method : - Read namelist namsbc_apr + !! - Read Patm fields in netcdf files + !! - Compute reference atmospheric pressure + !! - Compute inverse barometer ssh + !! ** action : apr : atmospheric pressure at kt + !! ssh_ib : inverse barometer ssh at kt + !!--------------------------------------------------------------------- + INTEGER, INTENT(in):: kt ! ocean time step + ! + !!---------------------------------------------------------------------- + + ! ! ========================== ! + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! At each sbc time-step ! + ! ! ===========+++============ ! + ! + IF( kt /= nit000 ) ssh_ibb(:,:) = ssh_ib(:,:) !* Swap of ssh_ib fields + ! + CALL fld_read( kt, nn_fsbc, sf_apr ) !* input Patm provided at kt + nn_fsbc/2 + ! + ! !* update the reference atmospheric pressure (if necessary) + IF( ln_ref_apr ) rn_pref = glob_sum( 'sbcapr', sf_apr(1)%fnow(:,:,1) * e1e2t(:,:) ) / tarea + ! + ! !* Patm related forcing at kt + ssh_ib(:,:) = - ( sf_apr(1)%fnow(:,:,1) - rn_pref ) * r1_grau ! equivalent ssh (inverse barometer) + apr (:,:) = sf_apr(1)%fnow(:,:,1) ! atmospheric pressure + ! + CALL iom_put( "ssh_ib", ssh_ib ) !* output the inverse barometer ssh + ENDIF + + ! ! ---------------------------------------- ! + IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! + ! ! ---------------------------------------- ! + ! !* Restart: read in restart file + IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN + IF(lwp) WRITE(numout,*) 'sbc_apr: ssh_ibb read in the restart file' + CALL iom_get( numror, jpdom_auto, 'ssh_ibb', ssh_ibb ) ! before inv. barometer ssh + ! + ELSE !* no restart: set from nit000 values + IF(lwp) WRITE(numout,*) 'sbc_apr: ssh_ibb set to nit000 values' + ssh_ibb(:,:) = ssh_ib(:,:) + ENDIF + ENDIF + ! ! ---------------------------------------- ! + IF( lrst_oce ) THEN ! Write in the ocean restart file ! + ! ! ---------------------------------------- ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc_apr : ssh_ib written in ocean restart file at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~' + CALL iom_rstput( kt, nitrst, numrow, 'ssh_ibb' , ssh_ib ) + ENDIF + ! + END SUBROUTINE sbc_apr + + !!====================================================================== +END MODULE sbcapr \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk.F90 new file mode 100644 index 0000000..8d366cb --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk.F90 @@ -0,0 +1,1417 @@ +MODULE sbcblk + !!====================================================================== + !! *** MODULE sbcblk *** + !! Ocean forcing: momentum, heat and freshwater flux formulation + !! Aerodynamic Bulk Formulas + !! SUCCESSOR OF "sbcblk_core" + !!===================================================================== + !! History : 1.0 ! 2004-08 (U. Schweckendiek) Original CORE code + !! 2.0 ! 2005-04 (L. Brodeau, A.M. Treguier) improved CORE bulk and its user interface + !! 3.0 ! 2006-06 (G. Madec) sbc rewritting + !! - ! 2006-12 (L. Brodeau) Original code for turb_core + !! 3.2 ! 2009-04 (B. Lemaire) Introduce iom_put + !! 3.3 ! 2010-10 (S. Masson) add diurnal cycle + !! 3.4 ! 2011-11 (C. Harris) Fill arrays required by CICE + !! 3.7 ! 2014-06 (L. Brodeau) simplification and optimization of CORE bulk + !! 4.0 ! 2016-06 (L. Brodeau) sbcblk_core becomes sbcblk and is not restricted to the CORE algorithm anymore + !! ! ==> based on AeroBulk (https://github.com/brodeau/aerobulk/) + !! 4.0 ! 2016-10 (G. Madec) introduce a sbc_blk_init routine + !! 4.0 ! 2016-10 (M. Vancoppenolle) Introduce conduction flux emulator (M. Vancoppenolle) + !! 4.0 ! 2019-03 (F. Lemarié & G. Samson) add ABL compatibility (ln_abl=TRUE) + !! 4.2 ! 2020-12 (L. Brodeau) Introduction of various air-ice bulk parameterizations + improvements + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_blk_init : initialisation of the chosen bulk formulation as ocean surface boundary condition + !! sbc_blk : bulk formulation as ocean surface boundary condition + !! blk_oce_1 : computes pieces of momentum, heat and freshwater fluxes over ocean for ABL model (ln_abl=TRUE) + !! blk_oce_2 : finalizes momentum, heat and freshwater fluxes computation over ocean after the ABL step (ln_abl=TRUE) + !! sea-ice case only : + !! blk_ice_1 : provide the air-ice stress + !! blk_ice_2 : provide the heat and mass fluxes at air-ice interface + !! blk_ice_qcn : provide ice surface temperature and snow/ice conduction flux (emulating conduction flux) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE fldread ! read input fields + USE sbc_oce ! Surface boundary condition: ocean fields + USE trc_oce ! share SMS/Ocean variables + USE cyclone ! Cyclone 10m wind form trac of cyclone centres + USE sbcdcy ! surface boundary condition: diurnal cycle + USE sbcwave , ONLY : cdn_wave ! wave module + USE lib_fortran ! to use key_nosignedzero and glob_sum + ! +#if defined key_si3 + USE sbc_ice ! Surface boundary condition: ice fields #LB? ok to be in 'key_si3' ??? + USE ice , ONLY : u_ice, v_ice, jpl, a_i_b, at_i_b, t_su, rn_cnd_s, hfx_err_dif, nn_qtrice + USE icevar ! for CALL ice_var_snwblow + USE sbcblk_algo_ice_an05 + USE sbcblk_algo_ice_lu12 + USE sbcblk_algo_ice_lg15 +#endif + USE sbcblk_algo_ncar ! => turb_ncar : NCAR - (formerly known as CORE, Large & Yeager, 2009) + USE sbcblk_algo_coare3p0 ! => turb_coare3p0 : COAREv3.0 (Fairall et al. 2003) + USE sbcblk_algo_coare3p6 ! => turb_coare3p6 : COAREv3.6 (Fairall et al. 2018 + Edson et al. 2013) + USE sbcblk_algo_ecmwf ! => turb_ecmwf : ECMWF (IFS cycle 45r1) + USE sbcblk_algo_andreas ! => turb_andreas : Andreas et al. 2015 + ! + USE iom ! I/O manager library + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_blk_init ! called in sbcmod + PUBLIC sbc_blk ! called in sbcmod + PUBLIC blk_oce_1 ! called in sbcabl + PUBLIC blk_oce_2 ! called in sbcabl +#if defined key_si3 + PUBLIC blk_ice_1 ! routine called in icesbc + PUBLIC blk_ice_2 ! routine called in icesbc + PUBLIC blk_ice_qcn ! routine called in icesbc +#endif + + INTEGER , PUBLIC, PARAMETER :: jp_wndi = 1 ! index of 10m wind velocity (i-component) (m/s) at T-point + INTEGER , PUBLIC, PARAMETER :: jp_wndj = 2 ! index of 10m wind velocity (j-component) (m/s) at T-point + INTEGER , PUBLIC, PARAMETER :: jp_tair = 3 ! index of 10m air temperature (Kelvin) + INTEGER , PUBLIC, PARAMETER :: jp_humi = 4 ! index of specific humidity (kg/kg) + INTEGER , PUBLIC, PARAMETER :: jp_qsr = 5 ! index of solar heat (W/m2) + INTEGER , PUBLIC, PARAMETER :: jp_qlw = 6 ! index of Long wave (W/m2) + INTEGER , PUBLIC, PARAMETER :: jp_prec = 7 ! index of total precipitation (rain+snow) (Kg/m2/s) + INTEGER , PUBLIC, PARAMETER :: jp_snow = 8 ! index of snow (solid prcipitation) (kg/m2/s) + INTEGER , PUBLIC, PARAMETER :: jp_slp = 9 ! index of sea level pressure (Pa) + INTEGER , PUBLIC, PARAMETER :: jp_uoatm = 10 ! index of surface current (i-component) + ! ! seen by the atmospheric forcing (m/s) at T-point + INTEGER , PUBLIC, PARAMETER :: jp_voatm = 11 ! index of surface current (j-component) + ! ! seen by the atmospheric forcing (m/s) at T-point + INTEGER , PUBLIC, PARAMETER :: jp_cc = 12 ! index of cloud cover (-) range:0-1 + INTEGER , PUBLIC, PARAMETER :: jp_hpgi = 13 ! index of ABL geostrophic wind or hpg (i-component) (m/s) at T-point + INTEGER , PUBLIC, PARAMETER :: jp_hpgj = 14 ! index of ABL geostrophic wind or hpg (j-component) (m/s) at T-point + INTEGER , PUBLIC, PARAMETER :: jpfld = 14 ! maximum number of files to read + + ! Warning: keep this structure allocatable for Agrif... + TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:) :: sf ! structure of input atmospheric fields (file informations, fields read) + + ! !!* Namelist namsbc_blk : bulk parameters + LOGICAL :: ln_NCAR ! "NCAR" algorithm (Large and Yeager 2008) + LOGICAL :: ln_COARE_3p0 ! "COARE 3.0" algorithm (Fairall et al. 2003) + LOGICAL :: ln_COARE_3p6 ! "COARE 3.6" algorithm (Edson et al. 2013) + LOGICAL :: ln_ECMWF ! "ECMWF" algorithm (IFS cycle 45r1) + LOGICAL :: ln_ANDREAS ! "ANDREAS" algorithm (Andreas et al. 2015) + ! + !#LB: + LOGICAL :: ln_Cx_ice_cst ! use constant air-ice bulk transfer coefficients (value given in namelist's rn_Cd_i, rn_Ce_i & rn_Ch_i) + REAL(wp) :: rn_Cd_i, rn_Ce_i, rn_Ch_i ! values for " " + LOGICAL :: ln_Cx_ice_AN05 ! air-ice bulk transfer coefficients based on Andreas et al., 2005 + LOGICAL :: ln_Cx_ice_LU12 ! air-ice bulk transfer coefficients based on Lupkes et al., 2012 + LOGICAL :: ln_Cx_ice_LG15 ! air-ice bulk transfer coefficients based on Lupkes & Gryanik, 2015 + !#LB. + ! + LOGICAL :: ln_crt_fbk ! Add surface current feedback to the wind stress computation (Renault et al. 2020) + REAL(wp) :: rn_stau_a ! Alpha and Beta coefficients of Renault et al. 2020, eq. 10: Stau = Alpha * Wnd + Beta + REAL(wp) :: rn_stau_b ! + ! + REAL(dp) :: rn_pfac ! multiplication factor for precipitation + REAL(wp), PUBLIC :: rn_efac ! multiplication factor for evaporation + REAL(wp) :: rn_zqt ! z(q,t) : height of humidity and temperature measurements + REAL(wp) :: rn_zu ! z(u) : height of wind measurements + ! + INTEGER :: nn_iter_algo ! Number of iterations in bulk param. algo ("stable ABL + weak wind" requires more) + + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: theta_zu, q_zu ! air temp. and spec. hum. at wind speed height (L15 bulk scheme) + +#if defined key_si3 + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: Cd_ice , Ch_ice , Ce_ice !#LB transfert coefficients over ice + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: theta_zu_i, q_zu_i !#LB fixme ! air temp. and spec. hum. over ice at wind speed height (L15 bulk scheme) +#endif + + + LOGICAL :: ln_skin_cs ! use the cool-skin (only available in ECMWF and COARE algorithms) !LB + LOGICAL :: ln_skin_wl ! use the warm-layer parameterization (only available in ECMWF and COARE algorithms) !LB + LOGICAL :: ln_humi_sph ! humidity read in files ("sn_humi") is specific humidity [kg/kg] if .true. !LB + LOGICAL :: ln_humi_dpt ! humidity read in files ("sn_humi") is dew-point temperature [K] if .true. !LB + LOGICAL :: ln_humi_rlh ! humidity read in files ("sn_humi") is relative humidity [%] if .true. !LB + LOGICAL :: ln_tair_pot ! temperature read in files ("sn_tair") is already potential temperature (not absolute) + ! + INTEGER :: nhumi ! choice of the bulk algorithm + ! ! associated indices: + INTEGER, PARAMETER :: np_humi_sph = 1 + INTEGER, PARAMETER :: np_humi_dpt = 2 + INTEGER, PARAMETER :: np_humi_rlh = 3 + + INTEGER :: nblk ! choice of the bulk algorithm + ! ! associated indices: + INTEGER, PARAMETER :: np_NCAR = 1 ! "NCAR" algorithm (Large and Yeager 2008) + INTEGER, PARAMETER :: np_COARE_3p0 = 2 ! "COARE 3.0" algorithm (Fairall et al. 2003) + INTEGER, PARAMETER :: np_COARE_3p6 = 3 ! "COARE 3.6" algorithm (Edson et al. 2013) + INTEGER, PARAMETER :: np_ECMWF = 4 ! "ECMWF" algorithm (IFS cycle 45r1) + INTEGER, PARAMETER :: np_ANDREAS = 5 ! "ANDREAS" algorithm (Andreas et al. 2015) + + !#LB: +#if defined key_si3 + ! Same, over sea-ice: + INTEGER :: nblk_ice ! choice of the bulk algorithm + ! ! associated indices: + INTEGER, PARAMETER :: np_ice_cst = 1 ! constant transfer coefficients + INTEGER, PARAMETER :: np_ice_an05 = 2 ! Andreas et al., 2005 + INTEGER, PARAMETER :: np_ice_lu12 = 3 ! Lupkes el al., 2012 + INTEGER, PARAMETER :: np_ice_lg15 = 4 ! Lupkes & Gryanik, 2015 +#endif + !LB. + + + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcblk.F90 15551 2021-11-28 20:19:36Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_blk_alloc() + !!------------------------------------------------------------------- + !! *** ROUTINE sbc_blk_alloc *** + !!------------------------------------------------------------------- + ALLOCATE( theta_zu(jpi,jpj), q_zu(jpi,jpj), STAT=sbc_blk_alloc ) + CALL mpp_sum ( 'sbcblk', sbc_blk_alloc ) + IF( sbc_blk_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk_alloc: failed to allocate arrays' ) + END FUNCTION sbc_blk_alloc + +#if defined key_si3 + INTEGER FUNCTION sbc_blk_ice_alloc() + !!------------------------------------------------------------------- + !! *** ROUTINE sbc_blk_ice_alloc *** + !!------------------------------------------------------------------- + ALLOCATE( Cd_ice (jpi,jpj), Ch_ice (jpi,jpj), Ce_ice (jpi,jpj), & + & theta_zu_i(jpi,jpj), q_zu_i(jpi,jpj), STAT=sbc_blk_ice_alloc ) + CALL mpp_sum ( 'sbcblk', sbc_blk_ice_alloc ) + IF( sbc_blk_ice_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk_ice_alloc: failed to allocate arrays' ) + END FUNCTION sbc_blk_ice_alloc +#endif + + + SUBROUTINE sbc_blk_init + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_blk_init *** + !! + !! ** Purpose : choose and initialize a bulk formulae formulation + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER :: jfpr ! dummy loop indice and argument + INTEGER :: ios, ierror, ioptio ! Local integer + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of atmospheric forcing files + TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist informations on the fields to read + TYPE(FLD_N) :: sn_wndi, sn_wndj , sn_humi, sn_qsr ! informations about the fields to be read + TYPE(FLD_N) :: sn_qlw , sn_tair , sn_prec, sn_snow ! " " + TYPE(FLD_N) :: sn_slp , sn_uoatm, sn_voatm ! " " + TYPE(FLD_N) :: sn_cc, sn_hpgi, sn_hpgj ! " " + INTEGER :: ipka ! number of levels in the atmospheric variable + NAMELIST/namsbc_blk/ ln_NCAR, ln_COARE_3p0, ln_COARE_3p6, ln_ECMWF, ln_ANDREAS, & ! bulk algorithm + & rn_zqt, rn_zu, nn_iter_algo, ln_skin_cs, ln_skin_wl, & + & rn_pfac, rn_efac, & + & ln_crt_fbk, rn_stau_a, rn_stau_b, & ! current feedback + & ln_humi_sph, ln_humi_dpt, ln_humi_rlh, ln_tair_pot, & + & ln_Cx_ice_cst, rn_Cd_i, rn_Ce_i, rn_Ch_i, & + & ln_Cx_ice_AN05, ln_Cx_ice_LU12, ln_Cx_ice_LG15, & + & cn_dir, & + & sn_wndi, sn_wndj, sn_qsr, sn_qlw , & ! input fields + & sn_tair, sn_humi, sn_prec, sn_snow, sn_slp, & + & sn_uoatm, sn_voatm, sn_cc, sn_hpgi, sn_hpgj + + ! cool-skin / warm-layer !LB + !!--------------------------------------------------------------------- + ! + ! ! allocate sbc_blk_core array + IF( sbc_blk_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk : unable to allocate standard arrays' ) + ! +#if defined key_si3 + IF( sbc_blk_ice_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk : unable to allocate standard ice arrays' ) +#endif + ! + ! !** read bulk namelist + READ ( numnam_ref, namsbc_blk, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_blk in reference namelist' ) + ! + READ ( numnam_cfg, namsbc_blk, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_blk in configuration namelist' ) + ! + IF(lwm) WRITE( numond, namsbc_blk ) + ! + ! !** initialization of the chosen bulk formulae (+ check) + ! !* select the bulk chosen in the namelist and check the choice + ioptio = 0 + IF( ln_NCAR ) THEN + nblk = np_NCAR ; ioptio = ioptio + 1 + ENDIF + IF( ln_COARE_3p0 ) THEN + nblk = np_COARE_3p0 ; ioptio = ioptio + 1 + ENDIF + IF( ln_COARE_3p6 ) THEN + nblk = np_COARE_3p6 ; ioptio = ioptio + 1 + ENDIF + IF( ln_ECMWF ) THEN + nblk = np_ECMWF ; ioptio = ioptio + 1 + ENDIF + IF( ln_ANDREAS ) THEN + nblk = np_ANDREAS ; ioptio = ioptio + 1 + ENDIF + IF( ioptio /= 1 ) CALL ctl_stop( 'sbc_blk_init: Choose one and only one bulk algorithm' ) + + ! !** initialization of the cool-skin / warm-layer parametrization + IF( ln_skin_cs .OR. ln_skin_wl ) THEN + !! Some namelist sanity tests: + IF( ln_NCAR ) & + & CALL ctl_stop( 'sbc_blk_init: Cool-skin/warm-layer param. not compatible with NCAR algorithm' ) + IF( ln_ANDREAS ) & + & CALL ctl_stop( 'sbc_blk_init: Cool-skin/warm-layer param. not compatible with ANDREAS algorithm' ) + !IF( nn_fsbc /= 1 ) & + ! & CALL ctl_stop( 'sbc_blk_init: Please set "nn_fsbc" to 1 when using cool-skin/warm-layer param.') + END IF + + IF( ln_skin_wl ) THEN + !! Check if the frequency of downwelling solar flux input makes sense and if ln_dm2dc=T if it is daily! + IF( (sn_qsr%freqh < 0.).OR.(sn_qsr%freqh > 24.) ) & + & CALL ctl_stop( 'sbc_blk_init: Warm-layer param. (ln_skin_wl) not compatible with freq. of solar flux > daily' ) + IF( (sn_qsr%freqh == 24.).AND.(.NOT. ln_dm2dc) ) & + & CALL ctl_stop( 'sbc_blk_init: Please set ln_dm2dc=T for warm-layer param. (ln_skin_wl) to work properly' ) + END IF + + ioptio = 0 + IF( ln_humi_sph ) THEN + nhumi = np_humi_sph ; ioptio = ioptio + 1 + ENDIF + IF( ln_humi_dpt ) THEN + nhumi = np_humi_dpt ; ioptio = ioptio + 1 + ENDIF + IF( ln_humi_rlh ) THEN + nhumi = np_humi_rlh ; ioptio = ioptio + 1 + ENDIF + IF( ioptio /= 1 ) CALL ctl_stop( 'sbc_blk_init: Choose one and only one type of air humidity' ) + ! + IF( ln_dm2dc ) THEN !* check: diurnal cycle on Qsr + IF( sn_qsr%freqh /= 24. ) CALL ctl_stop( 'sbc_blk_init: ln_dm2dc=T only with daily short-wave input' ) + IF( sn_qsr%ln_tint ) THEN + CALL ctl_warn( 'sbc_blk_init: ln_dm2dc=T daily qsr time interpolation done by sbcdcy module', & + & ' ==> We force time interpolation = .false. for qsr' ) + sn_qsr%ln_tint = .false. + ENDIF + ENDIF + +#if defined key_si3 + ioptio = 0 + IF( ln_Cx_ice_cst ) THEN + nblk_ice = np_ice_cst ; ioptio = ioptio + 1 + ENDIF + IF( ln_Cx_ice_AN05 ) THEN + nblk_ice = np_ice_an05 ; ioptio = ioptio + 1 + ENDIF + IF( ln_Cx_ice_LU12 ) THEN + nblk_ice = np_ice_lu12 ; ioptio = ioptio + 1 + ENDIF + IF( ln_Cx_ice_LG15 ) THEN + nblk_ice = np_ice_lg15 ; ioptio = ioptio + 1 + ENDIF + IF( ioptio /= 1 ) CALL ctl_stop( 'sbc_blk_init: Choose one and only one ice-atm bulk algorithm' ) +#endif + + + ! !* set the bulk structure + ! !- store namelist information in an array + ! + slf_i(jp_wndi ) = sn_wndi ; slf_i(jp_wndj ) = sn_wndj + slf_i(jp_qsr ) = sn_qsr ; slf_i(jp_qlw ) = sn_qlw + slf_i(jp_tair ) = sn_tair ; slf_i(jp_humi ) = sn_humi + slf_i(jp_prec ) = sn_prec ; slf_i(jp_snow ) = sn_snow + slf_i(jp_slp ) = sn_slp ; slf_i(jp_cc ) = sn_cc + slf_i(jp_uoatm) = sn_uoatm ; slf_i(jp_voatm) = sn_voatm + slf_i(jp_hpgi ) = sn_hpgi ; slf_i(jp_hpgj ) = sn_hpgj + ! + IF( .NOT. ln_abl ) THEN ! force to not use jp_hpgi and jp_hpgj, should already be done in namelist_* but we never know... + slf_i(jp_hpgi)%clname = 'NOT USED' + slf_i(jp_hpgj)%clname = 'NOT USED' + ENDIF + ! + ! !- allocate the bulk structure + ALLOCATE( sf(jpfld), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_blk_init: unable to allocate sf structure' ) + ! + ! !- fill the bulk structure with namelist informations + CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_init', 'surface boundary condition -- bulk formulae', 'namsbc_blk' ) + sf(jp_wndi )%zsgn = -1._wp ; sf(jp_wndj )%zsgn = -1._wp ! vector field at T point: overwrite default definition of zsgn + sf(jp_uoatm)%zsgn = -1._wp ; sf(jp_voatm)%zsgn = -1._wp ! vector field at T point: overwrite default definition of zsgn + sf(jp_hpgi )%zsgn = -1._wp ; sf(jp_hpgj )%zsgn = -1._wp ! vector field at T point: overwrite default definition of zsgn + ! + DO jfpr= 1, jpfld + ! + IF( ln_abl .AND. & + & ( jfpr == jp_wndi .OR. jfpr == jp_wndj .OR. jfpr == jp_humi .OR. & + & jfpr == jp_hpgi .OR. jfpr == jp_hpgj .OR. jfpr == jp_tair ) ) THEN + ipka = jpka ! ABL: some fields are 3D input + ELSE + ipka = 1 + ENDIF + ! + ALLOCATE( sf(jfpr)%fnow(jpi,jpj,ipka) ) + ! + IF( TRIM(sf(jfpr)%clrootname) == 'NOT USED' ) THEN !-- not used field --! (only now allocated and set to default) + IF( jfpr == jp_slp ) THEN + sf(jfpr)%fnow(:,:,1:ipka) = 101325._wp ! use standard pressure in Pa + ELSEIF( jfpr == jp_prec .OR. jfpr == jp_snow .OR. jfpr == jp_uoatm .OR. jfpr == jp_voatm ) THEN + sf(jfpr)%fnow(:,:,1:ipka) = 0._wp ! no precip or no snow or no surface currents + ELSEIF( jfpr == jp_hpgi .OR. jfpr == jp_hpgj ) THEN + IF( .NOT. ln_abl ) THEN + DEALLOCATE( sf(jfpr)%fnow ) ! deallocate as not used in this case + ELSE + sf(jfpr)%fnow(:,:,1:ipka) = 0._wp + ENDIF + ELSEIF( jfpr == jp_cc ) THEN + sf(jp_cc)%fnow(:,:,1:ipka) = pp_cldf + ELSE + WRITE(ctmp1,*) 'sbc_blk_init: no default value defined for field number', jfpr + CALL ctl_stop( ctmp1 ) + ENDIF + ELSE !-- used field --! + IF( sf(jfpr)%ln_tint ) ALLOCATE( sf(jfpr)%fdta(jpi,jpj,ipka,2) ) ! allocate array for temporal interpolation + ! + IF( sf(jfpr)%freqh > 0. .AND. MOD( NINT(3600. * sf(jfpr)%freqh), nn_fsbc * NINT(rn_Dt) ) /= 0 ) & + & CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rn_Dt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.', & + & ' This is not ideal. You should consider changing either rn_Dt or nn_fsbc value...' ) + ENDIF + END DO + ! + IF( ln_abl ) THEN ! ABL: read 3D fields for wind, temperature, humidity and pressure gradient + rn_zqt = ght_abl(2) ! set the bulk altitude to ABL first level + rn_zu = ght_abl(2) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ABL formulation: overwrite rn_zqt & rn_zu with ABL first level altitude' + ENDIF + ! + ! + IF(lwp) THEN !** Control print + ! + WRITE(numout,*) !* namelist + WRITE(numout,*) ' Namelist namsbc_blk (other than data information):' + WRITE(numout,*) ' "NCAR" algorithm (Large and Yeager 2008) ln_NCAR = ', ln_NCAR + WRITE(numout,*) ' "COARE 3.0" algorithm (Fairall et al. 2003) ln_COARE_3p0 = ', ln_COARE_3p0 + WRITE(numout,*) ' "COARE 3.6" algorithm (Fairall 2018 + Edson al 2013) ln_COARE_3p6 = ', ln_COARE_3p6 + WRITE(numout,*) ' "ECMWF" algorithm (IFS cycle 45r1) ln_ECMWF = ', ln_ECMWF + WRITE(numout,*) ' "ANDREAS" algorithm (Andreas et al. 2015) ln_ANDREAS = ', ln_ANDREAS + WRITE(numout,*) ' Air temperature and humidity reference height (m) rn_zqt = ', rn_zqt + WRITE(numout,*) ' Wind vector reference height (m) rn_zu = ', rn_zu + WRITE(numout,*) ' factor applied on precipitation (total & snow) rn_pfac = ', rn_pfac + WRITE(numout,*) ' factor applied on evaporation rn_efac = ', rn_efac + WRITE(numout,*) ' (form absolute (=0) to relative winds(=1))' + WRITE(numout,*) ' use surface current feedback on wind stress ln_crt_fbk = ', ln_crt_fbk + IF(ln_crt_fbk) THEN + WRITE(numout,*) ' Renault et al. 2020, eq. 10: Stau = Alpha * Wnd + Beta' + WRITE(numout,*) ' Alpha rn_stau_a = ', rn_stau_a + WRITE(numout,*) ' Beta rn_stau_b = ', rn_stau_b + ENDIF + ! + WRITE(numout,*) + SELECT CASE( nblk ) !* Print the choice of bulk algorithm + CASE( np_NCAR ) ; WRITE(numout,*) ' ==>>> "NCAR" algorithm (Large and Yeager 2008)' + CASE( np_COARE_3p0 ) ; WRITE(numout,*) ' ==>>> "COARE 3.0" algorithm (Fairall et al. 2003)' + CASE( np_COARE_3p6 ) ; WRITE(numout,*) ' ==>>> "COARE 3.6" algorithm (Fairall 2018+Edson et al. 2013)' + CASE( np_ECMWF ) ; WRITE(numout,*) ' ==>>> "ECMWF" algorithm (IFS cycle 45r1)' + CASE( np_ANDREAS ) ; WRITE(numout,*) ' ==>>> "ANDREAS" algorithm (Andreas et al. 2015)' + END SELECT + ! + WRITE(numout,*) + WRITE(numout,*) ' use cool-skin parameterization (SSST) ln_skin_cs = ', ln_skin_cs + WRITE(numout,*) ' use warm-layer parameterization (SSST) ln_skin_wl = ', ln_skin_wl + ! + WRITE(numout,*) + SELECT CASE( nhumi ) !* Print the choice of air humidity + CASE( np_humi_sph ) ; WRITE(numout,*) ' ==>>> air humidity is SPECIFIC HUMIDITY [kg/kg]' + CASE( np_humi_dpt ) ; WRITE(numout,*) ' ==>>> air humidity is DEW-POINT TEMPERATURE [K]' + CASE( np_humi_rlh ) ; WRITE(numout,*) ' ==>>> air humidity is RELATIVE HUMIDITY [%]' + END SELECT + ! + !#LB: +#if defined key_si3 + IF( nn_ice > 0 ) THEN + WRITE(numout,*) + WRITE(numout,*) ' use constant ice-atm bulk transfer coeff. ln_Cx_ice_cst = ', ln_Cx_ice_cst + WRITE(numout,*) ' use ice-atm bulk coeff. from Andreas et al., 2005 ln_Cx_ice_AN05 = ', ln_Cx_ice_AN05 + WRITE(numout,*) ' use ice-atm bulk coeff. from Lupkes et al., 2012 ln_Cx_ice_LU12 = ', ln_Cx_ice_LU12 + WRITE(numout,*) ' use ice-atm bulk coeff. from Lupkes & Gryanik, 2015 ln_Cx_ice_LG15 = ', ln_Cx_ice_LG15 + ENDIF + WRITE(numout,*) + SELECT CASE( nblk_ice ) !* Print the choice of bulk algorithm + CASE( np_ice_cst ) + WRITE(numout,*) ' ==>>> Constant bulk transfer coefficients over sea-ice:' + WRITE(numout,*) ' => Cd_ice, Ce_ice, Ch_ice =', REAL(rn_Cd_i,4), REAL(rn_Ce_i,4), REAL(rn_Ch_i,4) + IF( (rn_Cd_i<0._wp).OR.(rn_Cd_i>1.E-2_wp).OR.(rn_Ce_i<0._wp).OR.(rn_Ce_i>1.E-2_wp).OR.(rn_Ch_i<0._wp).OR.(rn_Ch_i>1.E-2_wp) ) & + & CALL ctl_stop( 'Be realistic in your pick of Cd_ice, Ce_ice & Ch_ice ! (0 < Cx < 1.E-2)') + CASE( np_ice_an05 ) ; WRITE(numout,*) ' ==>>> bulk algo over ice: Andreas et al, 2005' + CASE( np_ice_lu12 ) ; WRITE(numout,*) ' ==>>> bulk algo over ice: Lupkes et al, 2012' + CASE( np_ice_lg15 ) ; WRITE(numout,*) ' ==>>> bulk algo over ice: Lupkes & Gryanik, 2015' + END SELECT +#endif + !#LB. + ! + ENDIF + ! + END SUBROUTINE sbc_blk_init + + + SUBROUTINE sbc_blk( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_blk *** + !! + !! ** Purpose : provide at each time step the surface ocean fluxes + !! (momentum, heat, freshwater and runoff) + !! + !! ** Method : + !! (1) READ each fluxes in NetCDF files: + !! the wind velocity (i-component) at z=rn_zu (m/s) at T-point + !! the wind velocity (j-component) at z=rn_zu (m/s) at T-point + !! the specific humidity at z=rn_zqt (kg/kg) + !! the air temperature at z=rn_zqt (Kelvin) + !! the solar heat (W/m2) + !! the Long wave (W/m2) + !! the total precipitation (rain+snow) (Kg/m2/s) + !! the snow (solid precipitation) (kg/m2/s) + !! ABL dynamical forcing (i/j-components of either hpg or geostrophic winds) + !! (2) CALL blk_oce_1 and blk_oce_2 + !! + !! C A U T I O N : never mask the surface stress fields + !! the stress is assumed to be in the (i,j) mesh referential + !! + !! ** Action : defined at each time-step at the air-sea interface + !! - utau, vtau i- and j-component of the wind stress + !! - taum wind stress module at T-point + !! - wndm wind speed module at T-point over free ocean or leads in presence of sea-ice + !! - qns, qsr non-solar and solar heat fluxes + !! - emp upward mass flux (evapo. - precip.) + !! - sfx salt flux due to freezing/melting (non-zero only if ice is present) + !! + !! ** References : Large & Yeager, 2004 / Large & Yeager, 2008 + !! Brodeau et al. Ocean Modelling 2010 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: zssq, zcd_du, zsen, zlat, zevp, zpre, ztheta + REAL(wp) :: ztst + LOGICAL :: llerr + !!---------------------------------------------------------------------- + ! + CALL fld_read( kt, nn_fsbc, sf ) ! input fields provided at the current time-step + + ! Sanity/consistence test on humidity at first time step to detect potential screw-up: + IF( kt == nit000 ) THEN + ! mean humidity over ocean on proc + ztst = glob_sum( 'sbcblk', sf(jp_humi)%fnow(:,:,1) * e1e2t(:,:) * tmask(:,:,1) ) / glob_sum( 'sbcblk', e1e2t(:,:) * tmask(:,:,1) ) + llerr = .FALSE. + SELECT CASE( nhumi ) + CASE( np_humi_sph ) ! specific humidity => expect: 0. <= something < 0.065 [kg/kg] (0.061 is saturation at 45degC !!!) + IF( (ztst < 0._wp) .OR. (ztst > 0.065_wp) ) llerr = .TRUE. + CASE( np_humi_dpt ) ! dew-point temperature => expect: 110. <= something < 320. [K] + IF( (ztst < 110._wp) .OR. (ztst > 320._wp) ) llerr = .TRUE. + CASE( np_humi_rlh ) ! relative humidity => expect: 0. <= something < 100. [%] + IF( (ztst < 0._wp) .OR. (ztst > 100._wp) ) llerr = .TRUE. + END SELECT + IF(llerr) THEN + WRITE(ctmp1,'(" Error on mean humidity value: ",f10.5)') ztst + CALL ctl_stop( 'STOP', ctmp1, 'Something is wrong with air humidity!!!', & + & ' ==> check the unit in your input files' , & + & ' ==> check consistence of namelist choice: specific? relative? dew-point?', & + & ' ==> ln_humi_sph -> [kg/kg] | ln_humi_rlh -> [%] | ln_humi_dpt -> [K] !!!' ) + ENDIF + IF(lwp) THEN + WRITE(numout,*) '' + WRITE(numout,*) ' Global mean humidity at kt = nit000: ', ztst + WRITE(numout,*) ' === Sanity/consistence test on air humidity sucessfuly passed! ===' + WRITE(numout,*) '' + ENDIF + ENDIF !IF( kt == nit000 ) + ! ! compute the surface ocean fluxes using bulk formulea + IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN + + ! Specific humidity of air at z=rn_zqt + SELECT CASE( nhumi ) + CASE( np_humi_sph ) + q_air_zt(:,:) = sf(jp_humi )%fnow(:,:,1) ! what we read in file is already a spec. humidity! + CASE( np_humi_dpt ) + IF((kt==nit000).AND.lwp) WRITE(numout,*) ' *** sbc_blk() => computing q_air out of dew-point and P !' + q_air_zt(:,:) = q_sat( sf(jp_humi )%fnow(:,:,1), sf(jp_slp )%fnow(:,:,1) ) + CASE( np_humi_rlh ) + IF((kt==nit000).AND.lwp) WRITE(numout,*) ' *** sbc_blk() => computing q_air out of RH, t_air and slp !' !LBrm + q_air_zt(:,:) = q_air_rh( 0.01_wp*sf(jp_humi )%fnow(:,:,1), & + & sf(jp_tair )%fnow(:,:,1), sf(jp_slp )%fnow(:,:,1) ) !#LB: 0.01 => RH is % percent in file + END SELECT + + ! Potential temperature of air at z=rn_zqt (most reanalysis products provide absolute temp., not potential temp.) + IF( ln_tair_pot ) THEN + ! temperature read into file is already potential temperature, do nothing... + theta_air_zt(:,:) = sf(jp_tair )%fnow(:,:,1) + ELSE + ! temperature read into file is ABSOLUTE temperature (that's the case for ECMWF products for example...) + IF((kt==nit000).AND.lwp) WRITE(numout,*) ' *** sbc_blk() => air temperature converted from ABSOLUTE to POTENTIAL!' + zpre(:,:) = pres_temp( q_air_zt(:,:), sf(jp_slp)%fnow(:,:,1), rn_zu, pta=sf(jp_tair)%fnow(:,:,1) ) + theta_air_zt(:,:) = theta_exner( sf(jp_tair)%fnow(:,:,1), zpre(:,:) ) + ENDIF + ! + CALL blk_oce_1( kt, sf(jp_wndi )%fnow(:,:,1), sf(jp_wndj )%fnow(:,:,1), & ! <<= in + & theta_air_zt(:,:), q_air_zt(:,:), & ! <<= in + & sf(jp_slp )%fnow(:,:,1), sst_m, ssu_m, ssv_m, & ! <<= in + & sf(jp_uoatm)%fnow(:,:,1), sf(jp_voatm)%fnow(:,:,1), & ! <<= in + & sf(jp_qsr )%fnow(:,:,1), sf(jp_qlw )%fnow(:,:,1), & ! <<= in (wl/cs) + & tsk_m, zssq, zcd_du, zsen, zlat, zevp ) ! =>> out + + CALL blk_oce_2( theta_air_zt(:,:), & ! <<= in + & sf(jp_qlw )%fnow(:,:,1), sf(jp_prec )%fnow(:,:,1), & ! <<= in + & REAL(sf(jp_snow )%fnow(:,:,1),dp), tsk_m, & ! <<= in + & zsen, zlat, zevp ) ! <=> in out + ENDIF + ! +#if defined key_cice + IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN + qlw_ice(:,:,1) = sf(jp_qlw )%fnow(:,:,1) + IF( ln_dm2dc ) THEN + qsr_ice(:,:,1) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) + ELSE + qsr_ice(:,:,1) = sf(jp_qsr)%fnow(:,:,1) + ENDIF + tatm_ice(:,:) = sf(jp_tair)%fnow(:,:,1) !#LB: should it be POTENTIAL temperature (theta_air_zt) instead ???? + qatm_ice(:,:) = q_air_zt(:,:) + tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac + sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac + wndi_ice(:,:) = sf(jp_wndi)%fnow(:,:,1) + wndj_ice(:,:) = sf(jp_wndj)%fnow(:,:,1) + ENDIF +#endif + +#if defined key_top + IF( ln_trcdc2dm ) THEN ! diurnal cycle in TOP + IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN + IF( ln_dm2dc ) THEN + qsr_mean(:,:) = ( 1. - albo ) * sf(jp_qsr)%fnow(:,:,1) * tmask(:,:,1) + ELSE + ncpl_qsr_freq = sf(jp_qsr)%freqh * 3600 ! qsr_mean will be computed in TOP + ENDIF + ENDIF + ENDIF +#endif + ! + END SUBROUTINE sbc_blk + + + SUBROUTINE blk_oce_1( kt, pwndi, pwndj, ptair, pqair, & ! inp + & pslp , pst , pu , pv, & ! inp + & puatm, pvatm, pdqsr , pdqlw , & ! inp + & ptsk , pssq , pcd_du, psen, plat, pevp ) ! out + !!--------------------------------------------------------------------- + !! *** ROUTINE blk_oce_1 *** + !! + !! ** Purpose : if ln_blk=T, computes surface momentum, heat and freshwater fluxes + !! if ln_abl=T, computes Cd x |U|, Ch x |U|, Ce x |U| for ABL integration + !! + !! ** Method : bulk formulae using atmospheric fields from : + !! if ln_blk=T, atmospheric fields read in sbc_read + !! if ln_abl=T, the ABL model at previous time-step + !! + !! ** Outputs : - pssq : surface humidity used to compute latent heat flux (kg/kg) + !! - pcd_du : Cd x |dU| at T-points (m/s) + !! - psen : sensible heat flux (W/m^2) + !! - plat : latent heat flux (W/m^2) + !! - pevp : evaporation (mm/s) #lolo + !!--------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! time step index + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndi ! atmospheric wind at T-point [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndj ! atmospheric wind at T-point [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pqair ! specific humidity at T-points [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: ptair ! potential temperature at T-points [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pslp ! sea-level pressure [Pa] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pst ! surface temperature [Celsius] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pu ! surface current at U-point (i-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pv ! surface current at V-point (j-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: puatm ! surface current seen by the atm at T-point (i-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pvatm ! surface current seen by the atm at T-point (j-component) [m/s] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pdqsr ! downwelling solar (shortwave) radiation at surface [W/m^2] + REAL(wp), INTENT(in ), DIMENSION(:,:) :: pdqlw ! downwelling longwave radiation at surface [W/m^2] + REAL(wp), INTENT( out), DIMENSION(:,:) :: ptsk ! skin temp. (or SST if CS & WL not used) [Celsius] + REAL(wp), INTENT( out), DIMENSION(:,:) :: pssq ! specific humidity at pst [kg/kg] + REAL(wp), INTENT( out), DIMENSION(:,:) :: pcd_du + REAL(wp), INTENT( out), DIMENSION(:,:) :: psen + REAL(wp), INTENT( out), DIMENSION(:,:) :: plat + REAL(wp), INTENT( out), DIMENSION(:,:) :: pevp + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zztmp ! local variable + REAL(wp) :: zstmax, zstau +#if defined key_cyclone + REAL(wp), DIMENSION(jpi,jpj) :: zwnd_i, zwnd_j ! wind speed components at T-point +#endif + REAL(wp), DIMENSION(jpi,jpj) :: ztau_i, ztau_j ! wind stress components at T-point + REAL(wp), DIMENSION(jpi,jpj) :: zU_zu ! bulk wind speed at height zu [m/s] + REAL(wp), DIMENSION(jpi,jpj) :: zcd_oce ! momentum transfert coefficient over ocean + REAL(wp), DIMENSION(jpi,jpj) :: zch_oce ! sensible heat transfert coefficient over ocean + REAL(wp), DIMENSION(jpi,jpj) :: zce_oce ! latent heat transfert coefficient over ocean + REAL(wp), DIMENSION(jpi,jpj) :: zsspt ! potential sea-surface temperature [K] + REAL(wp), DIMENSION(jpi,jpj) :: zpre, ztabs ! air pressure [Pa] & absolute temperature [K] + REAL(wp), DIMENSION(jpi,jpj) :: zztmp1, zztmp2 + !!--------------------------------------------------------------------- + ! + ! local scalars ( place there for vector optimisation purposes) + ! ! Temporary conversion from Celcius to Kelvin (and set minimum value far above 0 K) + ptsk(:,:) = pst(:,:) + rt0 ! by default: skin temperature = "bulk SST" (will remain this way if NCAR algorithm used!) + + ! sea surface potential temperature [K] + zsspt(:,:) = theta_exner( ptsk(:,:), pslp(:,:) ) + + ! --- cloud cover --- ! + cloud_fra(:,:) = sf(jp_cc)%fnow(:,:,1) + + ! ----------------------------------------------------------------------------- ! + ! 0 Wind components and module at T-point relative to the moving ocean ! + ! ----------------------------------------------------------------------------- ! + + ! ... components ( U10m - U_oce ) at T-point (unmasked) +#if defined key_cyclone + zwnd_i(:,:) = 0._wp + zwnd_j(:,:) = 0._wp + CALL wnd_cyc( kt, zwnd_i, zwnd_j ) ! add analytical tropical cyclone (Vincent et al. JGR 2012) + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zwnd_i(ji,jj) = pwndi(ji,jj) + zwnd_i(ji,jj) + zwnd_j(ji,jj) = pwndj(ji,jj) + zwnd_j(ji,jj) + ! ... scalar wind at T-point (not masked) + wndm(ji,jj) = SQRT( zwnd_i(ji,jj) * zwnd_i(ji,jj) + zwnd_j(ji,jj) * zwnd_j(ji,jj) ) + END_2D +#else + ! ... scalar wind module at T-point (not masked) + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + wndm(ji,jj) = SQRT( pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj) ) + END_2D +#endif + ! ----------------------------------------------------------------------------- ! + ! I Solar FLUX ! + ! ----------------------------------------------------------------------------- ! + + ! ocean albedo assumed to be constant + modify now Qsr to include the diurnal cycle ! Short Wave + zztmp = 1. - albo + IF( ln_dm2dc ) THEN + qsr(:,:) = zztmp * sbc_dcy( pdqsr(:,:) ) * tmask(:,:,1) + ELSE + qsr(:,:) = zztmp * pdqsr(:,:) * tmask(:,:,1) + ENDIF + + + ! ----------------------------------------------------------------------------- ! + ! II Turbulent FLUXES ! + ! ----------------------------------------------------------------------------- ! + + ! specific humidity at SST + pssq(:,:) = rdct_qsat_salt * q_sat( ptsk(:,:), pslp(:,:) ) + + IF( ln_skin_cs .OR. ln_skin_wl ) THEN + !! Backup "bulk SST" and associated spec. hum. + zztmp1(:,:) = zsspt(:,:) + zztmp2(:,:) = pssq(:,:) + ENDIF + + !! Time to call the user-selected bulk parameterization for + !! == transfer coefficients ==! Cd, Ch, Ce at T-point, and more... + SELECT CASE( nblk ) + + CASE( np_NCAR ) + CALL turb_ncar ( rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, & + & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu , & + & nb_iter=nn_iter_algo ) + ! + CASE( np_COARE_3p0 ) + CALL turb_coare3p0( kt, rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, & + & ln_skin_cs, ln_skin_wl, & + & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, & + & nb_iter=nn_iter_algo, & + & Qsw=qsr(:,:), rad_lw=pdqlw(:,:), slp=pslp(:,:) ) + ! + CASE( np_COARE_3p6 ) + CALL turb_coare3p6( kt, rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, & + & ln_skin_cs, ln_skin_wl, & + & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, & + & nb_iter=nn_iter_algo, & + & Qsw=qsr(:,:), rad_lw=pdqlw(:,:), slp=pslp(:,:) ) + ! + CASE( np_ECMWF ) + CALL turb_ecmwf ( kt, rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, & + & ln_skin_cs, ln_skin_wl, & + & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu, & + & nb_iter=nn_iter_algo, & + & Qsw=qsr(:,:), rad_lw=pdqlw(:,:), slp=pslp(:,:) ) + ! + CASE( np_ANDREAS ) + CALL turb_andreas ( rn_zqt, rn_zu, zsspt, ptair, pssq, pqair, wndm, & + & zcd_oce, zch_oce, zce_oce, theta_zu, q_zu, zU_zu , & + & nb_iter=nn_iter_algo ) + ! + CASE DEFAULT + CALL ctl_stop( 'STOP', 'sbc_oce: non-existing bulk parameterizaton selected' ) + ! + END SELECT + + IF( iom_use('Cd_oce') ) CALL iom_put("Cd_oce", zcd_oce * tmask(:,:,1)) + IF( iom_use('Ce_oce') ) CALL iom_put("Ce_oce", zce_oce * tmask(:,:,1)) + IF( iom_use('Ch_oce') ) CALL iom_put("Ch_oce", zch_oce * tmask(:,:,1)) + !! LB: mainly here for debugging purpose: + IF( iom_use('theta_zt') ) CALL iom_put("theta_zt", (ptair-rt0) * tmask(:,:,1)) ! potential temperature at z=zt + IF( iom_use('q_zt') ) CALL iom_put("q_zt", pqair * tmask(:,:,1)) ! specific humidity " + IF( iom_use('theta_zu') ) CALL iom_put("theta_zu", (theta_zu -rt0) * tmask(:,:,1)) ! potential temperature at z=zu + IF( iom_use('q_zu') ) CALL iom_put("q_zu", q_zu * tmask(:,:,1)) ! specific humidity " + IF( iom_use('ssq') ) CALL iom_put("ssq", pssq * tmask(:,:,1)) ! saturation specific humidity at z=0 + IF( iom_use('wspd_blk') ) CALL iom_put("wspd_blk", zU_zu * tmask(:,:,1)) ! bulk wind speed at z=zu + + IF( ln_skin_cs .OR. ln_skin_wl ) THEN + !! In the presence of sea-ice we forget about the cool-skin/warm-layer update of zsspt, pssq & ptsk: + WHERE ( fr_i(:,:) > 0.001_wp ) + ! sea-ice present, we forget about the update, using what we backed up before call to turb_*() + zsspt(:,:) = zztmp1(:,:) + pssq(:,:) = zztmp2(:,:) + END WHERE + ! apply potential temperature increment to abolute SST + ptsk(:,:) = ptsk(:,:) + ( zsspt(:,:) - zztmp1(:,:) ) + END IF + + ! Turbulent fluxes over ocean => BULK_FORMULA @ sbc_phy.F90 + ! ------------------------------------------------------------- + + IF( ln_abl ) THEN !== ABL formulation ==! multiplication by rho_air and turbulent fluxes computation done in ablstp + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zztmp = zU_zu(ji,jj) + wndm(ji,jj) = zztmp ! Store zU_zu in wndm to compute ustar2 in ablmod + pcd_du(ji,jj) = zztmp * zcd_oce(ji,jj) + psen(ji,jj) = zztmp * zch_oce(ji,jj) + pevp(ji,jj) = zztmp * zce_oce(ji,jj) + zpre(ji,jj) = pres_temp( pqair(ji,jj), pslp(ji,jj), rn_zu, ptpot=ptair(ji,jj), pta=ztabs(ji,jj) ) + rhoa(ji,jj) = rho_air( ztabs(ji,jj), pqair(ji,jj), zpre(ji,jj) ) + END_2D + + ELSE !== BLK formulation ==! turbulent fluxes computation + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zpre(ji,jj) = pres_temp( q_zu(ji,jj), pslp(ji,jj), rn_zu, ptpot=theta_zu(ji,jj), pta=ztabs(ji,jj) ) + rhoa(ji,jj) = rho_air( ztabs(ji,jj), q_zu(ji,jj), zpre(ji,jj) ) + END_2D + + CALL bulk_formula( rn_zu, zsspt(:,:), pssq(:,:), theta_zu(:,:), q_zu(:,:), & + & zcd_oce(:,:), zch_oce(:,:), zce_oce(:,:), & + & wndm(:,:), zU_zu(:,:), pslp(:,:), rhoa(:,:), & + & taum(:,:), psen(:,:), plat(:,:), & + & pEvap=pevp(:,:), pfact_evap=rn_efac ) + + psen(:,:) = psen(:,:) * tmask(:,:,1) + plat(:,:) = plat(:,:) * tmask(:,:,1) + taum(:,:) = taum(:,:) * tmask(:,:,1) + pevp(:,:) = pevp(:,:) * tmask(:,:,1) + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + IF( wndm(ji,jj) > 0._wp ) THEN + zztmp = taum(ji,jj) / wndm(ji,jj) +#if defined key_cyclone + ztau_i(ji,jj) = zztmp * zwnd_i(ji,jj) + ztau_j(ji,jj) = zztmp * zwnd_j(ji,jj) +#else + ztau_i(ji,jj) = zztmp * pwndi(ji,jj) + ztau_j(ji,jj) = zztmp * pwndj(ji,jj) +#endif + ELSE + ztau_i(ji,jj) = 0._wp + ztau_j(ji,jj) = 0._wp + ENDIF + END_2D + + IF( ln_crt_fbk ) THEN ! aply eq. 10 and 11 of Renault et al. 2020 (doi: 10.1029/2019MS001715) + zstmax = MIN( rn_stau_a * 3._wp + rn_stau_b, 0._wp ) ! set the max value of Stau corresponding to a wind of 3 m/s (<0) + DO_2D( 0, 1, 0, 1 ) ! end at jpj and jpi, as ztau_j(ji,jj+1) ztau_i(ji+1,jj) used in the next loop + zstau = MIN( rn_stau_a * wndm(ji,jj) + rn_stau_b, zstmax ) ! stau (<0) must be smaller than zstmax + ztau_i(ji,jj) = ztau_i(ji,jj) + zstau * ( 0.5_wp * ( pu(ji-1,jj ) + pu(ji,jj) ) - puatm(ji,jj) ) + ztau_j(ji,jj) = ztau_j(ji,jj) + zstau * ( 0.5_wp * ( pv(ji ,jj-1) + pv(ji,jj) ) - pvatm(ji,jj) ) + taum(ji,jj) = SQRT( ztau_i(ji,jj) * ztau_i(ji,jj) + ztau_j(ji,jj) * ztau_j(ji,jj) ) + END_2D + ENDIF + + ! ... utau, vtau at U- and V_points, resp. + ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines + ! Note that coastal wind stress is not used in the code... so this extra care has no effect + DO_2D( 0, 0, 0, 0 ) ! start loop at 2, in case ln_crt_fbk = T + utau(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( ztau_i(ji,jj) + ztau_i(ji+1,jj ) ) & + & * MAX(tmask(ji,jj,1),tmask(ji+1,jj,1)) + vtau(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( ztau_j(ji,jj) + ztau_j(ji ,jj+1) ) & + & * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1)) + END_2D + + IF( ln_crt_fbk ) THEN + CALL lbc_lnk( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp, taum, 'T', 1._wp ) + ELSE + CALL lbc_lnk( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp ) + ENDIF + + ! Saving open-ocean wind-stress (module and components) on T-points: + CALL iom_put( "taum_oce", taum(:,:)*tmask(:,:,1) ) ! output wind stress module + !#LB: These 2 lines below mostly here for 'STATION_ASF' test-case, otherwize "utau" (U-grid) and vtau" (V-grid) does the job in: [DYN/dynatf.F90]) + CALL iom_put( "utau_oce", ztau_i(:,:)*tmask(:,:,1) ) ! utau at T-points! + CALL iom_put( "vtau_oce", ztau_j(:,:)*tmask(:,:,1) ) ! vtau at T-points! + + IF(sn_cfctl%l_prtctl) THEN + CALL prt_ctl( tab2d_1=REAL(pssq,dp), clinfo1=' blk_oce_1: pssq : ') + CALL prt_ctl( tab2d_1=REAL(wndm,dp), clinfo1=' blk_oce_1: wndm : ') + CALL prt_ctl( tab2d_1=REAL(utau,dp), clinfo1=' blk_oce_1: utau : ', mask1=umask, & + & tab2d_2=REAL(vtau,dp), clinfo2=' vtau : ', mask2=vmask ) + CALL prt_ctl( tab2d_1=REAL(zcd_oce,dp), clinfo1=' blk_oce_1: Cd : ') + ENDIF + ! + ENDIF ! ln_blk / ln_abl + + ptsk(:,:) = ( ptsk(:,:) - rt0 ) * tmask(:,:,1) ! Back to Celsius + + IF( ln_skin_cs .OR. ln_skin_wl ) THEN + CALL iom_put( "t_skin" , ptsk ) ! T_skin in Celsius + CALL iom_put( "dt_skin" , ptsk - pst ) ! T_skin - SST temperature difference + ENDIF + ! + END SUBROUTINE blk_oce_1 + + + SUBROUTINE blk_oce_2( ptair, pdqlw, pprec, psnow, & ! <<= in + & ptsk, psen, plat, pevp ) ! <<= in + !!--------------------------------------------------------------------- + !! *** ROUTINE blk_oce_2 *** + !! + !! ** Purpose : finalize the momentum, heat and freshwater fluxes computation + !! at the ocean surface at each time step knowing Cd, Ch, Ce and + !! atmospheric variables (from ABL or external data) + !! + !! ** Outputs : - utau : i-component of the stress at U-point (N/m2) + !! - vtau : j-component of the stress at V-point (N/m2) + !! - taum : Wind stress module at T-point (N/m2) + !! - wndm : Wind speed module at T-point (m/s) + !! - qsr : Solar heat flux over the ocean (W/m2) + !! - qns : Non Solar heat flux over the ocean (W/m2) + !! - emp : evaporation minus precipitation (kg/m2/s) + !!--------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(:,:) :: ptair ! potential temperature of air #LB: confirm! + REAL(wp), INTENT(in), DIMENSION(:,:) :: pdqlw ! downwelling longwave radiation at surface [W/m^2] + REAL(wp), INTENT(in), DIMENSION(:,:) :: pprec + REAL(dp), INTENT(in), DIMENSION(:,:) :: psnow + REAL(wp), INTENT(in), DIMENSION(:,:) :: ptsk ! SKIN surface temperature [Celsius] + REAL(wp), INTENT(in), DIMENSION(:,:) :: psen + REAL(wp), INTENT(in), DIMENSION(:,:) :: plat + REAL(wp), INTENT(in), DIMENSION(:,:) :: pevp + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zztmp,zz1,zz2,zz3 ! local variable + REAL(wp), DIMENSION(jpi,jpj) :: zqlw ! net long wave radiative heat flux + REAL(wp), DIMENSION(jpi,jpj) :: zcptrain, zcptsnw, zcptn ! Heat content per unit mass (J/kg) + !!--------------------------------------------------------------------- + ! + ! Heat content per unit mass (J/kg) + zcptrain(:,:) = ( ptair - rt0 ) * rcp * tmask(:,:,1) + zcptsnw (:,:) = ( MIN( ptair, rt0 ) - rt0 ) * rcpi * tmask(:,:,1) + zcptn (:,:) = ptsk * rcp * tmask(:,:,1) + ! + ! ----------------------------------------------------------------------------- ! + ! III Net longwave radiative FLUX ! + ! ----------------------------------------------------------------------------- ! + !! #LB: now moved after Turbulent fluxes because must use the skin temperature rather than bulk SST + !! (ptsk is skin temperature if ln_skin_cs==.TRUE. .OR. ln_skin_wl==.TRUE.) + zqlw(:,:) = qlw_net( pdqlw(:,:), ptsk(:,:)+rt0 ) + + ! ----------------------------------------------------------------------------- ! + ! IV Total FLUXES ! + ! ----------------------------------------------------------------------------- ! + ! + emp (:,:) = ( pevp(:,:) - pprec(:,:) * rn_pfac ) * tmask(:,:,1) ! mass flux (evap. - precip.) + ! + qns(:,:) = zqlw(:,:) + psen(:,:) + plat(:,:) & ! Downward Non Solar + & - psnow(:,:) * rn_pfac * rLfus & ! remove latent melting heat for solid precip + & - pevp(:,:) * zcptn(:,:) & ! remove evap heat content at SST + & + ( pprec(:,:) - psnow(:,:) ) * rn_pfac * zcptrain(:,:) & ! add liquid precip heat content at Tair + & + psnow(:,:) * rn_pfac * zcptsnw(:,:) ! add solid precip heat content at min(Tair,Tsnow) + qns(:,:) = qns(:,:) * tmask(:,:,1) + ! +#if defined key_si3 + qns_oce(:,:) = zqlw(:,:) + psen(:,:) + plat(:,:) ! non solar without emp (only needed by SI3) + qsr_oce(:,:) = qsr(:,:) +#endif + ! + CALL iom_put( "rho_air" , rhoa*tmask(:,:,1) ) ! output air density [kg/m^3] + CALL iom_put( "evap_oce" , pevp ) ! evaporation + CALL iom_put( "qlw_oce" , zqlw ) ! output downward longwave heat over the ocean + CALL iom_put( "qsb_oce" , psen ) ! output downward sensible heat over the ocean + CALL iom_put( "qla_oce" , plat ) ! output downward latent heat over the ocean + tprecip(:,:) = pprec(:,:) * rn_pfac * tmask(:,:,1) ! output total precipitation [kg/m2/s] + sprecip(:,:) = psnow(:,:) * rn_pfac * tmask(:,:,1) ! output solid precipitation [kg/m2/s] + CALL iom_put( 'snowpre', sprecip ) ! Snow + CALL iom_put( 'precip' , tprecip ) ! Total precipitation + ! + IF ( nn_ice == 0 ) THEN + CALL iom_put( "qemp_oce" , qns-zqlw-psen-plat ) ! output downward heat content of E-P over the ocean + CALL iom_put( "qns_oce" , qns ) ! output downward non solar heat over the ocean + CALL iom_put( "qsr_oce" , qsr ) ! output downward solar heat over the ocean + CALL iom_put( "qt_oce" , qns+qsr ) ! output total downward heat over the ocean + ENDIF + ! + IF(sn_cfctl%l_prtctl) THEN + CALL prt_ctl(tab2d_1=REAL(zqlw,dp), clinfo1=' blk_oce_2: zqlw : ') + CALL prt_ctl(tab2d_1=REAL(psen,dp), clinfo1=' blk_oce_2: psen : ' ) + CALL prt_ctl(tab2d_1=REAL(plat,dp), clinfo1=' blk_oce_2: plat : ' ) + CALL prt_ctl(tab2d_1=REAL(qns,dp), clinfo1=' blk_oce_2: qns : ' ) + CALL prt_ctl(tab2d_1=REAL(emp,dp), clinfo1=' blk_oce_2: emp : ') + ENDIF + ! + END SUBROUTINE blk_oce_2 + + +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! blk_ice_1 : provide the air-ice stress + !! blk_ice_2 : provide the heat and mass fluxes at air-ice interface + !! blk_ice_qcn : provide ice surface temperature and snow/ice conduction flux (emulating conduction flux) + !!---------------------------------------------------------------------- + + SUBROUTINE blk_ice_1( pwndi, pwndj, ptair, pqair, pslp , puice, pvice, ptsui, & ! inputs + & putaui, pvtaui, pseni, pevpi, pssqi, pcd_dui ) ! optional outputs + !!--------------------------------------------------------------------- + !! *** ROUTINE blk_ice_1 *** + !! + !! ** Purpose : provide the surface boundary condition over sea-ice + !! + !! ** Method : compute momentum using bulk formulation + !! formulea, ice variables and read atmospheric fields. + !! NB: ice drag coefficient is assumed to be a constant + !!--------------------------------------------------------------------- + REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pslp ! sea-level pressure [Pa] + REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pwndi ! atmospheric wind at T-point [m/s] + REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pwndj ! atmospheric wind at T-point [m/s] + REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: ptair ! atmospheric potential temperature at T-point [K] + REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pqair ! atmospheric specific humidity at T-point [kg/kg] + REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: puice ! sea-ice velocity on I or C grid [m/s] + REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: pvice ! " + REAL(wp) , INTENT(in ), DIMENSION(:,: ) :: ptsui ! sea-ice surface temperature [K] + REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: putaui ! if ln_blk + REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pvtaui ! if ln_blk + REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pseni ! if ln_abl + REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pevpi ! if ln_abl + REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pssqi ! if ln_abl + REAL(wp) , INTENT( out), DIMENSION(:,: ), OPTIONAL :: pcd_dui ! if ln_abl + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zootm_su ! sea-ice surface mean temperature + REAL(wp) :: zztmp1, zztmp2 ! temporary scalars + REAL(wp), DIMENSION(jpi,jpj) :: ztmp, zsipt ! temporary array + !!--------------------------------------------------------------------- + ! + ! ------------------------------------------------------------ ! + ! Wind module relative to the moving ice ( U10m - U_ice ) ! + ! ------------------------------------------------------------ ! + ! C-grid ice dynamics : U & V-points (same as ocean) + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + wndm_ice(ji,jj) = SQRT( pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj) ) + END_2D + ! + ! potential sea-ice surface temperature [K] + zsipt(:,:) = theta_exner( ptsui(:,:), pslp(:,:) ) + + ! sea-ice <-> atmosphere bulk transfer coefficients + SELECT CASE( nblk_ice ) + + CASE( np_ice_cst ) + ! Constant bulk transfer coefficients over sea-ice: + Cd_ice(:,:) = rn_Cd_i + Ch_ice(:,:) = rn_Ch_i + Ce_ice(:,:) = rn_Ce_i + ! no height adjustment, keeping zt values: + theta_zu_i(:,:) = ptair(:,:) + q_zu_i(:,:) = pqair(:,:) + + CASE( np_ice_an05 ) ! calculate new drag from Lupkes(2015) equations + ztmp(:,:) = q_sat( ptsui(:,:), pslp(:,:), l_ice=.TRUE. ) ! temporary array for SSQ + CALL turb_ice_an05( rn_zqt, rn_zu, zsipt, ptair, ztmp, pqair, wndm_ice, & + & Cd_ice, Ch_ice, Ce_ice, theta_zu_i, q_zu_i ) + !! + CASE( np_ice_lu12 ) + ztmp(:,:) = q_sat( ptsui(:,:), pslp(:,:), l_ice=.TRUE. ) ! temporary array for SSQ + CALL turb_ice_lu12( rn_zqt, rn_zu, zsipt, ptair, ztmp, pqair, wndm_ice, fr_i, & + & Cd_ice, Ch_ice, Ce_ice, theta_zu_i, q_zu_i ) + !! + CASE( np_ice_lg15 ) ! calculate new drag from Lupkes(2015) equations + ztmp(:,:) = q_sat( ptsui(:,:), pslp(:,:), l_ice=.TRUE. ) ! temporary array for SSQ + CALL turb_ice_lg15( rn_zqt, rn_zu, zsipt, ptair, ztmp, pqair, wndm_ice, fr_i, & + & Cd_ice, Ch_ice, Ce_ice, theta_zu_i, q_zu_i ) + !! + END SELECT + + IF( iom_use('Cd_ice').OR.iom_use('Ce_ice').OR.iom_use('Ch_ice').OR.iom_use('taum_ice').OR.iom_use('utau_ice').OR.iom_use('vtau_ice') ) & + & ztmp(:,:) = ( 1._wp - MAX(0._wp, SIGN( 1._wp, 1.E-6_wp - fr_i )) )*tmask(:,:,1) ! mask for presence of ice ! + + IF( iom_use('Cd_ice') ) CALL iom_put("Cd_ice", Cd_ice*ztmp) + IF( iom_use('Ce_ice') ) CALL iom_put("Ce_ice", Ce_ice*ztmp) + IF( iom_use('Ch_ice') ) CALL iom_put("Ch_ice", Ch_ice*ztmp) + + + IF( ln_blk ) THEN + ! ---------------------------------------------------- ! + ! Wind stress relative to nonmoving ice ( U10m ) ! + ! ---------------------------------------------------- ! + ! supress moving ice in wind stress computation as we don't know how to do it properly... + DO_2D( 0, 1, 0, 1 ) ! at T point + zztmp1 = rhoa(ji,jj) * Cd_ice(ji,jj) * wndm_ice(ji,jj) + putaui(ji,jj) = zztmp1 * pwndi(ji,jj) + pvtaui(ji,jj) = zztmp1 * pwndj(ji,jj) + END_2D + + !#LB: saving the module, and x-y components, of the ai wind-stress at T-points: NOT weighted by the ice concentration !!! + IF(iom_use('taum_ice')) CALL iom_put('taum_ice', SQRT( putaui*putaui + pvtaui*pvtaui )*ztmp ) + !#LB: These 2 lines below mostly here for 'STATION_ASF' test-case, otherwize "utau_oi" (U-grid) and vtau_oi" (V-grid) does the job in: [ICE/icedyn_rhg_evp.F90]) + IF(iom_use('utau_ice')) CALL iom_put("utau_ice", putaui*ztmp) ! utau at T-points! + IF(iom_use('vtau_ice')) CALL iom_put("vtau_ice", pvtaui*ztmp) ! vtau at T-points! + + ! + DO_2D( 0, 0, 0, 0 ) ! U & V-points (same as ocean). + !#LB: QUESTION?? so SI3 expects wind stress vector to be provided at U & V points? Not at T-points ? + ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology + zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) ) + zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji ,jj+1,1) ) + putaui(ji,jj) = zztmp1 * ( putaui(ji,jj) + putaui(ji+1,jj ) ) + pvtaui(ji,jj) = zztmp2 * ( pvtaui(ji,jj) + pvtaui(ji ,jj+1) ) + END_2D + CALL lbc_lnk( 'sbcblk', putaui, 'U', -1._wp, pvtaui, 'V', -1._wp ) + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=REAL(putaui,dp), clinfo1=' blk_ice: putaui : ' & + & , tab2d_2=REAL(pvtaui,dp), clinfo2=' pvtaui : ' ) + ELSE ! ln_abl + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + pcd_dui(ji,jj) = wndm_ice(ji,jj) * Cd_ice(ji,jj) + pseni (ji,jj) = wndm_ice(ji,jj) * Ch_ice(ji,jj) + pevpi (ji,jj) = wndm_ice(ji,jj) * Ce_ice(ji,jj) + END_2D + pssqi(:,:) = q_sat( ptsui(:,:), pslp(:,:), l_ice=.TRUE. ) ; ! more accurate way to obtain ssq ! + + ENDIF ! ln_blk / ln_abl + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl(tab2d_1=REAL(wndm_ice,dp), clinfo1=' blk_ice: wndm_ice : ') + ! + END SUBROUTINE blk_ice_1 + + + SUBROUTINE blk_ice_2( ptsu, phs, phi, palb, ptair, pqair, pslp, pdqlw, pprec, psnow ) + !!--------------------------------------------------------------------- + !! *** ROUTINE blk_ice_2 *** + !! + !! ** Purpose : provide the heat and mass fluxes at air-ice interface + !! + !! ** Method : compute heat and freshwater exchanged + !! between atmosphere and sea-ice using bulk formulation + !! formulea, ice variables and read atmmospheric fields. + !! + !! caution : the net upward water flux has with mm/day unit + !!--------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptsu ! sea ice surface temperature [K] + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: palb ! ice albedo (all skies) + REAL(wp), DIMENSION(:,: ), INTENT(in) :: ptair ! potential temperature of air #LB: okay ??? + REAL(wp), DIMENSION(:,: ), INTENT(in) :: pqair ! specific humidity of air + REAL(wp), DIMENSION(:,: ), INTENT(in) :: pslp + REAL(wp), DIMENSION(:,: ), INTENT(in) :: pdqlw + REAL(wp), DIMENSION(:,: ), INTENT(in) :: pprec + REAL(wp), DIMENSION(:,: ), INTENT(in) :: psnow + !! + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp) :: zst, zst3, zsq, zsipt ! local variable + REAL(wp) :: zcoef_dqlw, zcoef_dqla ! - - + REAL(wp) :: zztmp, zzblk, zztmp1, z1_rLsub ! - - + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qlw ! long wave heat flux over ice + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qsb ! sensible heat flux over ice + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_dqlw ! long wave heat sensitivity over ice + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_dqsb ! sensible heat sensitivity over ice + REAL(wp), DIMENSION(jpi,jpj) :: zevap, zsnw ! evaporation and snw distribution after wind blowing (SI3) + REAL(wp), DIMENSION(jpi,jpj) :: ztmp, ztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: ztri + REAL(wp), DIMENSION(jpi,jpj) :: zcptrain, zcptsnw, zcptn ! Heat content per unit mass (J/kg) + !!--------------------------------------------------------------------- + ! + zcoef_dqlw = 4._wp * emiss_i * stefan ! local scalars + zztmp = 1. / ( 1. - albo ) + dqla_ice(:,:,:) = 0._wp + + ! Heat content per unit mass (J/kg) + zcptrain(:,:) = ( ptair - rt0 ) * rcp * tmask(:,:,1) + zcptsnw (:,:) = ( MIN( ptair, rt0 ) - rt0 ) * rcpi * tmask(:,:,1) + zcptn (:,:) = sst_m * rcp * tmask(:,:,1) + ! + ! ! ========================== ! + DO jl = 1, jpl ! Loop over ice categories ! + ! ! ========================== ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + + zst = ptsu(ji,jj,jl) ! surface temperature of sea-ice [K] + zsq = q_sat( zst, pslp(ji,jj), l_ice=.TRUE. ) ! surface saturation specific humidity when ice present + zsipt = theta_exner( zst, pslp(ji,jj) ) ! potential sea-ice surface temperature [K] + + ! ----------------------------! + ! I Radiative FLUXES ! + ! ----------------------------! + ! Short Wave (sw) + qsr_ice(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj) + + ! Long Wave (lw) + zst3 = zst * zst * zst + z_qlw(ji,jj,jl) = emiss_i * ( pdqlw(ji,jj) - stefan * zst * zst3 ) * tmask(ji,jj,1) + ! lw sensitivity + z_dqlw(ji,jj,jl) = zcoef_dqlw * zst3 + + ! ----------------------------! + ! II Turbulent FLUXES ! + ! ----------------------------! + + ! ... turbulent heat fluxes with Ch_ice recalculated in blk_ice_1 + + ! Common term in bulk F. equations... + zzblk = rhoa(ji,jj) * wndm_ice(ji,jj) + + ! Sensible Heat + zztmp1 = zzblk * rCp_air * Ch_ice(ji,jj) + z_qsb (ji,jj,jl) = zztmp1 * (zsipt - theta_zu_i(ji,jj)) + z_dqsb(ji,jj,jl) = zztmp1 ! ==> Qsens sensitivity (Dqsb_ice/Dtn_ice) + + ! Latent Heat + zztmp1 = zzblk * rLsub * Ce_ice(ji,jj) + qla_ice(ji,jj,jl) = MAX( zztmp1 * (zsq - q_zu_i(ji,jj)) , 0._wp ) ! #LB: only sublimation (and not condensation) ??? + IF(qla_ice(ji,jj,jl)>0._wp) dqla_ice(ji,jj,jl) = zztmp1*dq_sat_dt_ice(zst, pslp(ji,jj)) ! ==> Qlat sensitivity (dQlat/dT) + ! !#LB: dq_sat_dt_ice() in "sbc_phy.F90" + !#LB: without this unjustified "condensation sensure": + !qla_ice( ji,jj,jl) = zztmp1 * (zsq - q_zu_i(ji,jj)) + !dqla_ice(ji,jj,jl) = zztmp1 * dq_sat_dt_ice(zst, pslp(ji,jj)) ! ==> Qlat sensitivity (dQlat/dT) + + + ! ----------------------------! + ! III Total FLUXES ! + ! ----------------------------! + ! Downward Non Solar flux + qns_ice (ji,jj,jl) = z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - qla_ice (ji,jj,jl) + ! Total non solar heat flux sensitivity for ice + dqns_ice(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + dqla_ice(ji,jj,jl) ) !#LB: correct signs ???? + + END_2D + ! + END DO + ! + tprecip(:,:) = pprec(:,:) * rn_pfac * tmask(:,:,1) ! total precipitation [kg/m2/s] + sprecip(:,:) = psnow(:,:) * rn_pfac * tmask(:,:,1) ! solid precipitation [kg/m2/s] + CALL iom_put( 'snowpre', sprecip ) ! Snow precipitation + CALL iom_put( 'precip' , tprecip ) ! Total precipitation + + ! --- evaporation --- ! + z1_rLsub = 1._wp / rLsub + evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_rLsub ! sublimation + devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_rLsub ! d(sublimation)/dT + zevap (:,:) = emp(:,:) + tprecip(:,:) ! evaporation over ocean !LB: removed rn_efac here, correct??? + + ! --- evaporation minus precipitation --- ! + zsnw(:,:) = 0._wp + CALL ice_var_snwblow( (1.-at_i_b(:,:)), zsnw ) ! snow distribution over ice after wind blowing + emp_oce(:,:) = ( 1._wp - at_i_b(:,:) ) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw ) + emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw + emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:) + + ! --- heat flux associated with emp --- ! + qemp_oce(:,:) = - ( 1._wp - at_i_b(:,:) ) * zevap(:,:) * zcptn(:,:) & ! evap at sst + & + ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) & ! liquid precip at Tair + & + sprecip(:,:) * ( 1._wp - zsnw ) * ( zcptsnw (:,:) - rLfus ) ! solid precip at min(Tair,Tsnow) + qemp_ice(:,:) = sprecip(:,:) * zsnw * ( zcptsnw (:,:) - rLfus ) ! solid precip (only) + + ! --- total solar and non solar fluxes --- ! + qns_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) & + & + qemp_ice(:,:) + qemp_oce(:,:) + qsr_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) + + ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! + qprec_ice(:,:) = rhos * ( zcptsnw(:,:) - rLfus ) + + ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- + DO jl = 1, jpl + qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * rcpi * tmask(:,:,1) ) + ! ! But we do not have Tice => consider it at 0degC => evap=0 + END DO + + ! --- shortwave radiation transmitted thru the surface scattering layer (W/m2) --- ! + IF( nn_qtrice == 0 ) THEN + ! formulation derived from Grenfell and Maykut (1977), where transmission rate + ! 1) depends on cloudiness + ! 2) is 0 when there is any snow + ! 3) tends to 1 for thin ice + ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm + DO jl = 1, jpl + WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm + qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) ) + ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm + qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:) + ELSEWHERE ! zero when hs>0 + qtr_ice_top(:,:,jl) = 0._wp + END WHERE + ENDDO + ELSEIF( nn_qtrice == 1 ) THEN + ! formulation is derived from the thesis of M. Lebrun (2019). + ! It represents the best fit using several sets of observations + ! It comes with snow conductivities adapted to freezing/melting conditions (see icethd_zdf_bl99.F90) + qtr_ice_top(:,:,:) = 0.3_wp * qsr_ice(:,:,:) + ENDIF + ! + IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') ) THEN + CALL iom_put( 'evap_ao_cea' , zevap(:,:) * ( 1._wp - at_i_b(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average) + CALL iom_put( 'hflx_evap_cea', zevap(:,:) * ( 1._wp - at_i_b(:,:) ) * tmask(:,:,1) * zcptn(:,:) ) ! heat flux from evap (cell average) + ENDIF + IF( iom_use('rain') .OR. iom_use('rain_ao_cea') .OR. iom_use('hflx_rain_cea') ) THEN + CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation + CALL iom_put( 'rain_ao_cea' , ( tprecip(:,:) - sprecip(:,:) ) * ( 1._wp - at_i_b(:,:) ) ) ! liquid precipitation over ocean (cell average) + CALL iom_put( 'hflx_rain_cea', ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) ! heat flux from rain (cell average) + ENDIF + IF( iom_use('snow_ao_cea') .OR. iom_use('snow_ai_cea') .OR. & + & iom_use('hflx_snow_cea') .OR. iom_use('hflx_snow_ao_cea') .OR. iom_use('hflx_snow_ai_cea') ) THEN + CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average) + CALL iom_put( 'snow_ai_cea' , sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average) + CALL iom_put( 'hflx_snow_cea' , sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) ) ! heat flux from snow (cell average) + CALL iom_put( 'hflx_snow_ao_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) * ( 1._wp - zsnw(:,:) ) ) ! heat flux from snow (over ocean) + CALL iom_put( 'hflx_snow_ai_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) * zsnw(:,:) ) ! heat flux from snow (over ice) + ENDIF + IF( iom_use('hflx_prec_cea') ) THEN ! heat flux from precip (cell average) + CALL iom_put('hflx_prec_cea' , sprecip(:,:) * ( zcptsnw (:,:) - rLfus ) & + & + ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) + ENDIF + IF( iom_use('subl_ai_cea') .OR. iom_use('hflx_subl_cea') ) THEN + CALL iom_put( 'subl_ai_cea' , SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average) + CALL iom_put( 'hflx_subl_cea', SUM( a_i_b(:,:,:) * qevap_ice(:,:,:), dim=3 ) * tmask(:,:,1) ) ! Heat flux from sublimation (cell average) + ENDIF + ! + IF(sn_cfctl%l_prtctl) THEN + CALL prt_ctl(tab3d_1=REAL(qla_ice,dp) , clinfo1=' blk_ice: qla_ice : ', tab3d_2=z_qsb , clinfo2=' z_qsb : ', kdim=jpl) + CALL prt_ctl(tab3d_1=REAL(z_qlw,dp) , clinfo1=' blk_ice: z_qlw : ', tab3d_2=dqla_ice, clinfo2=' dqla_ice : ', kdim=jpl) + CALL prt_ctl(tab3d_1=REAL(z_dqsb ,dp) , clinfo1=' blk_ice: z_dqsb : ', tab3d_2=z_dqlw , clinfo2=' z_dqlw : ', kdim=jpl) + CALL prt_ctl(tab3d_1=REAL(dqns_ice,dp), clinfo1=' blk_ice: dqns_ice : ', tab3d_2=qsr_ice , clinfo2=' qsr_ice : ', kdim=jpl) + CALL prt_ctl(tab3d_1=REAL(ptsu ,dp) , clinfo1=' blk_ice: ptsu : ', tab3d_2=qns_ice , clinfo2=' qns_ice : ', kdim=jpl) + CALL prt_ctl(tab2d_1=REAL(tprecip ,dp), clinfo1=' blk_ice: tprecip : ', tab2d_2=REAL(sprecip,dp) , clinfo2=' sprecip : ') + ENDIF + + !#LB: + ! air-ice heat flux components that are not written from ice_stp()@icestp.F90: + IF( iom_use('qla_ice') ) CALL iom_put( 'qla_ice', SUM( - qla_ice * a_i_b, dim=3 ) ) !#LB: sign consistent with what's done for ocean + IF( iom_use('qsb_ice') ) CALL iom_put( 'qsb_ice', SUM( - z_qsb * a_i_b, dim=3 ) ) !#LB: ==> negative => loss of heat for sea-ice + IF( iom_use('qlw_ice') ) CALL iom_put( 'qlw_ice', SUM( z_qlw * a_i_b, dim=3 ) ) + !#LB. + + END SUBROUTINE blk_ice_2 + + + SUBROUTINE blk_ice_qcn( ld_virtual_itd, ptsu, ptb, phs, phi ) + !!--------------------------------------------------------------------- + !! *** ROUTINE blk_ice_qcn *** + !! + !! ** Purpose : Compute surface temperature and snow/ice conduction flux + !! to force sea ice / snow thermodynamics + !! in the case conduction flux is emulated + !! + !! ** Method : compute surface energy balance assuming neglecting heat storage + !! following the 0-layer Semtner (1976) approach + !! + !! ** Outputs : - ptsu : sea-ice / snow surface temperature (K) + !! - qcn_ice : surface inner conduction flux (W/m2) + !! + !!--------------------------------------------------------------------- + LOGICAL , INTENT(in ) :: ld_virtual_itd ! single-category option + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptsu ! sea ice / snow surface temperature + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: ptb ! sea ice base temperature + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phs ! snow thickness + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phi ! sea ice thickness + ! + INTEGER , PARAMETER :: nit = 10 ! number of iterations + REAL(wp), PARAMETER :: zepsilon = 0.1_wp ! characteristic thickness for enhanced conduction + ! + INTEGER :: ji, jj, jl ! dummy loop indices + INTEGER :: iter ! local integer + REAL(wp) :: zfac, zfac2, zfac3 ! local scalars + REAL(wp) :: zkeff_h, ztsu, ztsu0 ! + REAL(wp) :: zqc, zqnet ! + REAL(wp) :: zhe, zqa0 ! + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zgfac ! enhanced conduction factor + !!--------------------------------------------------------------------- + + ! -------------------------------------! + ! I Enhanced conduction factor ! + ! -------------------------------------! + ! Emulates the enhancement of conduction by unresolved thin ice (ld_virtual_itd = T) + ! Fichefet and Morales Maqueda, JGR 1997 + ! + zgfac(:,:,:) = 1._wp + + IF( ld_virtual_itd ) THEN + ! + zfac = 1._wp / ( rn_cnd_s + rcnd_i ) + zfac2 = EXP(1._wp) * 0.5_wp * zepsilon + zfac3 = 2._wp / zepsilon + ! + DO jl = 1, jpl + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zhe = ( rn_cnd_s * phi(ji,jj,jl) + rcnd_i * phs(ji,jj,jl) ) * zfac ! Effective thickness + IF( zhe >= zfac2 ) zgfac(ji,jj,jl) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( zhe * zfac3 ) ) ) ! Enhanced conduction factor + END_2D + END DO + ! + ENDIF + + ! -------------------------------------------------------------! + ! II Surface temperature and conduction flux ! + ! -------------------------------------------------------------! + ! + zfac = rcnd_i * rn_cnd_s + ! + DO jl = 1, jpl + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zkeff_h = zfac * zgfac(ji,jj,jl) / & ! Effective conductivity of the snow-ice system divided by thickness + & ( rcnd_i * phs(ji,jj,jl) + rn_cnd_s * MAX( 0.01, phi(ji,jj,jl) ) ) + ztsu = ptsu(ji,jj,jl) ! Store current iteration temperature + ztsu0 = ptsu(ji,jj,jl) ! Store initial surface temperature + zqa0 = qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) ! Net initial atmospheric heat flux + ! + DO iter = 1, nit ! --- Iterative loop + zqc = zkeff_h * ( ztsu - ptb(ji,jj) ) ! Conduction heat flux through snow-ice system (>0 downwards) + zqnet = zqa0 + dqns_ice(ji,jj,jl) * ( ztsu - ptsu(ji,jj,jl) ) - zqc ! Surface energy budget + ztsu = ztsu - zqnet / ( dqns_ice(ji,jj,jl) - zkeff_h ) ! Temperature update + END DO + ! + ptsu (ji,jj,jl) = MIN( rt0, ztsu ) + qcn_ice(ji,jj,jl) = zkeff_h * ( ptsu(ji,jj,jl) - ptb(ji,jj) ) + qns_ice(ji,jj,jl) = qns_ice(ji,jj,jl) + dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) + qml_ice(ji,jj,jl) = ( qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) - qcn_ice(ji,jj,jl) ) & + & * MAX( 0._wp , SIGN( 1._wp, ptsu(ji,jj,jl) - rt0 ) ) + + ! --- Diagnose the heat loss due to changing non-solar flux (as in icethd_zdf_bl99) --- ! + hfx_err_dif(ji,jj) = hfx_err_dif(ji,jj) - ( dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) ) * a_i_b(ji,jj,jl) + + END_2D + ! + END DO + ! + END SUBROUTINE blk_ice_qcn + +#endif + + !!====================================================================== +END MODULE sbcblk diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_andreas.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_andreas.F90 new file mode 100644 index 0000000..c8fa35b --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_andreas.F90 @@ -0,0 +1,337 @@ +!!! TO DO: consistent psi_m and psi_h needed!!! For now is those of NCAR !!! +!! +MODULE sbcblk_algo_andreas + !!====================================================================== + !! *** MODULE sbcblk_algo_andreas *** + !! Computes: + !! * bulk transfer coefficients C_D, C_E and C_H + !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed + !! * the effective bulk wind speed at 10m Ubzu + !! according to Andreas et al. (2015) + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !! Andreas, E.L., Mahrt, L. and Vickers, D. (2015), + !! An improved bulk air–sea surface flux algorithm, + !! including spray‐mediated transfer. + !! Q.J.R. Meteorol. Soc., 141: 642-654. doi:10.1002/qj.2424 + !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !! + !! * bulk transfer coefficients C_D, C_E and C_H + !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed + !! * the effective bulk wind speed at z=zu: Ubzu + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Using the bulk formulation/param. of Large & Yeager 2008 + !! + !! Routine turb_andreas maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !! + !! ** Author: L. Brodeau, August 2020 / AeroBulk (https://github.com/brodeau/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.x ! 2020-08 (L.Brodeau) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + + IMPLICIT NONE + PRIVATE + + !! Important (Brodeau fix): + REAL(wp), PARAMETER :: rRi_max = 0.15_wp ! Bulk Ri above which the algorithm fucks up! + ! ! (increasing (>0) Ri means that surface layer increasingly stable and/or wind increasingly weak) + REAL(wp), PARAMETER :: rCs_min = 0.35E-3_wp ! minimum value to tolarate for CE and CH ! Must be larger than "Cx_min" !!! + + PUBLIC :: TURB_ANDREAS, psi_m_andreas, psi_h_andreas + + !! * Substitutions +# include "do_loop_substitute.h90" + + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE turb_andreas( zt, zu, sst, t_zt, ssq, q_zt, U_zu, & + & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & + & nb_iter, CdN, ChN, CeN ) + !!---------------------------------------------------------------------------------- + !! *** ROUTINE turb_andreas *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to Large & Yeager (2004) and Large & Yeager (2008) + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! INPUT : + !! ------- + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * sst : bulk SST [K] + !! * t_zt : potential air temperature at zt [K] + !! * ssq : specific humidity at saturation at SST [kg/kg] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! + !! OUTPUT : + !! -------- + !! * Cd : drag coefficient + !! * Ch : sensible heat coefficient + !! * Ce : evaporation coefficient + !! * t_zu : pot. air temperature adjusted at wind height zu [K] + !! * q_zu : specific humidity of air // [kg/kg] + !! * Ubzu : bulk wind speed at zu [m/s] + !! + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: sst ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: ssq ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + ! + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN + ! + INTEGER :: nbit, jit ! iterations... + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + !! + REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star + REAL(wp), DIMENSION(jpi,jpj) :: z0 ! roughness length (momentum) [m] + REAL(wp), DIMENSION(jpi,jpj) :: UN10 ! Neutral wind speed at zu [m/s] + REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: RiB ! square root of Cd + !! + !!---------------------------------------------------------------------------------- + nbit = nb_iter0 + IF( PRESENT(nb_iter) ) nbit = nb_iter + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision + + Ubzu = MAX( 0.25_wp , U_zu ) ! relative wind speed at zu (normally 10m), we don't want to fall under 0.5 m/s + + !! First guess: + UN10 = Ubzu + Cd = 1.1E-3_wp + Ch = 1.1E-3_wp + Ce = 1.1E-3_wp + t_zu = t_zt + q_zu = q_zt + + !! First guess of turbulent scales for scalars: + ztmp0 = SQRT(Cd) + t_star = Ch/ztmp0*(t_zu - sst) ! theta* + q_star = Ce/ztmp0*(q_zu - ssq) ! q* + + ! Bulk Richardson number: + RiB(:,:) = Ri_bulk( zu, sst, t_zu, ssq, q_zu, Ubzu ) + + + !! ITERATION BLOCK + DO jit = 1, nbit + + WHERE ( RiB < rRi_max ) + !! Normal condition case: + u_star = U_STAR_ANDREAS( UN10 ) + ELSEWHERE + !! Extremely stable + weak wind !!! + !! => for we force u* to be consistent with minimum value for CD: + !! (otherwize algorithm becomes nonsense...) + u_star = SQRT(Cx_min) * Ubzu ! Cd does not go below Cx_min ! + ENDWHERE + + !! Stability parameter : + zeta_u = zu*One_on_L( t_zu, q_zu, u_star, t_star, q_star ) ! zu * 1/L + + !! Drag coefficient: + ztmp0 = u_star/Ubzu + + Cd = MAX( ztmp0*ztmp0 , Cx_min ) + + !! Roughness length: + z0 = MIN( z0_from_Cd( zu, Cd, ppsi=psi_m_andreas(zeta_u) ) , z0_sea_max ) + + !! z0t and z0q, based on LKB, just like into COARE 2.5: + ztmp0 = z0 * u_star / visc_air(t_zu) ! Re_r + ztmp1 = z0tq_LKB( 1, ztmp0, z0 ) ! z0t + ztmp2 = z0tq_LKB( 2, ztmp0, z0 ) ! z0q + + !! Turbulent scales at zu : + ztmp0 = psi_h_andreas(zeta_u) ! lolo: zeta_u for scalars??? + t_star = (t_zu - sst)*vkarmn/(LOG(zu) - LOG(ztmp1) - ztmp0) ! theta* (ztmp1 == z0t in rhs term) + q_star = (q_zu - ssq)*vkarmn/(LOG(zu) - LOG(ztmp2) - ztmp0) ! q* (ztmp2 == z0q in rhs term) + + IF( (.NOT. l_zt_equal_zu).AND.( jit > 1 ) ) THEN + !! Re-updating temperature and humidity at zu if zt /= zu: + ztmp0 = zeta_u/zu*zt ! zeta_t + ztmp0 = LOG(zt/zu) + psi_h_andreas(zeta_u) - psi_h_andreas(ztmp0) + t_zu = t_zt - t_star/vkarmn*ztmp0 + q_zu = q_zt - q_star/vkarmn*ztmp0 + RiB = Ri_bulk( zu, sst, t_zu, ssq, q_zu, Ubzu ) !LOLO + ENDIF + + !! Update neutral-stability wind at zu: + UN10 = MAX( 0.1_wp , UN10_from_ustar( zu, Ubzu, u_star, psi_m_andreas(zeta_u) ) ) ! UN10 + + END DO !DO jit = 1, nbit + + ! Compute transfer coefficients at zu: + ztmp0 = u_star/Ubzu + + Cd = MAX( ztmp0*ztmp0 , Cx_min ) ! the earlier use of Cx_min on u* should make use of Cx_min here unnecessary! + + ztmp1 = t_zu - sst ; ztmp1 = SIGN( MAX(ABS(ztmp1),1.E-6_wp), ztmp1 ) ! dt_zu + ztmp2 = q_zu - ssq ; ztmp2 = SIGN( MAX(ABS(ztmp2),1.E-9_wp), ztmp2 ) ! dq_zu + Ch = MAX( ztmp0*t_star/ztmp1 , rCs_min ) + Ce = MAX( ztmp0*q_star/ztmp2 , rCs_min ) + + !! Neutral-stability coefficients: + ztmp0 = 1._wp/LOG(zu/z0) + ztmp1 = z0 * u_star / visc_air(t_zu) ! Re_r + + IF(PRESENT(CdN)) CdN = vkarmn2*ztmp0*ztmp0 + IF(PRESENT(ChN)) ChN = vkarmn2*ztmp0/LOG(zu/z0tq_LKB( 1, ztmp1, z0 )) + IF(PRESENT(CeN)) CeN = vkarmn2*ztmp0/LOG(zu/z0tq_LKB( 2, ztmp1, z0 )) + + END SUBROUTINE turb_andreas + + + FUNCTION U_STAR_ANDREAS( pun10 ) + !!---------------------------------------------------------------------------------- + !! Estimate of the friction velocity as a function of the neutral-stability wind + !! speed at at 10m + !! + !! Origin: Eq.(2.2) of Andreas et al. (2015) + !! + !! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pun10 !: neutral-stability scalar wind speed at 10m (m/s) + REAL(wp), DIMENSION(jpi,jpj) :: u_star_andreas !: friction velocity [m/s] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: za, zt, zw ! local scalars + !!---------------------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zw = pun10(ji,jj) + za = zw - 8.271_wp + zt = za + SQRT( 0.12_wp*za*za + 0.181_wp ) + u_star_andreas(ji,jj) = 0.239_wp + 0.0433_wp * zt + END_2D + END FUNCTION U_STAR_ANDREAS + + + FUNCTION psi_m_andreas( pzeta ) + !!---------------------------------------------------------------------------------- + !! Universal profile stability function for momentum + !! TO DO !!!!!!!!!!!!!!!!!!!!! + !! LOLO: paper says Paulson 1970 when unstable and Grachev et al 2007 for STABLE + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! ** Author: L. Brodeau, April 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_andreas + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + REAL(wp), PARAMETER :: zam = 5._wp ! a_m (just below Eq.(9b) + REAL(wp), PARAMETER :: zbm = zam/6.5_wp ! b_m (just below Eq.(9b) + ! + REAL(wp), PARAMETER :: z1o3 = 1._wp/3._wp + REAL(wp), PARAMETER :: zsr3 = SQRT(3._wp) + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx2, zx, zpsi_unst, zbbm, zpsi_stab, zstab ! local scalars + !!---------------------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zta = MIN( pzeta(ji,jj) , 15._wp ) !! Very stable conditions (L positif and big!) + ! + !! *** Unstable: Paulson (1970): #LOLO: DOUBLE CHECK IT IS PAULSON!!!!! + zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 - 16z)^0.5 + zx2 = MAX( zx2 , 1._wp ) + zx = SQRT(zx2) ! (1 - 16z)^0.25 + zpsi_unst = 2._wp*LOG(ABS( (1._wp + zx )*0.5_wp )) & + & + LOG(ABS( (1._wp + zx2)*0.5_wp )) & + & - 2._wp*ATAN(zx) + rpi*0.5_wp + ! + !! *** Stable: Grachev et al 2007 (SHEBA) [Eq.(12) Grachev et al 2007]: + zx = ABS(1._wp + zta)**z1o3 + zbbm = ABS( (1._wp - zbm)/zbm )**z1o3 ! B_m + ! + zpsi_stab = -3.*zam/zbm*(zx - 1._wp) + zam*zbbm/(2.*zbm) * ( & + & 2.*LOG(ABS( ( zx + zbbm )/(1._wp + zbbm ) )) & + & - LOG(ABS( (zx*zx - zx*zbbm + zbbm*zbbm)/(1._wp - zbbm + zbbm*zbbm) )) & + & + 2.*zsr3*( ATAN( (2.*zx - zbbm)/(zsr3*zbbm) ) - ATAN( (2._wp - zbbm)/(zsr3*zbbm) ) ) ) + ! + ! + zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 + ! + psi_m_andreas(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable + ! + END_2D + END FUNCTION psi_m_andreas + + + FUNCTION psi_h_andreas( pzeta ) + !!---------------------------------------------------------------------------------- + !! Universal profile stability function for temperature and humidity + !! + !! TO DO + !! !! LOLO: paper says Paulson 1970 when unstable and Grachev et al 2007 for STABLE + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_andreas + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + REAL(wp), PARAMETER :: zah = 5._wp ! a_h (just below Eq.(9b) + REAL(wp), PARAMETER :: zbh = 5._wp ! b_h (just below Eq.(9b) + REAL(wp), PARAMETER :: zch = 3._wp ! c_h (just below Eq.(9b) + REAL(wp), PARAMETER :: zbbh = SQRT(5._wp) ! B_h (just below Eq.(13) + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zz, zx2, zpsi_unst, zpsi_stab, zstab ! local scalars + !!---------------------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zta = MIN( pzeta(ji,jj) , 15._wp ) !! Very stable conditions (L positif and large!) + ! + !! *** Unstable: Paulson (1970): #LOLO: DOUBLE CHECK IT IS PAULSON!!!!! + zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 -16z)^0.5 + zx2 = MAX( zx2 , 1._wp ) + zpsi_unst = 2._wp*LOG( 0.5_wp*(1._wp + zx2) ) + ! + !! *** Stable: Grachev et al 2007 (SHEBA) [Eq.(13) Grachev et al 2007]: + zz = 2.*zta + zch + zpsi_stab = - 0.5*zbh*LOG(ABS(1._wp + zch*zta + zta*zta)) & + & + (-zah/zbbh + 0.5*zbh*zch/zbbh) & + & *( LOG(ABS((zz - zbbh)/(zz + zbbh))) & + & - LOG(ABS((zch - zbbh)/(zch + zbbh))) ) + ! + zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 + ! + psi_h_andreas(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable + ! + END_2D + END FUNCTION psi_h_andreas + + !!====================================================================== +END MODULE sbcblk_algo_andreas \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_coare3p0.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_coare3p0.F90 new file mode 100644 index 0000000..55a3983 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_coare3p0.F90 @@ -0,0 +1,508 @@ +MODULE sbcblk_algo_coare3p0 + !!====================================================================== + !! *** MODULE sbcblk_algo_coare3p0 *** + !! + !! After Fairall et al, 2003 + !! Computes: + !! * bulk transfer coefficients C_D, C_E and C_H + !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed + !! * the effective bulk wind speed at 10m Ubzu + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Routine turb_coare3p0 maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk) + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.0 ! 2016-02 (L.Brodeau) Original code + !! 4.2 ! 2020-12 (L. Brodeau) Introduction of various air-ice bulk parameterizations + improvements + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! turb_coare3p0 : computes the bulk turbulent transfer coefficients + !! adjusts t_air and q_air from zt to zu m + !! returns the effective bulk wind speed at 10m + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE iom ! I/O manager library + USE lib_mpp ! distribued memory computing library + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE sbcwave, ONLY : cdn_wave ! wave module +#if defined key_si3 || defined key_cice + USE sbc_ice ! Surface boundary condition: ice fields +#endif + USE lib_fortran ! to use key_nosignedzero + + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + USE sbcblk_skin_coare ! cool-skin/warm layer scheme (CSWL_ECMWF) !LB + + IMPLICIT NONE + PRIVATE + + PUBLIC :: SBCBLK_ALGO_COARE3P0_INIT, TURB_COARE3P0 + !! * Substitutions +# include "do_loop_substitute.h90" + + !! COARE own values for given constants: + REAL(wp), PARAMETER :: zi0 = 600._wp ! scale height of the atmospheric boundary layer... + REAL(wp), PARAMETER :: Beta0 = 1.25_wp ! gustiness parameter + REAL(wp), PARAMETER :: zeta_abs_max = 50._wp + + !!---------------------------------------------------------------------- +CONTAINS + + + SUBROUTINE sbcblk_algo_coare3p0_init(l_use_cs, l_use_wl) + !!--------------------------------------------------------------------- + !! *** FUNCTION sbcblk_algo_coare3p0_init *** + !! + !! INPUT : + !! ------- + !! * l_use_cs : use the cool-skin parameterization + !! * l_use_wl : use the warm-layer parameterization + !!--------------------------------------------------------------------- + LOGICAL , INTENT(in) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in) :: l_use_wl ! use the warm-layer parameterization + INTEGER :: ierr + !!--------------------------------------------------------------------- + IF( l_use_wl ) THEN + ierr = 0 + ALLOCATE ( Tau_ac(jpi,jpj) , Qnt_ac(jpi,jpj), dT_wl(jpi,jpj), Hz_wl(jpi,jpj), STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P0_INIT => allocation of Tau_ac, Qnt_ac, dT_wl & Hz_wl failed!' ) + Tau_ac(:,:) = 0._wp + Qnt_ac(:,:) = 0._wp + dT_wl(:,:) = 0._wp + Hz_wl(:,:) = Hwl_max + ENDIF + IF( l_use_cs ) THEN + ierr = 0 + ALLOCATE ( dT_cs(jpi,jpj), STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P0_INIT => allocation of dT_cs failed!' ) + dT_cs(:,:) = -0.25_wp ! First guess of skin correction + ENDIF + END SUBROUTINE sbcblk_algo_coare3p0_init + + + + SUBROUTINE turb_coare3p0( kt, zt, zu, T_s, t_zt, q_s, q_zt, U_zu, l_use_cs, l_use_wl, & + & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & + & nb_iter, Cdn, Chn, Cen, & ! optional output + & Qsw, rad_lw, slp, pdT_cs, & ! optionals for cool-skin (and warm-layer) + & pdT_wl, pHz_wl ) ! optionals for warm-layer only + !!---------------------------------------------------------------------- + !! *** ROUTINE turb_coare3p0 *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to Fairall et al. (2003) + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! Applies the cool-skin warm-layer correction of the SST to T_s + !! if the net shortwave flux at the surface (Qsw), the downwelling longwave + !! radiative fluxes at the surface (rad_lw), and the sea-leve pressure (slp) + !! are provided as (optional) arguments! + !! + !! INPUT : + !! ------- + !! * kt : current time step (starts at 1) + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * t_zt : potential air temperature at zt [K] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! * l_use_cs : use the cool-skin parameterization + !! * l_use_wl : use the warm-layer parameterization + !! + !! INPUT/OUTPUT: + !! ------------- + !! * T_s : always "bulk SST" as input [K] + !! -> unchanged "bulk SST" as output if CSWL not used [K] + !! -> skin temperature as output if CSWL used [K] + !! + !! * q_s : SSQ aka saturation specific humidity at temp. T_s [kg/kg] + !! -> doesn't need to be given a value if skin temp computed (in case l_use_cs=True or l_use_wl=True) + !! -> MUST be given the correct value if not computing skint temp. (in case l_use_cs=False or l_use_wl=False) + !! + !! OPTIONAL INPUT: + !! --------------- + !! * Qsw : net solar flux (after albedo) at the surface (>0) [W/m^2] + !! * rad_lw : downwelling longwave radiation at the surface (>0) [W/m^2] + !! * slp : sea-level pressure [Pa] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * pdT_cs : SST increment "dT" for cool-skin correction [K] + !! * pdT_wl : SST increment "dT" for warm-layer correction [K] + !! * pHz_wl : thickness of warm-layer [m] + !! + !! OUTPUT : + !! -------- + !! * Cd : drag coefficient + !! * Ch : sensible heat coefficient + !! * Ce : evaporation coefficient + !! * t_zu : pot. air temperature adjusted at wind height zu [K] + !! * q_zu : specific humidity of air // [kg/kg] + !! * Ubzu : bulk wind speed at zu [m/s] + !! + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! current time step + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + ! + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cdn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Chn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cen + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] + ! + INTEGER :: nbit, jit + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + ! + REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star + REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu + REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air + REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t + REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] + ! + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zeta_t ! stability parameter at height zt + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST + ! + CHARACTER(len=40), PARAMETER :: crtnm = 'turb_coare3p0@sbcblk_algo_coare3p0' + !!---------------------------------------------------------------------------------- + IF( kt == nit000 ) CALL SBCBLK_ALGO_COARE3P0_INIT(l_use_cs, l_use_wl) + + nbit = nb_iter0 + IF( PRESENT(nb_iter) ) nbit = nb_iter + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision + IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) + + !! Initializations for cool skin and warm layer: + IF( l_use_cs .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & + & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use cool-skin param!' ) + + IF( l_use_wl .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & + & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use warm-layer param!' ) + + IF( l_use_cs .OR. l_use_wl ) THEN + ALLOCATE ( zsst(jpi,jpj) ) + zsst = T_s ! backing up the bulk SST + IF( l_use_cs ) T_s = T_s - 0.25_wp ! First guess of correction + q_s = rdct_qsat_salt*q_sat(MAX(T_s, 200._wp), slp) ! First guess of q_s + ENDIF + + !! First guess of temperature and humidity at height zu: + t_zu = MAX( t_zt , 180._wp ) ! who knows what's given on masked-continental regions... + q_zu = MAX( q_zt , 1.e-6_wp ) ! " + + !! Pot. temp. difference (and we don't want it to be 0!) + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + + znu_a = visc_air(t_zu) ! Air viscosity (m^2/s) at zt given from temperature in (K) + + Ubzu = SQRT(U_zu*U_zu + 0.5_wp*0.5_wp) ! initial guess for wind gustiness contribution + + ztmp0 = LOG( zu*10000._wp) ! optimization: 10000. == 1/z0 (with z0 first guess == 0.0001) + ztmp1 = LOG(10._wp*10000._wp) ! " " " + u_star = 0.035_wp*Ubzu*ztmp1/ztmp0 ! (u* = 0.035*Un10) + + z0 = charn_coare3p0(U_zu)*u_star*u_star/grav + 0.11_wp*znu_a/u_star + z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + z0t = 1._wp / ( 0.1_wp*EXP(vkarmn/(0.00115/(vkarmn/ztmp1))) ) + z0t = MIN( MAX(ABS(z0t), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + Cd = MAX( (vkarmn/ztmp0)**2 , Cx_min ) ! first guess of Cd + + ztmp0 = vkarmn2/LOG(zt/z0t)/Cd + + ztmp2 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, Ubzu ) ! Bulk Richardson Number (BRN) + + !! First estimate of zeta_u, depending on the stability, ie sign of BRN (ztmp2): + ztmp1 = 0.5 + SIGN( 0.5_wp , ztmp2 ) + zeta_u = (1._wp - ztmp1) * ztmp0*ztmp2 / (1._wp - ztmp2*zi0*0.004_wp*Beta0**3/zu) & ! BRN < 0 + & + ztmp1 * ( ztmp0*ztmp2 + 27._wp/9._wp*ztmp2*ztmp2 ) ! BRN > 0 + + !! First guess M-O stability dependent scaling params.(u*,t*,q*) to estimate z0 and z/L + ztmp0 = vkarmn/(LOG(zu/z0t) - psi_h_coare(zeta_u)) + + u_star = MAX ( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) + t_star = dt_zu*ztmp0 + q_star = dq_zu*ztmp0 + + ! What needs to be done if zt /= zu: + IF( .NOT. l_zt_equal_zu ) THEN + !! First update of values at zu (or zt for wind) + zeta_t = zt*zeta_u/zu + ztmp0 = psi_h_coare(zeta_u) - psi_h_coare(zeta_t) + ztmp1 = LOG(zt/zu) + ztmp0 + t_zu = t_zt - t_star/vkarmn*ztmp1 + q_zu = q_zt - q_star/vkarmn*ztmp1 + q_zu = (0.5_wp + SIGN(0.5_wp,q_zu))*q_zu !Makes it impossible to have negative humidity : + ! + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + ENDIF + + !! ITERATION BLOCK + DO jit = 1, nbit + + !!Inverse of Obukov length (1/L) : + ztmp0 = One_on_L(t_zu, q_zu, u_star, t_star, q_star) ! 1/L == 1/[Obukhov length] + ztmp0 = SIGN( MIN(ABS(ztmp0),200._wp), ztmp0 ) ! 1/L (prevents FPE from stupid values from masked region later on...) + + ztmp1 = u_star*u_star ! u*^2 + + !! Update wind at zu with convection-related wind gustiness in unstable conditions (Fairall et al. 2003, Eq.8): + ztmp2 = Beta0*Beta0*ztmp1*(MAX(-zi0*ztmp0/vkarmn,0._wp))**(2._wp/3._wp) ! square of wind gustiness contribution, ztmp2 == Ug^2 + !! ! Only true when unstable (L<0) => when ztmp0 < 0 => explains "-" before zi0 + Ubzu = MAX(SQRT(U_zu*U_zu + ztmp2), 0.2_wp) ! include gustiness in bulk wind speed + ! => 0.2 prevents Ubzu to be 0 in stable case when U_zu=0. + + !! Stability parameters: + zeta_u = zu*ztmp0 + zeta_u = SIGN( MIN(ABS(zeta_u),zeta_abs_max), zeta_u ) + IF( .NOT. l_zt_equal_zu ) THEN + zeta_t = zt*ztmp0 + zeta_t = SIGN( MIN(ABS(zeta_t),zeta_abs_max), zeta_t ) + ENDIF + + !! Adjustment the wind at 10m (not needed in the current algo form): + !IF( zu \= 10._wp ) U10 = U_zu + u_star/vkarmn*(LOG(10._wp/zu) - psi_m_coare(10._wp*ztmp0) + psi_m_coare(zeta_u)) + + !! Roughness lengthes z0, z0t (z0q = z0t) : + ztmp2 = u_star/vkarmn*LOG(10./z0) ! Neutral wind speed at 10m + z0 = charn_coare3p0(ztmp2)*ztmp1/grav + 0.11_wp*znu_a/u_star ! Roughness length (eq.6) [ ztmp1==u*^2 ] + z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + ztmp1 = ( znu_a / (z0*u_star) )**0.6_wp ! (1./Re_r)^0.72 (Re_r: roughness Reynolds number) COARE3.6-specific! + z0t = MIN( 1.1E-4_wp , 5.5E-5_wp*ztmp1 ) ! Scalar roughness for both theta and q (eq.28) #LB: some use 1.15 not 1.1 !!! + z0t = MIN( MAX(ABS(z0t), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + !! Turbulent scales at zu : + ztmp0 = psi_h_coare(zeta_u) + ztmp1 = vkarmn/(LOG(zu) - LOG(z0t) - ztmp0) ! #LB: in ztmp0, some use psi_h_coare(zeta_t) rather than psi_h_coare(zeta_t) ??? + + t_star = dt_zu*ztmp1 + q_star = dq_zu*ztmp1 + u_star = MAX( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) + + IF( .NOT. l_zt_equal_zu ) THEN + !! Re-updating temperature and humidity at zu if zt /= zu : + ztmp1 = LOG(zt/zu) + ztmp0 - psi_h_coare(zeta_t) + t_zu = t_zt - t_star/vkarmn*ztmp1 + q_zu = q_zt - q_star/vkarmn*ztmp1 + ENDIF + + IF(( l_use_cs ).OR.( l_use_wl )) THEN + zpre(:,:) = pres_temp( q_zu(:,:), slp(:,:), zu, ptpot=t_zu(:,:), pta=zta(:,:) ) + zrhoa(:,:) = rho_air( zta(:,:), q_zu(:,:), zpre(:,:) ) + ENDIF + + IF( l_use_cs ) THEN + !! Cool-skin contribution + + CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, zrhoa, & + & ztmp1, zeta_u, Qlat=ztmp2) ! Qnsol -> ztmp1 / Tau -> zeta_u + + CALL CS_COARE( Qsw, ztmp1, u_star, zsst, ztmp2 ) ! ! Qnsol -> ztmp1 / Qlat -> ztmp2 + + T_s(:,:) = zsst(:,:) + dT_cs(:,:)*tmask(:,:,1) + IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1) + q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) + ENDIF + + IF( l_use_wl ) THEN + !! Warm-layer contribution + CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, zrhoa, & + & ztmp1, zeta_u) ! Qnsol -> ztmp1 / Tau -> zeta_u + !! In WL_COARE or , Tau_ac and Qnt_ac must be updated at the final itteration step => add a flag to do this! + CALL WL_COARE( Qsw, ztmp1, zeta_u, zsst, MOD(nbit,jit) ) + + !! Updating T_s and q_s !!! + T_s(:,:) = zsst(:,:) + dT_wl(:,:)*tmask(:,:,1) + IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*tmask(:,:,1) + q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) + ENDIF + + IF( l_use_cs .OR. l_use_wl .OR. (.NOT. l_zt_equal_zu) ) THEN + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + ENDIF + + END DO !DO jit = 1, nbit + + ! compute transfer coefficients at zu : + ztmp0 = u_star/Ubzu + Cd = MAX( ztmp0*ztmp0 , Cx_min ) + Ch = MAX( ztmp0*t_star/dt_zu , Cx_min ) + Ce = MAX( ztmp0*q_star/dq_zu , Cx_min ) + + IF( .NOT. l_zt_equal_zu ) DEALLOCATE( zeta_t ) + + IF(PRESENT(Cdn)) Cdn = MAX( vkarmn2 / (LOG(zu/z0 )*LOG(zu/z0 )) , Cx_min ) + IF(PRESENT(Chn)) Chn = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) + IF(PRESENT(Cen)) Cen = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) + + IF( l_use_cs .AND. PRESENT(pdT_cs) ) pdT_cs = dT_cs + IF( l_use_wl .AND. PRESENT(pdT_wl) ) pdT_wl = dT_wl + IF( l_use_wl .AND. PRESENT(pHz_wl) ) pHz_wl = Hz_wl + + IF( l_use_cs .OR. l_use_wl ) DEALLOCATE ( zsst ) + + END SUBROUTINE turb_coare3p0 + + + FUNCTION charn_coare3p0( pwnd ) + !!------------------------------------------------------------------- + !! Compute the Charnock parameter as a function of the wind speed + !! + !! (Fairall et al., 2003 p.577-578) + !! + !! Wind below 10 m/s : alfa = 0.011 + !! Wind between 10 and 18 m/s : linear increase from 0.011 to 0.018 + !! Wind greater than 18 m/s : alfa = 0.018 + !! + !! Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p0 + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zw, zgt10, zgt18 + !!------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zw = pwnd(ji,jj) ! wind speed + ! + ! Charnock's constant, increases with the wind : + zgt10 = 0.5 + SIGN(0.5_wp,(zw - 10)) ! If zw<10. --> 0, else --> 1 + zgt18 = 0.5 + SIGN(0.5_wp,(zw - 18.)) ! If zw<18. --> 0, else --> 1 + ! + charn_coare3p0(ji,jj) = (1. - zgt10)*0.011 & ! wind is lower than 10 m/s + & + zgt10*((1. - zgt18)*(0.011 + (0.018 - 0.011) & + & *(zw - 10.)/(18. - 10.)) + zgt18*( 0.018 ) ) ! Hare et al. (1999) + ! + END_2D + END FUNCTION charn_coare3p0 + + FUNCTION psi_m_coare( pzeta ) + !!---------------------------------------------------------------------------------- + !! ** Purpose: compute the universal profile stability function for momentum + !! COARE 3.0, Fairall et al. 2003 + !! pzeta : stability paramenter, z/L where z is altitude + !! measurement and L is M-O length + !! Stability function for wind speed and scalars matching Kansas and free + !! convection forms with weighting f convective form, follows Fairall et + !! al (1996) with profile constants from Grachev et al (2000) BLM stable + !! form from Beljaars and Holtslag (1991) + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_coare + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab + !!---------------------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zta = pzeta(ji,jj) + ! + zphi_m = ABS(1. - 15.*zta)**.25 !!Kansas unstable + ! + zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.) & + & - 2.*ATAN(zphi_m) + 0.5*rpi + ! + zphi_c = ABS(1. - 10.15*zta)**.3333 !!Convective + ! + zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & + & - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 + ! + zf = zta*zta + zf = zf/(1. + zf) + zc = MIN(50._wp, 0.35_wp*zta) + zstab = 0.5 + SIGN(0.5_wp, zta) + ! + psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) + & - zstab * ( 1. + 1.*zta & ! (zta > 0) + & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! " + END_2D + END FUNCTION psi_m_coare + + + FUNCTION psi_h_coare( pzeta ) + !!--------------------------------------------------------------------- + !! Universal profile stability function for temperature and humidity + !! COARE 3.0, Fairall et al. 2003 + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! Stability function for wind speed and scalars matching Kansas and free + !! convection forms with weighting f convective form, follows Fairall et + !! al (1996) with profile constants from Grachev et al (2000) BLM stable + !! form from Beljaars and Holtslag (1991) + !! + !! Author: L. Brodeau, June 2016 / AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_coare + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab + !!---------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zta = pzeta(ji,jj) + ! + zphi_h = (ABS(1. - 15.*zta))**.5 !! Kansas unstable (zphi_h = zphi_m**2 when unstable, zphi_m when stable) + ! + zpsi_k = 2.*LOG((1. + zphi_h)/2.) + ! + zphi_c = (ABS(1. - 34.15*zta))**.3333 !! Convective + ! + zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & + & -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 + ! + zf = zta*zta + zf = zf/(1. + zf) + zc = MIN(50._wp,0.35_wp*zta) + zstab = 0.5 + SIGN(0.5_wp, zta) + ! + psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & + & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 & + & + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) + END_2D + END FUNCTION psi_h_coare + + !!====================================================================== +END MODULE sbcblk_algo_coare3p0 \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_coare3p6.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_coare3p6.F90 new file mode 100644 index 0000000..171d657 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_coare3p6.F90 @@ -0,0 +1,500 @@ +MODULE sbcblk_algo_coare3p6 + !!====================================================================== + !! *** MODULE sbcblk_algo_coare3p6 *** + !! + !! After Fairall et al 2018 & Edson et al 2013 + !! Computes: + !! * bulk transfer coefficients C_D, C_E and C_H + !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed + !! * the effective bulk wind speed at 10m Ubzu + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Routine turb_coare3p6 maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk) + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.0 ! 2016-02 (L.Brodeau) Original code + !! 4.2 ! 2020-12 (L. Brodeau) Introduction of various air-ice bulk parameterizations + improvements + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! turb_coare3p6 : computes the bulk turbulent transfer coefficients + !! adjusts t_air and q_air from zt to zu m + !! returns the effective bulk wind speed at 10m + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE lib_mpp, ONLY: ctl_stop ! distribued memory computing library + USE in_out_manager, ONLY: nit000 ! I/O manager + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + USE sbcblk_skin_coare ! cool-skin/warm layer scheme (CSWL_ECMWF) !LB + + IMPLICIT NONE + PRIVATE + + PUBLIC :: SBCBLK_ALGO_COARE3P6_INIT, TURB_COARE3P6 + !! * Substitutions +# include "do_loop_substitute.h90" + + !! COARE own values for given constants: + REAL(wp), PARAMETER :: zi0 = 600._wp ! scale height of the atmospheric boundary layer... + REAL(wp), PARAMETER :: Beta0 = 1.2_wp ! gustiness parameter + REAL(wp), PARAMETER :: zeta_abs_max = 50._wp + + !!---------------------------------------------------------------------- +CONTAINS + + + SUBROUTINE sbcblk_algo_coare3p6_init(l_use_cs, l_use_wl) + !!--------------------------------------------------------------------- + !! *** FUNCTION sbcblk_algo_coare3p6_init *** + !! + !! INPUT : + !! ------- + !! * l_use_cs : use the cool-skin parameterization + !! * l_use_wl : use the warm-layer parameterization + !!--------------------------------------------------------------------- + LOGICAL , INTENT(in) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in) :: l_use_wl ! use the warm-layer parameterization + INTEGER :: ierr + !!--------------------------------------------------------------------- + IF( l_use_wl ) THEN + ierr = 0 + ALLOCATE ( Tau_ac(jpi,jpj) , Qnt_ac(jpi,jpj), dT_wl(jpi,jpj), Hz_wl(jpi,jpj), STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P6_INIT => allocation of Tau_ac, Qnt_ac, dT_wl & Hz_wl failed!' ) + Tau_ac(:,:) = 0._wp + Qnt_ac(:,:) = 0._wp + dT_wl(:,:) = 0._wp + Hz_wl(:,:) = Hwl_max + ENDIF + IF( l_use_cs ) THEN + ierr = 0 + ALLOCATE ( dT_cs(jpi,jpj), STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_COARE3P6_INIT => allocation of dT_cs failed!' ) + dT_cs(:,:) = -0.25_wp ! First guess of skin correction + ENDIF + END SUBROUTINE sbcblk_algo_coare3p6_init + + + + SUBROUTINE turb_coare3p6( kt, zt, zu, T_s, t_zt, q_s, q_zt, U_zu, l_use_cs, l_use_wl, & + & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & + & nb_iter, Cdn, Chn, Cen, & ! optional output + & Qsw, rad_lw, slp, pdT_cs, & ! optionals for cool-skin (and warm-layer) + & pdT_wl, pHz_wl ) ! optionals for warm-layer only + !!---------------------------------------------------------------------- + !! *** ROUTINE turb_coare3p6 *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to Fairall et al. (2003) + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! Applies the cool-skin warm-layer correction of the SST to T_s + !! if the net shortwave flux at the surface (Qsw), the downwelling longwave + !! radiative fluxes at the surface (rad_lw), and the sea-leve pressure (slp) + !! are provided as (optional) arguments! + !! + !! INPUT : + !! ------- + !! * kt : current time step (starts at 1) + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * t_zt : potential air temperature at zt [K] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! * l_use_cs : use the cool-skin parameterization + !! * l_use_wl : use the warm-layer parameterization + !! + !! INPUT/OUTPUT: + !! ------------- + !! * T_s : always "bulk SST" as input [K] + !! -> unchanged "bulk SST" as output if CSWL not used [K] + !! -> skin temperature as output if CSWL used [K] + !! + !! * q_s : SSQ aka saturation specific humidity at temp. T_s [kg/kg] + !! -> doesn't need to be given a value if skin temp computed (in case l_use_cs=True or l_use_wl=True) + !! -> MUST be given the correct value if not computing skint temp. (in case l_use_cs=False or l_use_wl=False) + !! + !! OPTIONAL INPUT: + !! --------------- + !! * Qsw : net solar flux (after albedo) at the surface (>0) [W/m^2] + !! * rad_lw : downwelling longwave radiation at the surface (>0) [W/m^2] + !! * slp : sea-level pressure [Pa] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * pdT_cs : SST increment "dT" for cool-skin correction [K] + !! * pdT_wl : SST increment "dT" for warm-layer correction [K] + !! * pHz_wl : thickness of warm-layer [m] + !! + !! OUTPUT : + !! -------- + !! * Cd : drag coefficient + !! * Ch : sensible heat coefficient + !! * Ce : evaporation coefficient + !! * t_zu : pot. air temperature adjusted at wind height zu [K] + !! * q_zu : specific humidity of air // [kg/kg] + !! * Ubzu : bulk wind speed at zu [m/s] + !! + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! current time step + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + ! + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cdn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Chn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cen + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] + ! + INTEGER :: nbit, jit + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + ! + REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star + REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu + REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air + REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t + REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: zpre, zrhoa, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] + ! + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zeta_t ! stability parameter at height zt + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST + ! + CHARACTER(len=40), PARAMETER :: crtnm = 'turb_coare3p6@sbcblk_algo_coare3p6' + !!---------------------------------------------------------------------------------- + IF( kt == nit000 ) CALL SBCBLK_ALGO_COARE3P6_INIT(l_use_cs, l_use_wl) + + nbit = nb_iter0 + IF( PRESENT(nb_iter) ) nbit = nb_iter + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision + IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) + + !! Initializations for cool skin and warm layer: + IF( l_use_cs .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & + & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use cool-skin param!' ) + + IF( l_use_wl .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & + & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use warm-layer param!' ) + + IF( l_use_cs .OR. l_use_wl ) THEN + ALLOCATE ( zsst(jpi,jpj) ) + zsst = T_s ! backing up the bulk SST + IF( l_use_cs ) T_s = T_s - 0.25_wp ! First guess of correction + q_s = rdct_qsat_salt*q_sat(MAX(T_s, 200._wp), slp) ! First guess of q_s + ENDIF + + !! First guess of temperature and humidity at height zu: + t_zu = MAX( t_zt , 180._wp ) ! who knows what's given on masked-continental regions... + q_zu = MAX( q_zt , 1.e-6_wp ) ! " + + !! Pot. temp. difference (and we don't want it to be 0!) + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + + znu_a = visc_air(t_zu) ! Air viscosity (m^2/s) at zt given from temperature in (K) + + Ubzu = SQRT(U_zu*U_zu + 0.5_wp*0.5_wp) ! initial guess for wind gustiness contribution + + ztmp0 = LOG( zu*10000._wp) ! optimization: 10000. == 1/z0 (with z0 first guess == 0.0001) + ztmp1 = LOG(10._wp*10000._wp) ! " " " + u_star = 0.035_wp*Ubzu*ztmp1/ztmp0 ! (u* = 0.035*Un10) + + z0 = charn_coare3p6(U_zu)*u_star*u_star/grav + 0.11_wp*znu_a/u_star + z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + z0t = 1._wp / ( 0.1_wp*EXP(vkarmn/(0.00115/(vkarmn/ztmp1))) ) + z0t = MIN( MAX(ABS(z0t), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + Cd = MAX( (vkarmn/ztmp0)**2 , Cx_min ) ! first guess of Cd + + ztmp0 = vkarmn2/LOG(zt/z0t)/Cd + + ztmp2 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, Ubzu ) ! Bulk Richardson Number (BRN) + + !! First estimate of zeta_u, depending on the stability, ie sign of BRN (ztmp2): + ztmp1 = 0.5 + SIGN( 0.5_wp , ztmp2 ) + zeta_u = (1._wp - ztmp1) * ztmp0*ztmp2 / (1._wp - ztmp2*zi0*0.004_wp*Beta0**3/zu) & ! BRN < 0 + & + ztmp1 * ( ztmp0*ztmp2 + 27._wp/9._wp*ztmp2*ztmp2 ) ! BRN > 0 + + !! First guess M-O stability dependent scaling params.(u*,t*,q*) to estimate z0 and z/L + ztmp0 = vkarmn/(LOG(zu/z0t) - psi_h_coare(zeta_u)) + + u_star = MAX ( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) + t_star = dt_zu*ztmp0 + q_star = dq_zu*ztmp0 + + ! What needs to be done if zt /= zu: + IF( .NOT. l_zt_equal_zu ) THEN + !! First update of values at zu (or zt for wind) + zeta_t = zt*zeta_u/zu + ztmp0 = psi_h_coare(zeta_u) - psi_h_coare(zeta_t) + ztmp1 = LOG(zt/zu) + ztmp0 + t_zu = t_zt - t_star/vkarmn*ztmp1 + q_zu = q_zt - q_star/vkarmn*ztmp1 + q_zu = (0.5_wp + SIGN(0.5_wp,q_zu))*q_zu !Makes it impossible to have negative humidity : + ! + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + ENDIF + + !! ITERATION BLOCK + DO jit = 1, nbit + + !!Inverse of Obukov length (1/L) : + ztmp0 = One_on_L(t_zu, q_zu, u_star, t_star, q_star) ! 1/L == 1/[Obukhov length] + ztmp0 = SIGN( MIN(ABS(ztmp0),200._wp), ztmp0 ) ! 1/L (prevents FPE from stupid values from masked region later on...) + + ztmp1 = u_star*u_star ! u*^2 + + !! Update wind at zu with convection-related wind gustiness in unstable conditions (Fairall et al. 2003, Eq.8): + ztmp2 = Beta0*Beta0*ztmp1*(MAX(-zi0*ztmp0/vkarmn,0._wp))**(2._wp/3._wp) ! square of wind gustiness contribution, ztmp2 == Ug^2 + !! ! Only true when unstable (L<0) => when ztmp0 < 0 => explains "-" before zi0 + Ubzu = MAX(SQRT(U_zu*U_zu + ztmp2), 0.2_wp) ! include gustiness in bulk wind speed + ! => 0.2 prevents Ubzu to be 0 in stable case when U_zu=0. + + !! Stability parameters: + zeta_u = zu*ztmp0 + zeta_u = SIGN( MIN(ABS(zeta_u),zeta_abs_max), zeta_u ) + IF( .NOT. l_zt_equal_zu ) THEN + zeta_t = zt*ztmp0 + zeta_t = SIGN( MIN(ABS(zeta_t),zeta_abs_max), zeta_t ) + ENDIF + + !! Adjustment the wind at 10m (not needed in the current algo form): + !IF( zu \= 10._wp ) U10 = U_zu + u_star/vkarmn*(LOG(10._wp/zu) - psi_m_coare(10._wp*ztmp0) + psi_m_coare(zeta_u)) + + !! Roughness lengthes z0, z0t (z0q = z0t) : + ztmp2 = u_star/vkarmn*LOG(10./z0) ! Neutral wind speed at 10m + z0 = charn_coare3p6(ztmp2)*ztmp1/grav + 0.11_wp*znu_a/u_star ! Roughness length (eq.6) [ ztmp1==u*^2 ] + z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + ztmp1 = ( znu_a / (z0*u_star) )**0.72_wp ! COARE3.6-specific! (1./Re_r)^0.72 (Re_r: roughness Reynolds number) COARE3.6-specific! + z0t = MIN( 1.6E-4_wp , 5.8E-5_wp*ztmp1 ) ! COARE3.6-specific! + z0t = MIN( MAX(ABS(z0t), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + !! Turbulent scales at zu : + ztmp0 = psi_h_coare(zeta_u) + ztmp1 = vkarmn/(LOG(zu) - LOG(z0t) - ztmp0) ! #LB: in ztmp0, some use psi_h_coare(zeta_t) rather than psi_h_coare(zeta_t) ??? + + t_star = dt_zu*ztmp1 + q_star = dq_zu*ztmp1 + u_star = MAX( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) + + IF( .NOT. l_zt_equal_zu ) THEN + !! Re-updating temperature and humidity at zu if zt /= zu : + ztmp1 = LOG(zt/zu) + ztmp0 - psi_h_coare(zeta_t) + t_zu = t_zt - t_star/vkarmn*ztmp1 + q_zu = q_zt - q_star/vkarmn*ztmp1 + ENDIF + + IF(( l_use_cs ).OR.( l_use_wl )) THEN + zpre(:,:) = pres_temp( q_zu(:,:), slp(:,:), zu, ptpot=t_zu(:,:), pta=zta(:,:) ) + zrhoa(:,:) = rho_air( zta(:,:), q_zu(:,:), zpre(:,:) ) + ENDIF + + IF( l_use_cs ) THEN + !! Cool-skin contribution + + CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, zrhoa, & + & ztmp1, zeta_u, Qlat=ztmp2) ! Qnsol -> ztmp1 / Tau -> zeta_u + + CALL CS_COARE( Qsw, ztmp1, u_star, zsst, ztmp2 ) ! ! Qnsol -> ztmp1 / Qlat -> ztmp2 + + T_s(:,:) = zsst(:,:) + dT_cs(:,:)*tmask(:,:,1) + IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1) + q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) + ENDIF + + IF( l_use_wl ) THEN + !! Warm-layer contribution + CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, zrhoa, & + & ztmp1, zeta_u) ! Qnsol -> ztmp1 / Tau -> zeta_u + !! In WL_COARE or , Tau_ac and Qnt_ac must be updated at the final itteration step => add a flag to do this! + CALL WL_COARE( Qsw, ztmp1, zeta_u, zsst, MOD(nbit,jit) ) + + !! Updating T_s and q_s !!! + T_s(:,:) = zsst(:,:) + dT_wl(:,:)*tmask(:,:,1) + IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*tmask(:,:,1) + q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) + ENDIF + + IF( l_use_cs .OR. l_use_wl .OR. (.NOT. l_zt_equal_zu) ) THEN + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + ENDIF + + END DO !DO jit = 1, nbit + + ! compute transfer coefficients at zu : + ztmp0 = u_star/Ubzu + Cd = MAX( ztmp0*ztmp0 , Cx_min ) + Ch = MAX( ztmp0*t_star/dt_zu , Cx_min ) + Ce = MAX( ztmp0*q_star/dq_zu , Cx_min ) + + IF( .NOT. l_zt_equal_zu ) DEALLOCATE( zeta_t ) + + IF(PRESENT(Cdn)) Cdn = MAX( vkarmn2 / (LOG(zu/z0 )*LOG(zu/z0 )) , Cx_min ) + IF(PRESENT(Chn)) Chn = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) + IF(PRESENT(Cen)) Cen = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) + + IF( l_use_cs .AND. PRESENT(pdT_cs) ) pdT_cs = dT_cs + IF( l_use_wl .AND. PRESENT(pdT_wl) ) pdT_wl = dT_wl + IF( l_use_wl .AND. PRESENT(pHz_wl) ) pHz_wl = Hz_wl + + IF( l_use_cs .OR. l_use_wl ) DEALLOCATE ( zsst ) + + END SUBROUTINE turb_coare3p6 + + + FUNCTION charn_coare3p6( pwnd ) + !!------------------------------------------------------------------- + !! Computes the Charnock parameter as a function of the Neutral wind speed at 10m + !! "wind speed dependent formulation" + !! (Eq. 13 in Edson et al., 2013) + !! + !! Author: L. Brodeau, July 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p6 + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! neutral wind speed at 10m + ! + REAL(wp), PARAMETER :: charn0_max = 0.028 !: value above which the Charnock parameter levels off for winds > 18 m/s + !!------------------------------------------------------------------- + charn_coare3p6 = MAX( MIN( 0.0017_wp*pwnd - 0.005_wp , charn0_max) , 0._wp ) + !! + END FUNCTION charn_coare3p6 + + FUNCTION charn_coare3p6_wave( pus, pwsh, pwps ) + !!------------------------------------------------------------------- + !! Computes the Charnock parameter as a function of wave information and u* + !! + !! (COARE 3.6, Fairall et al., 2018) + !! + !! Author: L. Brodeau, October 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: charn_coare3p6_wave + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwsh ! significant wave height [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwps ! phase speed of dominant waves [m/s] + !!------------------------------------------------------------------- + charn_coare3p6_wave = ( pwsh*0.2_wp*(pus/pwps)**2.2_wp ) * grav/(pus*pus) + !! + END FUNCTION charn_coare3p6_wave + + + FUNCTION psi_m_coare( pzeta ) + !!---------------------------------------------------------------------------------- + !! ** Purpose: compute the universal profile stability function for momentum + !! COARE 3.0, Fairall et al. 2003 + !! pzeta : stability paramenter, z/L where z is altitude + !! measurement and L is M-O length + !! Stability function for wind speed and scalars matching Kansas and free + !! convection forms with weighting f convective form, follows Fairall et + !! al (1996) with profile constants from Grachev et al (2000) BLM stable + !! form from Beljaars and Holtslag (1991) + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_coare + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zphi_m, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab + !!---------------------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zta = pzeta(ji,jj) + ! + zphi_m = ABS(1. - 15.*zta)**.25 !!Kansas unstable + ! + zpsi_k = 2.*LOG((1. + zphi_m)/2.) + LOG((1. + zphi_m*zphi_m)/2.) & + & - 2.*ATAN(zphi_m) + 0.5*rpi + ! + zphi_c = ABS(1. - 10.15*zta)**.3333 !!Convective + ! + zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & + & - 1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 + ! + zf = zta*zta + zf = zf/(1. + zf) + zc = MIN(50._wp, 0.35_wp*zta) + zstab = 0.5 + SIGN(0.5_wp, zta) + ! + psi_m_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & ! (zta < 0) + & - zstab * ( 1. + 1.*zta & ! (zta > 0) + & + 0.6667*(zta - 14.28)/EXP(zc) + 8.525 ) ! " + END_2D + END FUNCTION psi_m_coare + + + FUNCTION psi_h_coare( pzeta ) + !!--------------------------------------------------------------------- + !! Universal profile stability function for temperature and humidity + !! COARE 3.0, Fairall et al. 2003 + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! Stability function for wind speed and scalars matching Kansas and free + !! convection forms with weighting f convective form, follows Fairall et + !! al (1996) with profile constants from Grachev et al (2000) BLM stable + !! form from Beljaars and Holtslag (1991) + !! + !! Author: L. Brodeau, June 2016 / AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_coare + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab + !!---------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zta = pzeta(ji,jj) + ! + zphi_h = (ABS(1. - 15.*zta))**.5 !! Kansas unstable (zphi_h = zphi_m**2 when unstable, zphi_m when stable) + ! + zpsi_k = 2.*LOG((1. + zphi_h)/2.) + ! + zphi_c = (ABS(1. - 34.15*zta))**.3333 !! Convective + ! + zpsi_c = 1.5*LOG((1. + zphi_c + zphi_c*zphi_c)/3.) & + & -1.7320508*ATAN((1. + 2.*zphi_c)/1.7320508) + 1.813799447 + ! + zf = zta*zta + zf = zf/(1. + zf) + zc = MIN(50._wp,0.35_wp*zta) + zstab = 0.5 + SIGN(0.5_wp, zta) + ! + psi_h_coare(ji,jj) = (1. - zstab) * ( (1. - zf)*zpsi_k + zf*zpsi_c ) & + & - zstab * ( (ABS(1. + 2.*zta/3.))**1.5 & + & + .6667*(zta - 14.28)/EXP(zc) + 8.525 ) + END_2D + END FUNCTION psi_h_coare + + !!====================================================================== +END MODULE sbcblk_algo_coare3p6 \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ecmwf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ecmwf.F90 new file mode 100644 index 0000000..2a37be0 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ecmwf.F90 @@ -0,0 +1,489 @@ +MODULE sbcblk_algo_ecmwf + !!====================================================================== + !! *** MODULE sbcblk_algo_ecmwf *** + !! Computes: + !! * bulk transfer coefficients C_D, C_E and C_H + !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed + !! * the effective bulk wind speed at 10m Ubzu + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Using the bulk formulation/param. of IFS of ECMWF (cycle 40r1) + !! based on IFS doc (avaible online on the ECMWF's website) + !! + !! Routine turb_ecmwf maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk) + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.0 ! 2016-02 (L.Brodeau) Original code + !! 4.2 ! 2020-12 (L. Brodeau) Introduction of various air-ice bulk parameterizations + improvements + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! turb_ecmwf : computes the bulk turbulent transfer coefficients + !! adjusts t_air and q_air from zt to zu m + !! returns the effective bulk wind speed at 10m + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE lib_mpp, ONLY: ctl_stop ! distribued memory computing library + USE in_out_manager, ONLY: nit000 ! I/O manager + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + USE sbcblk_skin_ecmwf ! cool-skin/warm layer scheme !LB + USE sbcwave, ONLY : charn + USE sbc_oce, ONLY : ln_charn ! wave module + + IMPLICIT NONE + PRIVATE + + PUBLIC :: SBCBLK_ALGO_ECMWF_INIT, TURB_ECMWF + + !! ECMWF own values for given constants, taken form IFS documentation... + REAL(wp), PARAMETER, PUBLIC :: charn0_ecmwf = 0.018_wp ! Charnock constant (pretty high value here !!! + ! ! => Usually 0.011 for moderate winds) + REAL(wp), PARAMETER :: zi0 = 1000. ! scale height of the atmospheric boundary layer...1 + REAL(wp), PARAMETER :: Beta0 = 1. ! gustiness parameter ( = 1.25 in COAREv3) + REAL(wp), PARAMETER :: alpha_M = 0.11 ! For roughness length (smooth surface term) + REAL(wp), PARAMETER :: alpha_H = 0.40 ! (Chapter 3, p.34, IFS doc Cy31r1) + REAL(wp), PARAMETER :: alpha_Q = 0.62 ! + + !! * Substitutions +# include "do_loop_substitute.h90" + + !!---------------------------------------------------------------------- +CONTAINS + + + SUBROUTINE sbcblk_algo_ecmwf_init(l_use_cs, l_use_wl) + !!--------------------------------------------------------------------- + !! *** FUNCTION sbcblk_algo_ecmwf_init *** + !! + !! INPUT : + !! ------- + !! * l_use_cs : use the cool-skin parameterization + !! * l_use_wl : use the warm-layer parameterization + !!--------------------------------------------------------------------- + LOGICAL , INTENT(in) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in) :: l_use_wl ! use the warm-layer parameterization + INTEGER :: ierr + !!--------------------------------------------------------------------- + IF( l_use_wl ) THEN + ierr = 0 + ALLOCATE ( dT_wl(jpi,jpj), Hz_wl(jpi,jpj), STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_ECMWF_INIT => allocation of dT_wl & Hz_wl failed!' ) + dT_wl(:,:) = 0._wp + Hz_wl(:,:) = rd0 ! (rd0, constant, = 3m is default for Zeng & Beljaars) + ENDIF + IF( l_use_cs ) THEN + ierr = 0 + ALLOCATE ( dT_cs(jpi,jpj), STAT=ierr ) + IF( ierr > 0 ) CALL ctl_stop( ' SBCBLK_ALGO_ECMWF_INIT => allocation of dT_cs failed!' ) + dT_cs(:,:) = -0.25_wp ! First guess of skin correction + ENDIF + END SUBROUTINE sbcblk_algo_ecmwf_init + + + + SUBROUTINE turb_ecmwf( kt, zt, zu, T_s, t_zt, q_s, q_zt, U_zu, l_use_cs, l_use_wl, & + & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & + & nb_iter, Cdn, Chn, Cen, & ! optional output + & Qsw, rad_lw, slp, pdT_cs, & ! optionals for cool-skin (and warm-layer) + & pdT_wl, pHz_wl ) ! optionals for warm-layer only + !!---------------------------------------------------------------------------------- + !! *** ROUTINE turb_ecmwf *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to IFS doc. (cycle 45r1) + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! Applies the cool-skin warm-layer correction of the SST to T_s + !! if the net shortwave flux at the surface (Qsw), the downwelling longwave + !! radiative fluxes at the surface (rad_lw), and the sea-leve pressure (slp) + !! are provided as (optional) arguments! + !! + !! INPUT : + !! ------- + !! * kt : current time step (starts at 1) + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * t_zt : potential air temperature at zt [K] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! * l_use_cs : use the cool-skin parameterization + !! * l_use_wl : use the warm-layer parameterization + !! + !! INPUT/OUTPUT: + !! ------------- + !! * T_s : always "bulk SST" as input [K] + !! -> unchanged "bulk SST" as output if CSWL not used [K] + !! -> skin temperature as output if CSWL used [K] + !! + !! * q_s : SSQ aka saturation specific humidity at temp. T_s [kg/kg] + !! -> doesn't need to be given a value if skin temp computed (in case l_use_cs=True or l_use_wl=True) + !! -> MUST be given the correct value if not computing skint temp. (in case l_use_cs=False or l_use_wl=False) + !! + !! OPTIONAL INPUT: + !! --------------- + !! * Qsw : net solar flux (after albedo) at the surface (>0) [W/m^2] + !! * rad_lw : downwelling longwave radiation at the surface (>0) [W/m^2] + !! * slp : sea-level pressure [Pa] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * pdT_cs : SST increment "dT" for cool-skin correction [K] + !! * pdT_wl : SST increment "dT" for warm-layer correction [K] + !! * pHz_wl : thickness of warm-layer [m] + !! + !! OUTPUT : + !! -------- + !! * Cd : drag coefficient + !! * Ch : sensible heat coefficient + !! * Ce : evaporation coefficient + !! * t_zu : pot. air temperature adjusted at wind height zu [K] + !! * q_zu : specific humidity of air // [kg/kg] + !! * Ubzu : bulk wind speed at zu [m/s] + !! + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! current time step + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: T_s ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: q_s ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + LOGICAL , INTENT(in ) :: l_use_cs ! use the cool-skin parameterization + LOGICAL , INTENT(in ) :: l_use_wl ! use the warm-layer parameterization + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + ! + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cdn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Chn + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: Cen + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: Qsw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: rad_lw ! [W/m^2] + REAL(wp), INTENT(in ), OPTIONAL, DIMENSION(jpi,jpj) :: slp ! [Pa] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_cs + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pdT_wl ! [K] + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: pHz_wl ! [m] + ! + INTEGER :: nbit, jit + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + ! + REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star + REAL(wp), DIMENSION(jpi,jpj) :: dt_zu, dq_zu + REAL(wp), DIMENSION(jpi,jpj) :: znu_a !: Nu_air, Viscosity of air + REAL(wp), DIMENSION(jpi,jpj) :: Linv !: 1/L (inverse of Monin Obukhov length... + REAL(wp), DIMENSION(jpi,jpj) :: z0, z0t, z0q + REAL(wp), DIMENSION(jpi,jpj) :: zrhoa, zpre, zta ! air pressure [Pa], density [kg/m3] & absolute temperature [k] + ! + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsst ! to back up the initial bulk SST + ! + REAL(wp), DIMENSION(jpi,jpj) :: func_m, func_h + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ecmwf@sbcblk_algo_ecmwf.F90' + !!---------------------------------------------------------------------------------- + IF( kt == nit000 ) CALL SBCBLK_ALGO_ECMWF_INIT(l_use_cs, l_use_wl) + + nbit = nb_iter0 + IF( PRESENT(nb_iter) ) nbit = nb_iter + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision + + !! Initializations for cool skin and warm layer: + IF( l_use_cs .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & + & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use cool-skin param!' ) + + IF( l_use_wl .AND. (.NOT.(PRESENT(Qsw) .AND. PRESENT(rad_lw) .AND. PRESENT(slp))) ) & + & CALL ctl_stop( '['//TRIM(crtnm)//'] => ' , 'you need to provide Qsw, rad_lw & slp to use warm-layer param!' ) + + IF( l_use_cs .OR. l_use_wl ) THEN + ALLOCATE ( zsst(jpi,jpj) ) + zsst = T_s ! backing up the bulk SST + IF( l_use_cs ) T_s = T_s - 0.25_wp ! First guess of correction + q_s = rdct_qsat_salt*q_sat(MAX(T_s, 200._wp), slp) ! First guess of q_s + ENDIF + + + ! Identical first gess as in COARE, with IFS parameter values though... + ! + !! First guess of temperature and humidity at height zu: + t_zu = MAX( t_zt , 180._wp ) ! who knows what's given on masked-continental regions... + q_zu = MAX( q_zt , 1.e-6_wp ) ! " + + !! Pot. temp. difference (and we don't want it to be 0!) + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + + znu_a = visc_air(t_zu) ! Air viscosity (m^2/s) at zt given from temperature in (K) + + Ubzu = SQRT(U_zu*U_zu + 0.5_wp*0.5_wp) ! initial guess for wind gustiness contribution + + ztmp0 = LOG( zu*10000._wp) ! optimization: 10000. == 1/z0 (with z0 first guess == 0.0001) + ztmp1 = LOG(10._wp*10000._wp) ! " " " + u_star = 0.035_wp*Ubzu*ztmp1/ztmp0 ! (u* = 0.035*Un10) + + IF (ln_charn) THEN ! Charnock value if wave coupling + z0 = charn*u_star*u_star/grav + 0.11_wp*znu_a/u_star + ELSE + z0 = charn0_ecmwf*u_star*u_star/grav + 0.11_wp*znu_a/u_star + ENDIF + z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + z0t = 1._wp / ( 0.1_wp*EXP(vkarmn/(0.00115/(vkarmn/ztmp1))) ) + z0t = MIN( MAX(ABS(z0t), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) + + Cd = MAX( (vkarmn/ztmp0)**2 , Cx_min ) ! first guess of Cd + + ztmp0 = vkarmn2/LOG(zt/z0t)/Cd + + ztmp2 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, Ubzu ) ! Bulk Richardson Number (BRN) + + !! First estimate of zeta_u, depending on the stability, ie sign of BRN (ztmp2): + ztmp1 = 0.5 + SIGN( 0.5_wp , ztmp2 ) + func_h = (1._wp - ztmp1) * ztmp0*ztmp2 / (1._wp - ztmp2*zi0*0.004_wp*Beta0**3/zu) & ! BRN < 0 + & + ztmp1 * ( ztmp0*ztmp2 + 27._wp/9._wp*ztmp2*ztmp2 ) ! BRN > 0 + + !! First guess M-O stability dependent scaling params.(u*,t*,q*) to estimate z0 and z/L + ztmp0 = vkarmn/(LOG(zu/z0t) - psi_h_ecmwf(func_h)) + + u_star = MAX ( Ubzu*vkarmn/(LOG(zu) - LOG(z0) - psi_m_ecmwf(func_h)) , 1.E-9 ) ! (MAX => prevents FPE from stupid values from masked region later on) + t_star = dt_zu*ztmp0 + q_star = dq_zu*ztmp0 + + ! What needs to be done if zt /= zu: + IF( .NOT. l_zt_equal_zu ) THEN + !! First update of values at zu (or zt for wind) + ztmp0 = psi_h_ecmwf(func_h) - psi_h_ecmwf(zt*func_h/zu) ! zt*func_h/zu == zeta_t + ztmp1 = LOG(zt/zu) + ztmp0 + t_zu = t_zt - t_star/vkarmn*ztmp1 + q_zu = q_zt - q_star/vkarmn*ztmp1 + q_zu = (0.5_wp + SIGN(0.5_wp,q_zu))*q_zu !Makes it impossible to have negative humidity : + ! + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + ENDIF + + + !! => that was same first guess as in COARE... + + + !! First guess of inverse of Obukov length (1/L) : + Linv = One_on_L( t_zu, q_zu, u_star, t_star, q_star ) + + !! Functions such as u* = Ubzu*vkarmn/func_m + ztmp0 = zu*Linv + func_m = LOG(zu) - LOG(z0) - psi_m_ecmwf(ztmp0) + psi_m_ecmwf( z0*Linv) + func_h = LOG(zu) - LOG(z0t) - psi_h_ecmwf(ztmp0) + psi_h_ecmwf(z0t*Linv) + + !! ITERATION BLOCK + DO jit = 1, nbit + + !! Bulk Richardson Number at z=zu (Eq. 3.25) + ztmp0 = Ri_bulk( zu, T_s, t_zu, q_s, q_zu, Ubzu ) ! Bulk Richardson Number (BRN) + + !! New estimate of the inverse of the Obukhon length (Linv == zeta/zu) : + Linv = ztmp0*func_m*func_m/func_h / zu ! From Eq. 3.23, Chap.3.2.3, IFS doc - Cy40r1 + !! Note: it is slightly different that the L we would get with the usual + Linv = SIGN( MIN(ABS(Linv),200._wp), Linv ) ! (prevent FPE from stupid values from masked region later on...) + + !! Update func_m with new Linv: + func_m = LOG(zu) -LOG(z0) - psi_m_ecmwf(zu*Linv) + psi_m_ecmwf(z0*Linv) ! LB: should be "zu+z0" rather than "zu" alone, but z0 is tiny wrt zu! + + !! Need to update roughness lengthes: + u_star = Ubzu*vkarmn/func_m + ztmp2 = u_star*u_star + ztmp1 = znu_a/u_star + IF (ln_charn) THEN ! Charnock value if wave coupling + z0 = MIN( ABS( alpha_M*ztmp1 + charn*ztmp2/grav ) , 0.001_wp) + ELSE + z0 = MIN( ABS( alpha_M*ztmp1 + charn0_ecmwf*ztmp2/grav ) , 0.001_wp) + ENDIF + z0 = MIN( ABS( alpha_M*ztmp1 + charn0_ecmwf*ztmp2/grav ) , 0.001_wp) + z0t = MIN( ABS( alpha_H*ztmp1 ) , 0.001_wp) ! eq.3.26, Chap.3, p.34, IFS doc - Cy31r1 + z0q = MIN( ABS( alpha_Q*ztmp1 ) , 0.001_wp) + + !! Update wind at zu with convection-related wind gustiness in unstable conditions (Chap. 3.2, IFS doc - Cy40r1, Eq.3.17 and Eq.3.18 + Eq.3.8) + ztmp2 = Beta0*Beta0*ztmp2*(MAX(-zi0*Linv/vkarmn,0._wp))**(2._wp/3._wp) ! square of wind gustiness contribution (combining Eq. 3.8 and 3.18, hap.3, IFS doc - Cy31r1) + !! ! Only true when unstable (L<0) => when ztmp0 < 0 => explains "-" before zi0 + Ubzu = MAX(SQRT(U_zu*U_zu + ztmp2), 0.2_wp) ! include gustiness in bulk wind speed + ! => 0.2 prevents Ubzu to be 0 in stable case when U_zu=0. + + + !! Need to update "theta" and "q" at zu in case they are given at different heights + !! as well the air-sea differences: + IF( .NOT. l_zt_equal_zu ) THEN + !! Arrays func_m and func_h are free for a while so using them as temporary arrays... + func_h = psi_h_ecmwf(zu*Linv) ! temporary array !!! + func_m = psi_h_ecmwf(zt*Linv) ! temporary array !!! + + ztmp2 = psi_h_ecmwf(z0t*Linv) + ztmp0 = func_h - ztmp2 + ztmp1 = vkarmn/(LOG(zu) - LOG(z0t) - ztmp0) + t_star = dt_zu*ztmp1 + ztmp2 = ztmp0 - func_m + ztmp2 + ztmp1 = LOG(zt/zu) + ztmp2 + t_zu = t_zt - t_star/vkarmn*ztmp1 + + ztmp2 = psi_h_ecmwf(z0q*Linv) + ztmp0 = func_h - ztmp2 + ztmp1 = vkarmn/(LOG(zu) - LOG(z0q) - ztmp0) + q_star = dq_zu*ztmp1 + ztmp2 = ztmp0 - func_m + ztmp2 + ztmp1 = LOG(zt/zu) + ztmp2 + q_zu = q_zt - q_star/vkarmn*ztmp1 + ENDIF + + !! Updating because of updated z0 and z0t and new Linv... + ztmp0 = zu*Linv + func_m = log(zu) - LOG(z0 ) - psi_m_ecmwf(ztmp0) + psi_m_ecmwf(z0 *Linv) + func_h = log(zu) - LOG(z0t) - psi_h_ecmwf(ztmp0) + psi_h_ecmwf(z0t*Linv) + + IF(( l_use_cs ).OR.( l_use_wl )) THEN + zpre(:,:) = pres_temp( q_zu(:,:), slp(:,:), zu, ptpot=t_zu(:,:), pta=zta(:,:) ) + zrhoa(:,:) = rho_air( zta(:,:), q_zu(:,:), zpre(:,:) ) + ENDIF + + IF( l_use_cs ) THEN + !! Cool-skin contribution + + CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, zrhoa, & + & ztmp1, ztmp0, Qlat=ztmp2) ! Qnsol -> ztmp1 / Tau -> ztmp0 + + CALL CS_ECMWF( Qsw, ztmp1, u_star, zsst ) ! Qnsol -> ztmp1 + + T_s(:,:) = zsst(:,:) + dT_cs(:,:)*tmask(:,:,1) + IF( l_use_wl ) T_s(:,:) = T_s(:,:) + dT_wl(:,:)*tmask(:,:,1) + q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) + + ENDIF + + IF( l_use_wl ) THEN + !! Warm-layer contribution + CALL UPDATE_QNSOL_TAU( zu, T_s, q_s, t_zu, q_zu, u_star, t_star, q_star, U_zu, Ubzu, slp, rad_lw, zrhoa, & + & ztmp1, ztmp2) ! Qnsol -> ztmp1 / Tau -> ztmp2 + CALL WL_ECMWF( Qsw, ztmp1, u_star, zsst ) + !! Updating T_s and q_s !!! + T_s(:,:) = zsst(:,:) + dT_wl(:,:)*tmask(:,:,1) ! + IF( l_use_cs ) T_s(:,:) = T_s(:,:) + dT_cs(:,:)*tmask(:,:,1) + q_s(:,:) = rdct_qsat_salt*q_sat(MAX(T_s(:,:), 200._wp), slp(:,:)) + ENDIF + + IF( l_use_cs .OR. l_use_wl .OR. (.NOT. l_zt_equal_zu) ) THEN + dt_zu = t_zu - T_s ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu - q_s ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + ENDIF + + END DO !DO jit = 1, nbit + + Cd = MAX( vkarmn2/(func_m*func_m) , Cx_min ) + Ch = MAX( vkarmn2/(func_m*func_h) , Cx_min ) + ztmp2 = LOG(zu/z0q) - psi_h_ecmwf(zu*Linv) + psi_h_ecmwf(z0q*Linv) ! func_q + Ce = MAX( vkarmn2/(func_m*ztmp2) , Cx_min ) + + IF(PRESENT(Cdn)) Cdn = MAX( vkarmn2 / (LOG(zu/z0 )*LOG(zu/z0 )) , Cx_min ) + IF(PRESENT(Chn)) Chn = MAX( vkarmn2 / (LOG(zu/z0t)*LOG(zu/z0t)) , Cx_min ) + IF(PRESENT(Cen)) Cen = MAX( vkarmn2 / (LOG(zu/z0q)*LOG(zu/z0q)) , Cx_min ) + + IF( l_use_cs .AND. PRESENT(pdT_cs) ) pdT_cs = dT_cs + IF( l_use_wl .AND. PRESENT(pdT_wl) ) pdT_wl = dT_wl + IF( l_use_wl .AND. PRESENT(pHz_wl) ) pHz_wl = Hz_wl + + IF( l_use_cs .OR. l_use_wl ) DEALLOCATE ( zsst ) + + END SUBROUTINE turb_ecmwf + + + FUNCTION psi_m_ecmwf( pzeta ) + !!---------------------------------------------------------------------------------- + !! Universal profile stability function for momentum + !! ECMWF / as in IFS cy31r1 documentation, available online + !! at ecmwf.int + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ecmwf + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx2, zx, ztmp, zpsi_unst, zpsi_stab, zstab, zc + !!---------------------------------------------------------------------------------- + zc = 5._wp/0.35_wp + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zta = MIN( pzeta(ji,jj) , 5._wp ) !! Very stable conditions (L positif and big!): + + ! *** Unstable (Paulson 1970) [eq.3.20, Chap.3, p.33, IFS doc - Cy31r1] : + zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 - 16z)^0.5 + zx = SQRT(zx2) ! (1 - 16z)^0.25 + ztmp = 1._wp + zx + zpsi_unst = LOG( 0.125_wp*ztmp*ztmp*(1._wp + zx2) ) - 2._wp*ATAN( zx ) + 0.5_wp*rpi + + ! *** Stable [eq.3.22, Chap.3, p.33, IFS doc - Cy31r1] : + zpsi_stab = -2._wp/3._wp*(zta - zc)*EXP(-0.35_wp*zta) & + & - zta - 2._wp/3._wp*zc + ! + zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 + ! + psi_m_ecmwf(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable + ! + END_2D + END FUNCTION psi_m_ecmwf + + + FUNCTION psi_h_ecmwf( pzeta ) + !!---------------------------------------------------------------------------------- + !! Universal profile stability function for temperature and humidity + !! ECMWF / as in IFS cy31r1 documentation, available online + !! at ecmwf.int + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ecmwf + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab, zc + !!---------------------------------------------------------------------------------- + zc = 5._wp/0.35_wp + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zta = MIN(pzeta(ji,jj) , 5._wp) ! Very stable conditions (L positif and big!): + ! + ! *** Unstable (Paulson 1970) [eq.3.20, Chap.3, p.33, IFS doc - Cy31r1] : + zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 -16z)^0.5 + zpsi_unst = 2._wp*LOG( 0.5_wp*(1._wp + zx2) ) + ! + ! *** Stable [eq.3.22, Chap.3, p.33, IFS doc - Cy31r1] : + zpsi_stab = -2._wp/3._wp*(zta - zc)*EXP(-0.35_wp*zta) & + & - ABS(1._wp + 2._wp/3._wp*zta)**1.5_wp - 2._wp/3._wp*zc + 1._wp + ! + ! LB: added ABS() to avoid NaN values when unstable, which contaminates the unstable solution... + ! + zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 + ! + psi_h_ecmwf(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable + ! + END_2D + END FUNCTION psi_h_ecmwf + + + !!====================================================================== +END MODULE sbcblk_algo_ecmwf \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_an05.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_an05.F90 new file mode 100644 index 0000000..287277b --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_an05.F90 @@ -0,0 +1,389 @@ +MODULE sbcblk_algo_ice_an05 + !!====================================================================== + !! *** MODULE sbcblk_algo_ice_an05 *** + !! Computes turbulent components of surface fluxes over sea-ice + !! + !! Andreas, E.L., Jordan, R.E. & Makshtas, A.P. Parameterizing turbulent exchange over sea ice: the ice station weddell results. + !! Boundary-Layer Meteorology 114, 439–460 (2005). https://doi.org/10.1007/s10546-004-1414-7 + !! + !! * bulk transfer coefficients C_D, C_E and C_H + !! * air temp. and spec. hum. adjusted from zt (usually 2m) to zu (usually 10m) if needed + !! * the "effective" bulk wind speed at zu: Ub (including gustiness contribution in unstable conditions) + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Routine turb_ice_an05 maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !! + !! Author: Laurent Brodeau, Summer 2020 + !! + !!---------------------------------------------------------------------- + USE par_kind, ONLY: wp + USE par_oce, ONLY: jpi, jpj, Nis0, Nie0, Njs0, Nje0, nn_hls, ntsi, ntsj, ntei, ntej + USE lib_mpp, ONLY: ctl_stop ! distribued memory computing library + USE phycst ! physical constants + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + + IMPLICIT NONE + PRIVATE + + PUBLIC :: turb_ice_an05 + + INTEGER , PARAMETER :: nbit = 8 ! number of itterations + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE turb_ice_an05( zt, zu, Ts_i, t_zt, qs_i, q_zt, U_zu, & + & Cd_i, Ch_i, Ce_i, t_zu_i, q_zu_i, & + & CdN, ChN, CeN, xz0, xu_star, xL, xUN10 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE turb_ice_an05 *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to: + !! Andreas, E.L., Jordan, R.E. & Makshtas, A.P. Parameterizing turbulent exchange over sea ice: the ice station weddell results. + !! Boundary-Layer Meteorology 114, 439–460 (2005). https://doi.org/10.1007/s10546-004-1414-7 + !! + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! INPUT : + !! ------- + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * Ts_i : surface temperature of sea-ice [K] + !! * t_zt : potential air temperature at zt [K] + !! * qs_i : saturation specific humidity at temp. Ts_i over ice [kg/kg] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! + !! OUTPUT : + !! -------- + !! * Cd_i : drag coefficient over sea-ice + !! * Ch_i : sensible heat coefficient over sea-ice + !! * Ce_i : sublimation coefficient over sea-ice + !! * t_zu_i : pot. air temp. adjusted at zu over sea-ice [K] + !! * q_zu_i : spec. hum. of air adjusted at zu over sea-ice [kg/kg] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * CdN : neutral-stability drag coefficient + !! * ChN : neutral-stability sensible heat coefficient + !! * CeN : neutral-stability evaporation coefficient + !! * xz0 : return the aerodynamic roughness length (integration constant for wind stress) [m] + !! * xu_star : return u* the friction velocity [m/s] + !! * xL : return the Obukhov length [m] + !! * xUN10 : neutral wind speed at 10m [m/s] + !! + !! ** Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: Ts_i ! ice surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp0, ztmp1, ztmp2 ! temporary stuff + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: z0, dt_zu, dq_zu + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: u_star, t_star, q_star + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: znu_a !: Nu_air = kinematic viscosity of air + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zeta_u, zeta_t ! stability parameter at height zu + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: z0tq + !! + INTEGER :: jit + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + !! + LOGICAL :: lreturn_cdn=.FALSE., lreturn_chn=.FALSE., lreturn_cen=.FALSE. + LOGICAL :: lreturn_z0=.FALSE., lreturn_ustar=.FALSE., lreturn_L=.FALSE., lreturn_UN10=.FALSE. + !! + CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ice_an05@sbcblk_algo_ice_an05.f90' + !!---------------------------------------------------------------------------------- + ALLOCATE ( Ubzu(jpi,jpj), u_star(jpi,jpj), t_star(jpi,jpj), q_star(jpi,jpj), & + & zeta_u(jpi,jpj), dt_zu(jpi,jpj), dq_zu(jpi,jpj), & + & znu_a(jpi,jpj), ztmp1(jpi,jpj), ztmp2(jpi,jpj), & + & z0(jpi,jpj), z0tq(jpi,jpj,2), ztmp0(jpi,jpj) ) + + lreturn_cdn = PRESENT(CdN) + lreturn_chn = PRESENT(ChN) + lreturn_cen = PRESENT(CeN) + lreturn_z0 = PRESENT(xz0) + lreturn_ustar = PRESENT(xu_star) + lreturn_L = PRESENT(xL) + lreturn_UN10 = PRESENT(xUN10) + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) + IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) + + !! Scalar wind speed cannot be below 0.2 m/s + Ubzu = MAX( U_zu, wspd_thrshld_ice ) + + !! First guess of temperature and humidity at height zu: + t_zu_i = MAX( t_zt , 100._wp ) ! who knows what's given on masked-continental regions... + q_zu_i = MAX( q_zt , 0.1e-6_wp ) ! " + + !! Air-Ice differences (and we don't want it to be 0!) + dt_zu = t_zu_i - Ts_i ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu_i - qs_i ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + + znu_a = visc_air(t_zu_i) ! Air viscosity (m^2/s) at zt given from temperature in (K) + + !! Very crude first guesses of z0: + z0 = 8.0E-4_wp + + !! Crude first guess of turbulent scales + u_star = 0.035_wp*Ubzu*LOG( 10._wp/z0 )/LOG( zu/z0 ) + z0 = rough_leng_m( u_star , znu_a ) + + DO jit = 1, 2 + u_star = MAX ( Ubzu*vkarmn/(LOG(zu) - LOG(z0)) , 1.E-9 ) + z0 = rough_leng_m( u_star , znu_a ) + END DO + + z0tq = rough_leng_tq( z0, u_star , znu_a ) + t_star = dt_zu*vkarmn/(LOG(zu/z0tq(:,:,1))) + q_star = dq_zu*vkarmn/(LOG(zu/z0tq(:,:,2))) + + + !! ITERATION BLOCK + DO jit = 1, nbit + + !!Inverse of Obukov length (1/L) : + ztmp0 = One_on_L(t_zu_i, q_zu_i, u_star, t_star, q_star) ! 1/L == 1/[Obukhov length] + ztmp0 = SIGN( MIN(ABS(ztmp0),200._wp), ztmp0 ) ! (prevents FPE from stupid values from masked region later on...) + + !! Stability parameters "zeta" : + zeta_u = zu*ztmp0 + zeta_u = SIGN( MIN(ABS(zeta_u),50.0_wp), zeta_u ) + IF( .NOT. l_zt_equal_zu ) THEN + zeta_t = zt*ztmp0 + zeta_t = SIGN( MIN(ABS(zeta_t),50.0_wp), zeta_t ) + END IF + + !! Roughness lengthes z0, z0t, & z0q : + z0 = rough_leng_m ( u_star , znu_a ) + z0tq = rough_leng_tq( z0, u_star , znu_a ) + + !! Turbulent scales at zu : + ztmp0 = psi_h_ice(zeta_u) + t_star = dt_zu*vkarmn/(LOG(zu) - LOG(z0tq(:,:,1)) - ztmp0) + q_star = dq_zu*vkarmn/(LOG(zu) - LOG(z0tq(:,:,2)) - ztmp0) + u_star = MAX( Ubzu*vkarmn/(LOG(zu) - LOG(z0(:,:)) - psi_m_ice(zeta_u)) , 1.E-9 ) + + IF( .NOT. l_zt_equal_zu ) THEN + !! Re-updating temperature and humidity at zu if zt /= zu : + ztmp1 = LOG(zt/zu) + ztmp0 - psi_h_ice(zeta_t) + t_zu_i = t_zt - t_star/vkarmn*ztmp1 + q_zu_i = q_zt - q_star/vkarmn*ztmp1 + dt_zu = t_zu_i - Ts_i ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu_i - qs_i ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + END IF + + END DO !DO jit = 1, nbit + + ! compute transfer coefficients at zu : + ztmp0 = u_star/Ubzu + Cd_i = ztmp0*ztmp0 + Ch_i = ztmp0*t_star/dt_zu + Ce_i = ztmp0*q_star/dq_zu + + IF( lreturn_cdn .OR. lreturn_chn .OR. lreturn_cen ) ztmp0 = 1._wp/LOG( zu/z0(:,:) ) + IF( lreturn_cdn ) CdN = vkarmn2*ztmp0*ztmp0 + IF( lreturn_chn ) ChN = vkarmn2*ztmp0/LOG(zu/z0tq(:,:,1)) + IF( lreturn_cen ) CeN = vkarmn2*ztmp0/LOG(zu/z0tq(:,:,2)) + + IF( lreturn_z0 ) xz0 = z0 + IF( lreturn_ustar ) xu_star = u_star + IF( lreturn_L ) xL = 1./One_on_L(t_zu_i, q_zu_i, u_star, t_star, q_star) + IF( lreturn_UN10 ) xUN10 = u_star/vkarmn*LOG(10./z0) + + DEALLOCATE ( Ubzu, u_star, t_star, q_star, zeta_u, dt_zu, dq_zu, z0, z0tq, znu_a, ztmp0, ztmp1, ztmp2 ) + IF( .NOT. l_zt_equal_zu ) DEALLOCATE( zeta_t ) + + END SUBROUTINE turb_ice_an05 + + + + FUNCTION rough_leng_m( pus , pnua ) + !!---------------------------------------------------------------------------------- + !! Computes the roughness length of sea-ice according to Andreas et al. 2005, (eq. 19) + !! + !! Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: rough_leng_m ! roughness length over sea-ice [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! u* = friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s] + !! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zus, zz + !!---------------------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zus = MAX( pus(ji,jj) , 1.E-9_wp ) + + zz = (zus - 0.18_wp) / 0.1_wp + + rough_leng_m(ji,jj) = 0.135*pnua(ji,jj)/zus + 0.035*zus*zus/grav*( 5.*EXP(-zz*zz) + 1._wp ) ! Eq.(19) Andreas et al., 2005 + END_2D + !! + END FUNCTION rough_leng_m + + FUNCTION rough_leng_tq( pz0, pus , pnua ) + !!---------------------------------------------------------------------------------- + !! Computes the roughness length of sea-ice according to Andreas et al. 2005, (eq. 22) + !! => which still relies on Andreas 1987 ! + !! + !! Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,2) :: rough_leng_tq ! temp.,hum. roughness lengthes over sea-ice [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0 ! roughness length [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pus ! u* = friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pnua ! kinematic viscosity of air [m^2/s] + !! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zz0, zus, zre, zsmoot, ztrans, zrough + REAL(wp) :: zb0, zb1, zb2, zlog, zlog2, zlog_z0s_on_z0 + !!---------------------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zz0 = pz0(ji,jj) + zus = MAX( pus(ji,jj) , 1.E-9_wp ) + zre = MAX( zus*zz0/pnua(ji,jj) , 0._wp ) ! Roughness Reynolds number + + !! *** TABLE 1 of Andreas et al. 2005 *** + zsmoot = 0._wp ; ztrans = 0._wp ; zrough = 0._wp + IF ( zre <= 0.135_wp ) THEN ! Smooth flow condition (R* <= 0.135): + zsmoot = 1._wp + ELSEIF( zre < 2.5_wp ) THEN ! Transition (0.135 < R* < 2.5) + ztrans = 1._wp + ELSE ! Rough ( R* > 2.5) + zrough = 1._wp + ENDIF + + zlog = LOG(zre) + zlog2 = zlog*zlog + + !! z0t: + zb0 = zsmoot*1.25_wp + ztrans*0.149_wp + zrough*0.317_wp + zb1 = - ztrans*0.550_wp - zrough*0.565_wp + zb2 = - zrough*0.183_wp + zlog_z0s_on_z0 = zb0 + zb1*zlog + zb2*zlog2 + rough_leng_tq(ji,jj,1) = zz0 * EXP( zlog_z0s_on_z0 ) + + !! z0q: + zb0 = zsmoot*1.61_wp + ztrans*0.351_wp + zrough*0.396_wp + zb1 = - ztrans*0.628_wp - zrough*0.512_wp + zb2 = - zrough*0.180_wp + zlog = LOG(zre) + zlog_z0s_on_z0 = zb0 + zb1*zlog + zb2*zlog2 + rough_leng_tq(ji,jj,2) = zz0 * EXP( zlog_z0s_on_z0 ) + + END_2D + !! + END FUNCTION rough_leng_tq + + + + FUNCTION psi_m_ice( pzeta ) + !!---------------------------------------------------------------------------------- + !! ** Purpose: compute the universal profile stability function for momentum + !! + !! + !! Andreas et al 2005 == Jordan et al. 1999 + !! + !! Psi: + !! Unstable => Paulson 1970 + !! Stable => Holtslag & De Bruin 1988 + !! + !! pzeta : stability paramenter, z/L where z is altitude + !! measurement and L is M-O length + !! + !! ** Author: L. Brodeau, 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ice + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx, zpsi_u, zpsi_s, zstab + !!---------------------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! + zta = pzeta(ji,jj) + ! + ! Unstable stratification: + zx = ABS(1._wp - 16._wp*zta)**.25 ! (16 here, not 15!) + + zpsi_u = LOG( (1._wp + zx*zx)/2. ) & ! Eq.(30) Jordan et al. 1999 + & + 2.*LOG( (1._wp + zx )/2. ) & + & - 2.*ATAN( zx ) + 0.5*rpi + + ! Stable stratification: + zpsi_s = - ( 0.7_wp*zta + 0.75_wp*(zta - 14.3_wp)*EXP( -0.35*zta) + 10.7_wp ) ! Eq.(33) Jordan et al. 1999 + + !! Combine: + zstab = 0.5 + SIGN(0.5_wp, zta) + psi_m_ice(ji,jj) = (1._wp - zstab) * zpsi_u & ! Unstable (zta < 0) + & + zstab * zpsi_s ! Stable (zta > 0) + ! + END_2D + END FUNCTION psi_m_ice + + + FUNCTION psi_h_ice( pzeta ) + !!---------------------------------------------------------------------------------- + !! ** Purpose: compute the universal profile stability function for + !! temperature and humidity + !! + !! + !! Andreas et al 2005 == Jordan et al. 1999 + !! + !! Psi: + !! Unstable => Paulson 1970 + !! Stable => Holtslag & De Bruin 1988 + !! + !! pzeta : stability paramenter, z/L where z is altitude + !! measurement and L is M-O length + !! + !! ** Author: L. Brodeau, 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ice + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx, zpsi_u, zpsi_s, zstab + !!---------------------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! + zta = pzeta(ji,jj) + ! + ! Unstable stratification: + zx = ABS(1._wp - 16._wp*zta)**.25 ! (16 here, not 15!) + + zpsi_u = 2.*LOG( (1._wp + zx*zx)/2. ) ! Eq.(31) Jordan et al. 1999 + + ! Stable stratification (identical to Psi_m!): + zpsi_s = - ( 0.7_wp*zta + 0.75_wp*(zta - 14.3_wp)*EXP( -0.35*zta) + 10.7_wp ) ! Eq.(33) Jordan et al. 1999 + + !! Combine: + zstab = 0.5 + SIGN(0.5_wp, zta) + psi_h_ice(ji,jj) = (1._wp - zstab) * zpsi_u & ! Unstable (zta < 0) + & + zstab * zpsi_s ! Stable (zta > 0) + ! + END_2D + END FUNCTION psi_h_ice + + !!====================================================================== +END MODULE sbcblk_algo_ice_an05 \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_cdn.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_cdn.F90 new file mode 100644 index 0000000..f57e7af --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_cdn.F90 @@ -0,0 +1,295 @@ +! AeroBulk / 2020 / L. Brodeau +! +! When using AeroBulk to produce scientific work, please acknowledge with the following citation: +! +! Brodeau, L., B. Barnier, S. Gulev, and C. Woods, 2016: Climatologically +! significant effects of some approximations in the bulk parameterizations of +! turbulent air-sea fluxes. J. Phys. Oceanogr., doi:10.1175/JPO-D-16-0169.1. +! +! +MODULE sbcblk_algo_ice_cdn + !!==================================================================================== + !! Author: Laurent Brodeau, January 2020 + !!==================================================================================== + USE par_kind, ONLY: wp + USE par_oce, ONLY: jpi, jpj, Nis0, Nie0, Njs0, Nje0, nn_hls, ntsi, ntsj, ntei, ntej + USE phycst ! physical constants + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + + IMPLICIT NONE + PRIVATE + + PUBLIC :: CdN10_f_LU12, CdN_f_LU12_eq36, CdN10_f_LU13, CdN_f_LG15, CdN_f_LG15_light + + REAL(wp), PARAMETER :: rCe_0 = 2.23E-3_wp !LOLO: this one can be more accurate when sea-ice data => Lupkes et al (2013), Eq.(1) + REAL(wp), PARAMETER :: rNu_0 = 1._wp + REAL(wp), PARAMETER :: rMu_0 = 1._wp + REAL(wp), PARAMETER :: rbeta_0 = 1.4_wp ! (Eq.47) MIZ + + REAL(wp), PARAMETER :: rhmin_0 = 0.286_wp ! Eq.(25) + REAL(wp), PARAMETER :: rhmax_0 = 0.534_wp ! Eq.(25) + REAL(wp), PARAMETER :: rDmin_0 = 8._wp ! Eq.(27) + REAL(wp), PARAMETER :: rDmax_0 = 300._wp ! Eq.(27) + REAL(wp), PARAMETER :: rz0_w_0 = 3.27E-4 ! fixed roughness length over water (paragraph below Eq.36) + + !!============================================================ + REAL(wp), PARAMETER :: rce10_i_0 = 3.46e-3_wp ! (Eq.48) MIZ + REAL(wp), PARAMETER :: ralpha_0 = 0.2_wp ! (Eq.12) (ECHAM6 value) + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- +CONTAINS + + + FUNCTION CdN10_f_LU12( pfrice, pz0w, pSc, phf, pDi ) + !!---------------------------------------------------------------------- + !! *** ROUTINE CdN10_f_LU12 *** + !! + !! GENERAL FORM OF EQUATION 22 of Lupkes et al. 2012 + !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !! + !! ** Purpose : Computes the "form" contribution of the neutral air-ice + !! drag referenced at 10m to make it dependent on edges at + !! leads, melt ponds and flows (to be added to the "skin" + !! contribution. After some + !! approximations, this can be resumed to a dependency on + !! ice concentration. + !! + !! ** References : Lupkes et al. JGR 2012 (theory) + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: CdN10_f_LU12 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc, phf and pDi all provided... + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0w ! roughness length over water [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pSc ! shletering function [0-1] (Sc->1 for large distance between floes, ->0 for small distances) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: phf ! mean freeboard of floes [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pDi ! cross wind dimension of the floe (aka effective edge length for form drag) [m] + !!---------------------------------------------------------------------- + LOGICAL :: l_known_Sc=.FALSE., l_known_hf=.FALSE., l_known_Di=.FALSE. + REAL(wp) :: ztmp, zrlog, zfri, zfrw, zSc, zhf, zDi + INTEGER :: ji, jj + !!---------------------------------------------------------------------- + l_known_Sc = PRESENT(pSc) + l_known_hf = PRESENT(phf) + l_known_Di = PRESENT(pDi) + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + + zfri = pfrice(ji,jj) + zfrw = (1._wp - zfri) + + IF(l_known_Sc) THEN + zSc = pSc(ji,jj) + ELSE + !! Sc parameterized in terms of A (ice fraction): + zSc = zfrw**(1._wp / ( 10._wp * rBeta_0 )) ! Eq.(31) + END IF + + IF(l_known_hf) THEN + zhf = phf(ji,jj) + ELSE + !! hf parameterized in terms of A (ice fraction): + zhf = rhmax_0*zfri + rhmin_0*zfrw ! Eq.(25) + END IF + + IF(l_known_Di) THEN + zDi = pDi(ji,jj) + ELSE + !! Di parameterized in terms of A (ice fraction): + ztmp = 1._wp / ( 1._wp - (rDmin_0/rDmax_0)**(1._wp/rBeta_0) ) ! A* Eq.(27) + zDi = rDmin_0 * ( ztmp/(ztmp - zfri) )**rBeta_0 ! Eq.(26) + END IF + + ztmp = 1._wp/pz0w(ji,jj) + zrlog = LOG(zhf*ztmp) / LOG(10._wp*ztmp) + + CdN10_f_LU12(ji,jj) = 0.5_wp* 0.3_wp * zrlog*zrlog * zSc*zSc * zhf/zDi * zfri ! Eq.(22) + !! 1/2 Ce + + END_2D + END FUNCTION CdN10_f_LU12 + + + FUNCTION CdN_f_LU12_eq36( pzu, pfrice ) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LU12_eq36 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), INTENT(in) :: pzu ! reference height [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc, phf and pDi all provided... + !!---------------------------------------------------------------------- + REAL(wp) :: ztmp, zrlog, zfri, zhf, zDi + INTEGER :: ji, jj + !!---------------------------------------------------------------------- + !zhf = 0.28 ! h_fc + zhf = 0.41 ! h_fc + zDi = rDmin_0 + + ztmp = 1._wp/rz0_w_0 + zrlog = LOG(zhf*ztmp) / LOG(pzu*ztmp) + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zfri = pfrice(ji,jj) + CdN_f_LU12_eq36(ji,jj) = 0.5_wp* 0.3_wp * zrlog*zrlog * zhf/zDi * (1._wp - zfri)**rBeta_0 ! Eq.(35) & (36) + !! 1/2 Ce + END_2D + END FUNCTION CdN_f_LU12_eq36 + + + FUNCTION CdN10_f_LU13( pfrice ) + !!---------------------------------------------------------------------- + !! *** ROUTINE CdN10_f_LU13 *** + !! + !! ** Purpose : Computes the "form" contribution of the neutral air-ice + !! drag referenced at 10m to make it dependent on edges at + !! leads, melt ponds and flows (to be added to the "skin" + !! contribution. After some + !! approximations, this can be resumed to a dependency on + !! ice concentration. + !! + !! ** Method : The parameterization is taken from Lupkes et al. (2012) eq.(50) + !! with the highest level of approximation: level4, eq.(59) + !! The generic drag over a cell partly covered by ice can be re-written as follows: + !! + !! Cd = Cdw * (1-A) + Cdi * A + Ce * (1-A)**(nu+1/(10*beta)) * A**mu + !! + !! Ce = 2.23e-3 , as suggested by Lupkes (eq. 59) + !! nu = mu = beta = 1 , as suggested by Lupkes (eq. 59) + !! A is the concentration of ice minus melt ponds (if any) + !! + !! This new drag has a parabolic shape (as a function of A) starting at + !! Cdw(say 1.5e-3) for A=0, reaching 1.97e-3 for A~0.5 + !! and going down to Cdi(say 1.4e-3) for A=1 + !! + !! It is theoretically applicable to all ice conditions (not only MIZ) + !! => see Lupkes et al (2013) + !! + !! ** References : Lupkes et al. JGR 2012 (theory) + !! Lupkes et al. GRL 2013 (application to GCM) + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: CdN10_f_LU13 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b + !!---------------------------------------------------------------------- + INTEGER :: ji, jj + REAL(wp) :: zcoef + !!---------------------------------------------------------------------- + zcoef = rNu_0 + 1._wp / ( 10._wp * rBeta_0 ) + + !! We are not an AGCM, we are an OGCM!!! => we drop term "(1 - A)*Cd_w" + !! => so we keep only the last rhs terms of Eq.(1) of Lupkes et al, 2013 that we divide by "A": + !! (we multiply Cd_i_s and Cd_i_f by A later, when applying ocean-ice partitioning... + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + CdN10_f_LU13(ji,jj) = rCe_0 * pfrice(ji,jj)**(rMu_0 - 1._wp) * (1._wp - pfrice(ji,jj))**zcoef + END_2D + !! => seems okay for winter 100% sea-ice as second rhs term vanishes as pfrice == 1.... + + END FUNCTION CdN10_f_LU13 + + + FUNCTION CdN_f_LG15( pzu, pfrice, pz0i, pSc, phf, pDi ) + !!---------------------------------------------------------------------- + !! *** ROUTINE CdN_f_LG15 *** + !! + !! GENERAL FORM OF EQUATION 21 of Lupkes & Gryanik (2015) + !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !! + !! ** Purpose : Computes the "form" contribution of the neutral air-ice + !! drag referenced at 10m to make it dependent on edges at + !! leads, melt ponds and flows (to be added to the "skin" + !! contribution. After some + !! approximations, this can be resumed to a dependency on + !! ice concentration. + !! + !! ** References : Lupkes & Gryanik (2015) + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LG15 ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), INTENT(in ) :: pzu ! reference height [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b ! NOT USED if pSc, phf and pDi all provided... + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0i ! roughness length over ICE [m] (in LU12, it's over water ???) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pSc ! shletering function [0-1] (Sc->1 for large distance between floes, ->0 for small distances) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: phf ! mean freeboard of floes [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: pDi ! cross wind dimension of the floe (aka effective edge length for form drag) [m] + !!---------------------------------------------------------------------- + LOGICAL :: l_known_Sc=.FALSE., l_known_hf=.FALSE., l_known_Di=.FALSE. + REAL(wp) :: ztmp, zrlog, zfri, zfrw, zSc, zhf, zDi + INTEGER :: ji, jj + !!---------------------------------------------------------------------- + l_known_Sc = PRESENT(pSc) + l_known_hf = PRESENT(phf) + l_known_Di = PRESENT(pDi) + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + + zfri = pfrice(ji,jj) + zfrw = (1._wp - zfri) + + IF(l_known_Sc) THEN + zSc = pSc(ji,jj) + ELSE + !! Sc parameterized in terms of A (ice fraction): + zSc = zfrw**(1._wp / ( 10._wp * rBeta_0 )) ! Eq.(31) + END IF + + IF(l_known_hf) THEN + zhf = phf(ji,jj) + ELSE + !! hf parameterized in terms of A (ice fraction): + zhf = rhmax_0*zfri + rhmin_0*zfrw ! Eq.(25) + END IF + + IF(l_known_Di) THEN + zDi = pDi(ji,jj) + ELSE + !! Di parameterized in terms of A (ice fraction): + ztmp = 1._wp / ( 1._wp - (rDmin_0/rDmax_0)**(1._wp/rBeta_0) ) ! A* Eq.(27) + zDi = rDmin_0 * ( ztmp/(ztmp - zfri) )**rBeta_0 ! Eq.(26) + END IF + + ztmp = 1._wp/pz0i(ji,jj) + zrlog = LOG(zhf*ztmp/2.718_wp) / LOG(pzu*ztmp) !LOLO: adding number "e" !!! + + CdN_f_LG15(ji,jj) = 0.5_wp* 0.4_wp * zrlog*zrlog * zSc*zSc * zhf/zDi * zfri ! Eq.(21) Lukes & Gryanik (2015) + !! 1/2 Ce + + END_2D + END FUNCTION CdN_f_LG15 + + + FUNCTION CdN_f_LG15_light( pzu, pfrice, pz0w ) + !!---------------------------------------------------------------------- + !! *** ROUTINE CdN_f_LG15_light *** + !! + !! ** Purpose : Computes the "form" contribution of the neutral air-ice + !! drag referenced at 10m to make it dependent on edges at + !! leads, melt ponds and flows (to be added to the "skin" + !! contribution. After some + !! approximations, this can be resumed to a dependency on + !! ice concentration. + !! + !! ** References : Lupkes & Gryanik (2015) + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: CdN_f_LG15_light ! neutral FORM drag coefficient contribution over sea-ice + REAL(wp), INTENT(in) :: pzu ! reference height [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfrice ! ice concentration [fraction] => at_i_b + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pz0w ! roughness length over water [m] + !!---------------------------------------------------------------------- + REAL(wp) :: ztmp, zrlog, zfri + INTEGER :: ji, jj + !!---------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + + zfri = pfrice(ji,jj) + + ztmp = 1._wp / pz0w(ji,jj) + zrlog = LOG( 10._wp * ztmp ) / LOG( pzu * ztmp ) ! part of (Eq.46) + + CdN_f_LG15_light(ji,jj) = rce10_i_0 *zrlog*zrlog * zfri * (1._wp - zfri)**rbeta_0 ! (Eq.46) [ index 1 is for ice, 2 for water ] + + END_2D + END FUNCTION CdN_f_LG15_light + + + !!====================================================================== +END MODULE sbcblk_algo_ice_cdn \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_lg15.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_lg15.F90 new file mode 100644 index 0000000..550d2e7 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_lg15.F90 @@ -0,0 +1,289 @@ +MODULE sbcblk_algo_ice_lg15 + !!====================================================================== + !! *** MODULE sbcblk_algo_ice_lg15 *** + !! Computes turbulent components of surface fluxes over sea-ice + !! + !! + !! Lüpkes, C., and Gryanik, V. M. ( 2015), A stability‐dependent parametrization + !! of transfer coefficients for momentum and heat over polar sea ice to be used in climate models, + !! J. Geophys. Res. Atmos., 120, 552– 581, doi:10.1002/2014JD022418. + !! + !! => Despite the fact that the sea-ice concentration (frice) must be provided, + !! only transfer coefficients, and air temp. + hum. height adjustement + !! over ice are returned/performed. + !! ==> 'frice' is only here to estimate the form drag caused by sea-ice... + !! + !! Routine turb_ice_lg15 maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !! + !! Author: Laurent Brodeau, Summer 2020 + !! + !!---------------------------------------------------------------------- + USE par_kind, ONLY: wp + USE par_oce, ONLY: jpi, jpj + USE phycst ! physical constants + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + USE sbcblk_algo_ice_cdn + + IMPLICIT NONE + PRIVATE + + PUBLIC :: turb_ice_lg15 + + REAL(wp), PARAMETER :: ralpha_0 = 0.2_wp ! (Eq.12) (ECHAM6 value) + + !! To be namelist parameters in NEMO: + REAL(wp), PARAMETER :: rz0_i_s_0 = 0.69e-3_wp ! Eq. 43 [m] + REAL(wp), PARAMETER :: rz0_i_f_0 = 4.54e-4_wp ! bottom p.562 MIZ [m] + + LOGICAL, PARAMETER :: l_add_form_drag = .TRUE. + LOGICAL, PARAMETER :: l_use_pond_info = .FALSE. + LOGICAL, PARAMETER :: l_dbg_print = .FALSE. + + INTEGER , PARAMETER :: nbit = 8 ! number of itterations + + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE turb_ice_lg15( zt, zu, Ts_i, t_zt, qs_i, q_zt, U_zu, frice, & + & Cd_i, Ch_i, Ce_i, t_zu_i, q_zu_i, & + & CdN, ChN, CeN, xz0, xu_star, xL, xUN10 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE turb_ice_lg15 *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to: + !! Lüpkes, C., and Gryanik, V. M. ( 2015), A stability‐dependent + !! parametrization of transfer coefficients for momentum and heat + !! over polar sea ice to be used in climate models, + !! J. Geophys. Res. Atmos., 120, 552– 581, doi:10.1002/2014JD022418. + !! + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! INPUT : + !! ------- + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * Ts_i : surface temperature of sea-ice [K] + !! * t_zt : potential air temperature at zt [K] + !! * qs_i : saturation specific humidity at temp. Ts_i over ice [kg/kg] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! * frice : sea-ice concentration (fraction) + !! + !! OUTPUT : + !! -------- + !! * Cd_i : drag coefficient over sea-ice + !! * Ch_i : sensible heat coefficient over sea-ice + !! * Ce_i : sublimation coefficient over sea-ice + !! * t_zu_i : pot. air temp. adjusted at zu over sea-ice [K] + !! * q_zu_i : spec. hum. of air adjusted at zu over sea-ice [kg/kg] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * CdN : neutral-stability drag coefficient + !! * ChN : neutral-stability sensible heat coefficient + !! * CeN : neutral-stability evaporation coefficient + !! * xz0 : return the aerodynamic roughness length (integration constant for wind stress) [m] + !! * xu_star : return u* the friction velocity [m/s] + !! * xL : return the Obukhov length [m] + !! * xUN10 : neutral wind speed at 10m [m/s] + !! + !! ** Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: Ts_i ! ice surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: frice ! sea-ice concentration (fraction) + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp1, ztmp2 ! temporary stuff + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dt_zu, dq_zu + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zz0_s, zz0_f, RiB ! third dimensions (size=2): + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zCdN_s, zChN_s, zCdN_f, zChN_f + !! + INTEGER :: jit + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + !! + LOGICAL :: lreturn_cdn=.FALSE., lreturn_chn=.FALSE., lreturn_cen=.FALSE. + LOGICAL :: lreturn_z0=.FALSE., lreturn_ustar=.FALSE., lreturn_L=.FALSE., lreturn_UN10=.FALSE. + !! + CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ice_lg15@sbcblk_algo_ice_lg15.f90' + !!---------------------------------------------------------------------------------- + ALLOCATE ( Ubzu(jpi,jpj) ) + ALLOCATE ( ztmp1(jpi,jpj), ztmp2(jpi,jpj) ) + ALLOCATE ( dt_zu(jpi,jpj), dq_zu(jpi,jpj) ) + ALLOCATE ( zz0_s(jpi,jpj), zz0_f(jpi,jpj), RiB(jpi,jpj), & + & zCdN_s(jpi,jpj), zChN_s(jpi,jpj), zCdN_f(jpi,jpj), zChN_f(jpi,jpj) ) + + lreturn_cdn = PRESENT(CdN) + lreturn_chn = PRESENT(ChN) + lreturn_cen = PRESENT(CeN) + lreturn_z0 = PRESENT(xz0) + lreturn_ustar = PRESENT(xu_star) + lreturn_L = PRESENT(xL) + lreturn_UN10 = PRESENT(xUN10) + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) + + !! Scalar wind speed cannot be below 0.2 m/s + Ubzu = MAX( U_zu, wspd_thrshld_ice ) + + !! First guess of temperature and humidity at height zu: + t_zu_i = MAX( t_zt , 100._wp ) ! who knows what's given on masked-continental regions... + q_zu_i = MAX( q_zt , 0.1e-6_wp ) ! " + + !! Air-Ice & Air-Sea differences (and we don't want them to be 0!) + dt_zu = t_zu_i - Ts_i ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu_i - qs_i ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + + !! Very crude first guess: + Cd_i(:,:) = 1.4e-3_wp + Ch_i(:,:) = 1.4e-3_wp + Ce_i(:,:) = 1.4e-3_wp + + !! For skin drag : + zz0_s(:,:) = rz0_i_s_0 !#LB/RFI! ! Room for improvement. We use the same z0_skin everywhere (= rz0_i_s_0)... + zCdN_s(:,:) = Cd_from_z0( zu, zz0_s(:,:) ) + zChN_s(:,:) = vkarmn2 / ( LOG( zu / zz0_s(:,:) ) * LOG( zu / (ralpha_0*zz0_s(:,:)) ) ) ! (Eq.11,12) [ "" ] + + !! For form drag in MIZ: + zz0_f(:,:) = 0._wp + zCdN_f(:,:) = 0._wp + zChN_f(:,:) = 0._wp + IF ( l_add_form_drag ) THEN + zz0_f(:,:) = rz0_i_f_0 !#LB/RFI! ! Room for improvement. We use the same z0_form everywhere !!! + zCdN_f(:,:) = CdN_f_LG15_light( zu, frice(:,:), zz0_f(:,:) ) + zChN_f(:,:) = zCdN_f(:,:)/( 1._wp + LOG(1._wp/ralpha_0)/vkarmn*SQRT(zCdN_f(:,:)) ) ! (Eq.60,61) [ "" ] + END IF + + !! Some other first guess values, needed to compute wind at zt: + Cd_i(:,:) = zCdN_s(:,:) + zCdN_f(:,:) + Ch_i(:,:) = zChN_s(:,:) + zChN_f(:,:) + RiB(:,:) = Ri_bulk( zt, Ts_i(:,:), t_zt(:,:), qs_i(:,:), q_zt(:,:), Ubzu(:,:) ) ! over ice (index=1) + + + !! ITERATION BLOCK + DO jit = 1, nbit + + IF(l_dbg_print) PRINT *, 'LOLO: LOOP #', INT(jit,1) + IF(l_dbg_print) PRINT *, 'LOLO: theta_zu, Ts_i, Ubzu =', REAL(t_zu_i(:,:),4), REAL(Ts_i(:,:),4), REAL(Ubzu(:,:),4) + IF(l_dbg_print) PRINT *, 'LOLO: q_zu =', REAL(q_zu_i(:,:),4) + IF(l_dbg_print) PRINT *, 'LOLO: CdN_s, zCdN_f =', REAL(zCdN_s(:,:),4), REAL(zCdN_f(:,:),4) + + + !! Bulk Richardson Number + !! ====================== + !! PROBLEM: when computed at z=zu, with adjusted theta and q, it is numerically unstable in some rare events (unstable) + !! => fix: compute RiB at zt, with ajusted wind at zt... => seems to be more stable + IF( .NOT. l_zt_equal_zu ) THEN + ! U_zt = U_zu + u_star/vkarmn*(LOG(zt/zu) + psi_m_coare(zu/L) - psi_m_coare(zt/L)) + ztmp1(:,:) = zCdN_s(:,:) + zCdN_f(:,:) ! total neutral drag coeff! + ztmp2(:,:) = zz0_s(:,:) + zz0_f(:,:) ! total roughness length z0 + ztmp1 = LOG(zt/zu) + f_h_louis( zu, RiB(:,:), ztmp1(:,:), ztmp2(:,:) ) & + & - f_h_louis( zt, RiB(:,:), ztmp1(:,:), ztmp2(:,:) ) + ztmp2(:,:) = MAX( Ubzu(:,:) + (SQRT(Cd_i(:,:))*Ubzu)*ztmp1 , wspd_thrshld_ice ) ! wind at zt ( SQRT(Cd_i(:,:))*Ubzu == u* !) + ztmp2(:,:) = MIN( ztmp2(:,:) , Ubzu(:,:) ) + IF(l_dbg_print) PRINT *, 'LOLO: ADJUSTED WIND AT ZT =', ztmp2 + ELSE + ztmp2(:,:) = Ubzu(:,:) + END IF + RiB(:,:) = Ri_bulk( zt, Ts_i(:,:), t_zt(:,:), qs_i(:,:), q_zt(:,:), ztmp2(:,:) ) ! over ice (index=1) + IF(l_dbg_print) PRINT *, 'LOLO: RiB_zt =', RiB(:,:) + + + ! Momentum and Heat transfer coefficients WITHOUT FORM DRAG / (Eq.6) and (Eq.10): + Cd_i(:,:) = zCdN_s(:,:) * f_m_louis( zu, RiB(:,:), zCdN_s(:,:), zz0_s(:,:) ) ! (Eq.6) + Ch_i(:,:) = zChN_s(:,:) * f_h_louis( zu, RiB(:,:), zCdN_s(:,:), zz0_s(:,:) ) ! (Eq.10) / LOLO: why "zCdN_s" (ztmp1) and not "zChn" ??? + IF(l_dbg_print) PRINT *, 'LOLO: f_m_louis_s =', f_m_louis( zu, RiB(:,:), zCdN_s(:,:), zz0_s(:,:) ) + IF(l_dbg_print) PRINT *, 'LOLO: f_h_louis_s =', f_h_louis( zu, RiB(:,:), zCdN_s(:,:), zz0_s(:,:) ) + IF(l_dbg_print) PRINT *, 'LOLO: Cd / skin only / ice =', REAL(Cd_i(:,:),4) + + + IF ( l_add_form_drag ) THEN + !! Form-drag-related NEUTRAL momentum and Heat transfer coefficients: + !! MIZ: + Cd_i(:,:) = Cd_i(:,:) + zCdN_f(:,:) * f_m_louis( zu, RiB(:,:), zCdN_f(:,:), zz0_f(:,:) ) ! (Eq.6) + Ch_i(:,:) = Ch_i(:,:) + zChN_f(:,:) * f_h_louis( zu, RiB(:,:), zCdN_f(:,:), zz0_f(:,:) ) ! (Eq.10) / LOLO: why "zCdN_f" and not "zChn" ??? + IF(l_dbg_print) PRINT *, 'LOLO: f_m_louis_f =', f_m_louis( zu, RiB(:,:), zCdN_f(:,:), zz0_f(:,:) ) + IF(l_dbg_print) PRINT *, 'LOLO: f_h_louis_f =', f_h_louis( zu, RiB(:,:), zCdN_f(:,:), zz0_f(:,:) ) + + IF(l_dbg_print) PRINT *, 'LOLO: Cd / form only / ice =', REAL(zCdN_f(:,:) * f_m_louis( zu, RiB(:,:), zCdN_f(:,:), zz0_f(:,:) ),4) + + END IF + + IF(l_dbg_print) PRINT *, 'LOLO: Cd, Ch / TOTAL / ice =', REAL(Cd_i(:,:),4), REAL(Ch_i(:,:),4) + + + !! Adjusting temperature and humidity from zt to zu: + IF( .NOT. l_zt_equal_zu ) THEN + + !! Over ice: + ztmp1(:,:) = zCdN_s(:,:) + zCdN_f(:,:) ! total neutral drag coeff! + ztmp2(:,:) = zz0_s(:,:) + zz0_f(:,:) ! total roughness length z0 + ztmp1 = LOG(zt/zu) + f_h_louis( zu, RiB(:,:), ztmp1(:,:), ztmp2(:,:) ) & + & - f_h_louis( zt, RiB(:,:), ztmp1(:,:), ztmp2(:,:) ) + ztmp2 = 1._wp/SQRT(Cd_i(:,:)) + + t_zu_i(:,:) = t_zt - (Ch_i(:,:) * dt_zu(:,:) * ztmp2) / vkarmn * ztmp1 ! t_star = Ch * dt_zu / SQRT(Cd) + q_zu_i(:,:) = q_zt - (Ch_i(:,:) * dq_zu(:,:) * ztmp2) / vkarmn * ztmp1 ! q_star = Ce * dq_zu / SQRT(Cd) + q_zu_i(:,:) = MAX(0._wp, q_zu_i(:,:)) + + dt_zu(:,:) = t_zu_i(:,:) - Ts_i + dq_zu(:,:) = q_zu_i(:,:) - qs_i + + dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + END IF + + IF(l_dbg_print) PRINT *, ''!LOLO + + END DO !DO jit = 1, nbit + + Ce_i(:,:) = Ch_i(:,:) + + IF( lreturn_cdn ) CdN = zCdN_s(:,:)+zCdN_f(:,:) + IF( lreturn_chn ) ChN = zChN_s(:,:)+zChN_f(:,:) + IF( lreturn_cen ) CeN = zChN_s(:,:)+zChN_f(:,:) + + IF( lreturn_z0 ) xz0 = z0_from_Cd( zu, zCdN_s(:,:)+zCdN_f(:,:) ) + + IF( lreturn_ustar ) xu_star = SQRT(Cd_i) * Ubzu + + IF( lreturn_L ) THEN + ztmp1 = SQRT(Cd_i) + xL = 1./One_on_L( t_zu_i, q_zu_i, ztmp1*Ubzu, Ch_i*dt_zu(:,:)/ztmp1, Ce_i*dq_zu(:,:)/ztmp1 ) + END IF + + IF( lreturn_UN10 ) THEN + ztmp1 = zCdN_s(:,:) + zCdN_f(:,:) ! => CdN + xUN10 = SQRT(Cd_i) * Ubzu/vkarmn * LOG( 10._wp / z0_from_Cd(zu, ztmp1) ) + END IF + + DEALLOCATE ( Ubzu ) + DEALLOCATE ( ztmp1, ztmp2 ) + DEALLOCATE ( dt_zu, dq_zu ) + DEALLOCATE ( zz0_s, zz0_f, RiB, zCdN_s, zChN_s, zCdN_f, zChN_f ) + + END SUBROUTINE turb_ice_lg15 + + !!====================================================================== +END MODULE sbcblk_algo_ice_lg15 \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_lu12.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_lu12.F90 new file mode 100644 index 0000000..d69076f --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ice_lu12.F90 @@ -0,0 +1,185 @@ +MODULE sbcblk_algo_ice_lu12 + !!====================================================================== + !! *** MODULE sbcblk_algo_ice_lu12 *** + !! Computes turbulent components of surface fluxes over sea-ice + !! + !! Lüpkes, C., Gryanik, V. M., Hartmann, J., and Andreas, E. L. ( 2012), A parametrization, based on sea ice morphology, + !! of the neutral atmospheric drag coefficients for weather prediction and climate models, J. Geophys. Res., 117, D13112, + !! doi:10.1029/2012JD017630. + !! + !! => Despite the fact that the sea-ice concentration (frice) must be provided, + !! only transfer coefficients, and air temp. + hum. height adjustement + !! over ice are returned/performed. + !! ==> 'frice' is only here to estimate the form drag caused by sea-ice... + !! + !! Routine turb_ice_lu12 maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !! + !! Author: Laurent Brodeau, Summer 2020 + !! + !!---------------------------------------------------------------------- + USE par_kind, ONLY: wp + USE par_oce, ONLY: jpi, jpj + USE phycst ! physical constants + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + USE sbcblk_algo_ice_cdn + + IMPLICIT NONE + PRIVATE + + PUBLIC :: turb_ice_lu12 + + REAL(wp), PARAMETER :: rz0_i_s_0 = 0.69e-3_wp ! Eq.(43) of Lupkes & Gryanik (2015) [m] => to estimate CdN10 for skin drag! + REAL(wp), PARAMETER :: rz0_i_f_0 = 4.54e-4_wp ! bottom p.562 MIZ [m] (LG15) + + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE turb_ice_lu12( zt, zu, Ts_i, t_zt, qs_i, q_zt, U_zu, frice, & + & Cd_i, Ch_i, Ce_i, t_zu_i, q_zu_i, & + & CdN, ChN, CeN, xz0, xu_star, xL, xUN10 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE turb_ice_lu12 *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to: + !! Lüpkes, C., Gryanik, V. M., Hartmann, J., and Andreas, E. L. ( 2012), + !! A parametrization, based on sea ice morphology, of the neutral + !! atmospheric drag coefficients for weather prediction and climate models, + !! J. Geophys. Res., 117, D13112, doi:10.1029/2012JD017630. + !! + !! INPUT : + !! ------- + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * Ts_i : surface temperature of sea-ice [K] + !! * t_zt : potential air temperature at zt [K] + !! * qs_i : saturation specific humidity at temp. Ts_i over ice [kg/kg] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! * frice : sea-ice concentration (fraction) + !! + !! OUTPUT : + !! -------- + !! * Cd_i : drag coefficient over sea-ice + !! * Ch_i : sensible heat coefficient over sea-ice + !! * Ce_i : sublimation coefficient over sea-ice + !! * t_zu_i : pot. air temp. adjusted at zu over sea-ice [K] + !! * q_zu_i : spec. hum. of air adjusted at zu over sea-ice [kg/kg] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * CdN : neutral-stability drag coefficient + !! * ChN : neutral-stability sensible heat coefficient + !! * CeN : neutral-stability evaporation coefficient + !! * xz0 : return the aerodynamic roughness length (integration constant for wind stress) [m] + !! * xu_star : return u* the friction velocity [m/s] + !! * xL : return the Obukhov length [m] + !! * xUN10 : neutral wind speed at 10m [m/s] + !! + !! ** Author: L. Brodeau, January 2020 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: Ts_i ! ice surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: qs_i ! sat. spec. hum. at ice/air interface [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! spec. air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: frice ! sea-ice concentration (fraction) + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Cd_i ! drag coefficient over sea-ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ch_i ! transfert coefficient for heat over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: Ce_i ! transfert coefficient for sublimation over ice + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: t_zu_i ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: q_zu_i ! spec. humidity adjusted at zu [kg/kg] + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CdN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: ChN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: CeN + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xz0 ! Aerodynamic roughness length [m] + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xu_star ! u*, friction velocity + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xL ! zeta (zu/L) + REAL(wp), INTENT(out), DIMENSION(jpi,jpj), OPTIONAL :: xUN10 ! Neutral wind at zu + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dt_zu, dq_zu, z0 + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: Ubzu + !! + LOGICAL :: lreturn_cdn=.FALSE., lreturn_chn=.FALSE., lreturn_cen=.FALSE. + LOGICAL :: lreturn_z0=.FALSE., lreturn_ustar=.FALSE., lreturn_L=.FALSE., lreturn_UN10=.FALSE. + !! + CHARACTER(len=40), PARAMETER :: crtnm = 'turb_ice_lu12@sbcblk_algo_ice_lu12.f90' + !!---------------------------------------------------------------------------------- + ALLOCATE ( Ubzu(jpi,jpj) ) + ALLOCATE ( dt_zu(jpi,jpj), dq_zu(jpi,jpj), z0(jpi,jpj) ) + + lreturn_cdn = PRESENT(CdN) + lreturn_chn = PRESENT(ChN) + lreturn_cen = PRESENT(CeN) + lreturn_z0 = PRESENT(xz0) + lreturn_ustar = PRESENT(xu_star) + lreturn_L = PRESENT(xL) + lreturn_UN10 = PRESENT(xUN10) + + !! Scalar wind speed cannot be below 0.2 m/s + Ubzu = MAX( U_zu, wspd_thrshld_ice ) + + !! First guess of temperature and humidity at height zu: + t_zu_i = MAX( t_zt , 100._wp ) ! who knows what's given on masked-continental regions... + q_zu_i = MAX( q_zt , 0.1e-6_wp ) ! " + + !! Air-Ice & Air-Sea differences (and we don't want them to be 0!) + dt_zu = t_zu_i - Ts_i ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6_wp), dt_zu ) + dq_zu = q_zu_i - qs_i ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9_wp), dq_zu ) + + !! To estimate CDN10_skin: + !! we use the method that comes in LG15, i.e. by starting from a default roughness length z0 for skin drag: + + Ce_i(:,:) = rz0_i_s_0 !! temporary array to contain roughness length for skin drag ! + + + !! Method #1: + !Cd_i(:,:) = Cd_from_z0( zu, Ce_i(:,:) ) + CdN10_f_LU13( frice(:,:) ) + !IF( lreturn_cdfrm ) CdN_frm = CdN10_f_LU13( frice(:,:) ) + !PRINT *, 'LOLO: estimate of Cd_f_i method #1 =>', CdN10_f_LU13( frice(:,:) ); PRINT *, '' + + !! Method #2: + !! We need an estimate of z0 over water: + !z0_w(:,:) = z0_from_Cd( zu, CD_N10_NCAR(Ubzu) ) + !!PRINT *, 'LOLO: estimate of z0_w =>', z0_w + !Cd_i(:,:) = Cd_from_z0( zu, Ce_i(:,:) ) + CdN10_f_LU12( frice(:,:), z0_w(:,:) ) + !IF( lreturn_cdfrm ) CdN_frm = CdN10_f_LU12( frice(:,:), z0_w(:,:) ) + !! N10 skin drag N10 form drag + + !! Method #3: + !Cd_i(:,:) = Cd_from_z0( zu, Ce_i(:,:) ) + CdN10_f_LU12_eq36( frice(:,:) ) + !IF( lreturn_cdfrm ) CdN_frm = CdN10_f_LU12_eq36( frice(:,:) ) + !PRINT *, 'LOLO: estimate of Cd_f_i method #2 =>', CdN10_f_LU12( frice(:,:), z0_w(:,:) ) + + !! Method #4: + !! using eq.21 of LG15 instead: + z0(:,:) = rz0_i_f_0 + !Cd_i(:,:) = Cd_from_z0( zu, Ce_i(:,:) ) + CdN_f_LG15( zu, frice(:,:), z0(:,:) ) / frice(:,:) + Cd_i(:,:) = Cd_from_z0( zu, Ce_i(:,:) ) + CdN_f_LG15( zu, frice(:,:), z0(:,:) ) !/ frice(:,:) + !IF( lreturn_cdfrm ) CdN_frm = CdN_f_LG15( zu, frice(:,:), z0(:,:) ) + + + Ch_i(:,:) = Cd_i(:,:) + Ce_i(:,:) = Cd_i(:,:) + + IF( lreturn_cdn ) CdN = Cd_i(:,:) + IF( lreturn_chn ) ChN = Ch_i(:,:) + IF( lreturn_cen ) CeN = Ce_i(:,:) + + IF( lreturn_z0 ) xz0 = z0_from_Cd( zu, Cd_i ) + IF( lreturn_ustar ) xu_star = SQRT(Cd_i)*Ubzu + IF( lreturn_L ) xL = 1./One_on_L(t_zu_i, q_zu_i, SQRT(Cd_i)*Ubzu, & + & Cd_i/SQRT(Cd_i)*dt_zu, Cd_i/SQRT(Cd_i)*dq_zu) + IF( lreturn_UN10 ) xUN10 = SQRT(Cd_i)*Ubzu/vkarmn * LOG( 10._wp / z0_from_Cd( zu, Cd_i ) ) + + DEALLOCATE ( dt_zu, dq_zu, z0 ) + DEALLOCATE ( Ubzu ) + + END SUBROUTINE turb_ice_lu12 + + !!====================================================================== +END MODULE sbcblk_algo_ice_lu12 \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ncar.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ncar.F90 new file mode 100644 index 0000000..27bd746 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_algo_ncar.F90 @@ -0,0 +1,368 @@ +MODULE sbcblk_algo_ncar + !!====================================================================== + !! *** MODULE sbcblk_algo_ncar *** + !! Computes: + !! * bulk transfer coefficients C_D, C_E and C_H + !! * air temp. and spec. hum. adjusted from zt (2m) to zu (10m) if needed + !! * the effective bulk wind speed at 10m Ubzu + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Using the bulk formulation/param. of Large & Yeager 2008 + !! + !! Routine turb_ncar maintained and developed in AeroBulk + !! (https://github.com/brodeau/aerobulk/) + !! + !! L. Brodeau, 2015 + !!===================================================================== + !! History : 3.6 ! 2016-02 (L.Brodeau) successor of old turb_ncar of former sbcblk_core.F90 + !! 4.2 ! 2020-12 (L. Brodeau) Introduction of various air-ice bulk parameterizations + improvements + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! turb_ncar : computes the bulk turbulent transfer coefficients + !! adjusts t_air and q_air from zt to zu m + !! returns the effective bulk wind speed at 10m + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE sbc_oce, ONLY: ln_cdgw + USE sbcwave, ONLY: cdn_wave ! wave module + USE phycst ! physical constants + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + + IMPLICIT NONE + PRIVATE + + PUBLIC :: TURB_NCAR ! called by sbcblk.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" + + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE turb_ncar( zt, zu, sst, t_zt, ssq, q_zt, U_zu, & + & Cd, Ch, Ce, t_zu, q_zu, Ubzu, & + & nb_iter, CdN, ChN, CeN ) + !!---------------------------------------------------------------------------------- + !! *** ROUTINE turb_ncar *** + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to Large & Yeager (2004) and Large & Yeager (2008) + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! Returns the effective bulk wind speed at zu to be used in the bulk formulas + !! + !! INPUT : + !! ------- + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (usually 10m) [m] + !! * sst : bulk SST [K] + !! * t_zt : potential air temperature at zt [K] + !! * ssq : specific humidity at saturation at SST [kg/kg] + !! * q_zt : specific humidity of air at zt [kg/kg] + !! * U_zu : scalar wind speed at zu [m/s] + !! + !! + !! OUTPUT : + !! -------- + !! * Cd : drag coefficient + !! * Ch : sensible heat coefficient + !! * Ce : evaporation coefficient + !! * t_zu : pot. air temperature adjusted at wind height zu [K] + !! * q_zu : specific humidity of air // [kg/kg] + !! * Ubzu : bulk wind speed at zu [m/s] + !! + !! OPTIONAL OUTPUT: + !! ---------------- + !! * CdN : neutral-stability drag coefficient + !! * ChN : neutral-stability sensible heat coefficient + !! * CeN : neutral-stability evaporation coefficient + !! + !! ** Author: L. Brodeau, June 2019 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: zt ! height for t_zt and q_zt [m] + REAL(wp), INTENT(in ) :: zu ! height for U_zu [m] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: sst ! sea surface temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: t_zt ! potential air temperature [Kelvin] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: ssq ! sea surface specific humidity [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: q_zt ! specific air humidity at zt [kg/kg] + REAL(wp), INTENT(in ), DIMENSION(jpi,jpj) :: U_zu ! relative wind module at zu [m/s] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ch ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ce ! transfert coefficient for evaporation (Q_lat) + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: t_zu ! pot. air temp. adjusted at zu [K] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Ubzu ! bulk wind speed at zu [m/s] + ! + INTEGER , INTENT(in ), OPTIONAL :: nb_iter ! number of iterations + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CdN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: ChN + REAL(wp), INTENT( out), OPTIONAL, DIMENSION(jpi,jpj) :: CeN + ! + INTEGER :: nbit, jit ! iterations... + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + ! + REAL(wp), DIMENSION(jpi,jpj) :: zCdN, zCeN, zChN ! 10m neutral latent/sensible coefficient + REAL(wp), DIMENSION(jpi,jpj) :: zsqrt_Cd, zsqrt_CdN ! root square of Cd and Cd_neutral + REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + !!---------------------------------------------------------------------------------- + nbit = nb_iter0 + IF( PRESENT(nb_iter) ) nbit = nb_iter + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) ! testing "zu == zt" is risky with double precision + + Ubzu = MAX( 0.5_wp , U_zu ) ! relative wind speed at zu (normally 10m), we don't want to fall under 0.5 m/s + + !! First guess of stability: + ztmp0 = virt_temp(t_zt, q_zt) - virt_temp(sst, ssq) ! air-sea difference of virtual pot. temp. at zt + ztmp1 = 0.5_wp + SIGN(0.5_wp,ztmp0) ! ztmp1 = 1 if dTv > 0 => STABLE, 0 if unstable + + !! Neutral coefficients at 10m: + IF( ln_cdgw ) THEN ! wave drag case + cdn_wave(:,:) = cdn_wave(:,:) + rsmall * ( 1._wp - tmask(:,:,1) ) + zCdN (:,:) = cdn_wave(:,:) + ELSE + zCdN = cd_n10_ncar( Ubzu ) + ENDIF + + zsqrt_CdN = SQRT( zCdN ) + + !! Initializing transf. coeff. with their first guess neutral equivalents : + Cd = zCdN + Ce = ce_n10_ncar( zsqrt_CdN ) + Ch = ch_n10_ncar( zsqrt_CdN , ztmp1 ) ! ztmp1 is stability (1/0) + zsqrt_Cd = zsqrt_CdN + + IF( ln_cdgw ) THEN + zCeN = Ce + zChN = Ch + ENDIF + + !! Initializing values at z_u with z_t values: + t_zu = MAX( t_zt , 180._wp ) ! who knows what's given on masked-continental regions... + q_zu = MAX( q_zt , 1.e-6_wp ) ! " + + + !! ITERATION BLOCK + DO jit = 1, nbit + ! + ztmp1 = t_zu - sst ! Updating air/sea differences + ztmp2 = q_zu - ssq + + ! Updating turbulent scales : (L&Y 2004 Eq. (7)) + ztmp0 = zsqrt_Cd*Ubzu ! u* + ztmp1 = Ch/zsqrt_Cd*ztmp1 ! theta* + ztmp2 = Ce/zsqrt_Cd*ztmp2 ! q* + + ! Estimate the inverse of Obukov length (1/L) at height zu: + ztmp0 = One_on_L( t_zu, q_zu, ztmp0, ztmp1, ztmp2 ) + + !! Stability parameters : + zeta_u = zu*ztmp0 + zeta_u = sign( min(abs(zeta_u),10._wp), zeta_u ) + + !! Shifting temperature and humidity at zu (L&Y 2004 Eq. (9b-9c)) + IF( .NOT. l_zt_equal_zu ) THEN + ztmp0 = zt*ztmp0 ! zeta_t ! + ztmp0 = SIGN( MIN(ABS(ztmp0),10._wp), ztmp0 ) ! Temporaty array ztmp0 == zeta_t !!! + ztmp0 = LOG(zt/zu) + psi_h_ncar(zeta_u) - psi_h_ncar(ztmp0) ! ztmp0 just used as temp array again! + t_zu = t_zt - ztmp1/vkarmn*ztmp0 ! ztmp1 is still theta* L&Y 2004 Eq. (9b) + !! + q_zu = q_zt - ztmp2/vkarmn*ztmp0 ! ztmp2 is still q* L&Y 2004 Eq. (9c) + q_zu = MAX(0._wp, q_zu) + END IF + + ! Update neutral wind speed at 10m and neutral Cd at 10m (L&Y 2004 Eq. 9a)... + ! In very rare low-wind conditions, the old way of estimating the + ! neutral wind speed at 10m leads to a negative value that causes the code + ! to crash. To prevent this a threshold of 0.25m/s is imposed. + ztmp2 = psi_m_ncar(zeta_u) + IF( ln_cdgw ) THEN ! surface wave case + zsqrt_Cd = vkarmn / ( vkarmn / zsqrt_CdN - ztmp2 ) + Cd = zsqrt_Cd * zsqrt_Cd + ztmp0 = (LOG(zu/10._wp) - psi_h_ncar(zeta_u)) / vkarmn / zsqrt_CdN + ztmp2 = zsqrt_Cd / zsqrt_CdN + ztmp1 = 1._wp + zChN * ztmp0 + Ch = zChN * ztmp2 / ztmp1 ! L&Y 2004 eq. (10b) + ztmp1 = 1._wp + zCeN * ztmp0 + Ce = zCeN * ztmp2 / ztmp1 ! L&Y 2004 eq. (10c) + + ELSE + ztmp0 = MAX( 0.25_wp , UN10_from_CD(zu, Ubzu, Cd, ppsi=ztmp2) ) ! U_n10 (ztmp2 == psi_m_ncar(zeta_u)) + + zCdN = cd_n10_ncar(ztmp0) + zsqrt_CdN = sqrt(zCdN) + + !! Update of transfer coefficients: + + !! C_D + ztmp1 = 1._wp + zsqrt_CdN/vkarmn*(LOG(zu/10._wp) - ztmp2) ! L&Y 2004 Eq. (10a) (ztmp2 == psi_m(zeta_u)) + Cd = MAX( zCdN / ( ztmp1*ztmp1 ), Cx_min ) + + !! C_H and C_E + zsqrt_Cd = SQRT( Cd ) + ztmp0 = ( LOG(zu/10._wp) - psi_h_ncar(zeta_u) ) / vkarmn / zsqrt_CdN + ztmp2 = zsqrt_Cd / zsqrt_CdN + + ztmp1 = 0.5_wp + SIGN(0.5_wp,zeta_u) ! update stability + zChN = 1.e-3_wp * zsqrt_CdN*(18._wp*ztmp1 + 32.7_wp*(1._wp - ztmp1)) ! L&Y 2004 eq. (6c-6d) + zCeN = 1.e-3_wp * (34.6_wp * zsqrt_CdN) ! L&Y 2004 eq. (6b) + + Ch = MAX( zChN*ztmp2 / ( 1._wp + zChN*ztmp0 ) , Cx_min ) ! L&Y 2004 eq. (10b) + Ce = MAX( zCeN*ztmp2 / ( 1._wp + zCeN*ztmp0 ) , Cx_min ) ! L&Y 2004 eq. (10c) + + ENDIF + + END DO !DO jit = 1, nbit + + IF(PRESENT(CdN)) CdN(:,:) = zCdN(:,:) + IF(PRESENT(CeN)) CeN(:,:) = zCeN(:,:) + IF(PRESENT(ChN)) ChN(:,:) = zChN(:,:) + + END SUBROUTINE turb_ncar + + + FUNCTION cd_n10_ncar( pw10 ) + !!---------------------------------------------------------------------------------- + !! Estimate of the neutral drag coefficient at 10m as a function + !! of neutral wind speed at 10m + !! + !! Origin: Large & Yeager 2008, Eq. (11) + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pw10 ! scalar wind speed at 10m (m/s) + REAL(wp), DIMENSION(jpi,jpj) :: cd_n10_ncar + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zgt33, zw, zw6 ! local scalars + !!---------------------------------------------------------------------------------- + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zw = pw10(ji,jj) + zw6 = zw*zw*zw + zw6 = zw6*zw6 + ! + ! When wind speed > 33 m/s => Cyclone conditions => special treatment + zgt33 = 0.5_wp + SIGN( 0.5_wp, (zw - 33._wp) ) ! If pw10 < 33. => 0, else => 1 + ! + cd_n10_ncar(ji,jj) = 1.e-3_wp * ( & + & (1._wp - zgt33)*( 2.7_wp/zw + 0.142_wp + zw/13.09_wp - 3.14807E-10_wp*zw6) & ! wind < 33 m/s + & + zgt33 * 2.34_wp ) ! wind >= 33 m/s + ! + cd_n10_ncar(ji,jj) = MAX( cd_n10_ncar(ji,jj), Cx_min ) + ! + END_2D + ! + END FUNCTION cd_n10_ncar + + + FUNCTION ch_n10_ncar( psqrtcdn10 , pstab ) + !!---------------------------------------------------------------------------------- + !! Estimate of the neutral heat transfer coefficient at 10m !! + !! Origin: Large & Yeager 2008, Eq. (9) and (12) + + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: ch_n10_ncar + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 ) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pstab ! stable ABL => 1 / unstable ABL => 0 + !!---------------------------------------------------------------------------------- + IF( ANY(pstab < -0.00001) .OR. ANY(pstab > 1.00001) ) THEN + PRINT *, 'ERROR: ch_n10_ncar@mod_blk_ncar.f90: pstab =' + PRINT *, pstab + STOP + END IF + ! + ch_n10_ncar = MAX( 1.e-3_wp * psqrtcdn10*( 18._wp*pstab + 32.7_wp*(1._wp - pstab) ) , Cx_min ) ! Eq. (9) & (12) Large & Yeager, 2008 + ! + END FUNCTION ch_n10_ncar + + FUNCTION ce_n10_ncar( psqrtcdn10 ) + !!---------------------------------------------------------------------------------- + !! Estimate of the neutral heat transfer coefficient at 10m !! + !! Origin: Large & Yeager 2008, Eq. (9) and (13) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: ce_n10_ncar + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psqrtcdn10 ! sqrt( CdN10 ) + !!---------------------------------------------------------------------------------- + ce_n10_ncar = MAX( 1.e-3_wp * ( 34.6_wp * psqrtcdn10 ) , Cx_min ) + ! + END FUNCTION ce_n10_ncar + + + FUNCTION psi_m_ncar( pzeta ) + !!---------------------------------------------------------------------------------- + !! Universal profile stability function for momentum + !! !! Psis, L&Y 2004, Eq. (8c), (8d), (8e) + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_m_ncar + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx2, zx, zpsi_unst, zpsi_stab, zstab ! local scalars + !!---------------------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zta = pzeta(ji,jj) + ! + zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 - 16z)^0.5 + zx2 = MAX( zx2 , 1._wp ) + zx = SQRT(zx2) ! (1 - 16z)^0.25 + zpsi_unst = 2._wp*LOG( (1._wp + zx )*0.5_wp ) & + & + LOG( (1._wp + zx2)*0.5_wp ) & + & - 2._wp*ATAN(zx) + rpi*0.5_wp + ! + zpsi_stab = -5._wp*zta + ! + zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 + ! + psi_m_ncar(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable + ! + ! + END_2D + END FUNCTION psi_m_ncar + + + FUNCTION psi_h_ncar( pzeta ) + !!---------------------------------------------------------------------------------- + !! Universal profile stability function for temperature and humidity + !! !! Psis, L&Y 2004, Eq. (8c), (8d), (8e) + !! + !! pzeta : stability paramenter, z/L where z is altitude measurement + !! and L is M-O length + !! + !! ** Author: L. Brodeau, June 2016 / AeroBulk (https://github.com/brodeau/aerobulk/) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: psi_h_ncar + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pzeta + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zta, zx2, zpsi_unst, zpsi_stab, zstab ! local scalars + !!---------------------------------------------------------------------------------- + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zta = pzeta(ji,jj) + ! + zx2 = SQRT( ABS(1._wp - 16._wp*zta) ) ! (1 -16z)^0.5 + zx2 = MAX( zx2 , 1._wp ) + zpsi_unst = 2._wp*LOG( 0.5_wp*(1._wp + zx2) ) + ! + zpsi_stab = -5._wp*zta + ! + zstab = 0.5_wp + SIGN(0.5_wp, zta) ! zta > 0 => zstab = 1 + ! + psi_h_ncar(ji,jj) = zstab * zpsi_stab & ! (zta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zta < 0) Unstable + ! + END_2D + END FUNCTION psi_h_ncar + + !!====================================================================== +END MODULE sbcblk_algo_ncar \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_skin_coare.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_skin_coare.F90 new file mode 100644 index 0000000..54dedf9 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_skin_coare.F90 @@ -0,0 +1,313 @@ +MODULE sbcblk_skin_coare + !!====================================================================== + !! *** MODULE sbcblk_skin_coare *** + !! + !! Module that gathers the cool-skin and warm-layer parameterization used + !! in the COARE family of bulk parameterizations. + !! + !! Based on the last update for version COARE 3.6 (Fairall et al., 2019) + !! + !! Module 'sbcblk_skin_coare' also maintained and developed in AeroBulk (as + !! 'mod_skin_coare') + !! (https://github.com/brodeau/aerobulk) !! + !! ** Author: L. Brodeau, November 2019 / AeroBulk (https://github.com/brodeau/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.0 ! 2019-11 (L.Brodeau) Original code + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbc_oce ! Surface boundary condition: ocean fields + + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + + USE sbcdcy !#LB: to know hour of dawn and dusk: rdawn_dcy and rdusk_dcy (needed in WL_COARE) + + USE lib_mpp ! distribued memory computing library + USE in_out_manager ! I/O manager + USE lib_fortran ! to use key_nosignedzero + + IMPLICIT NONE + PRIVATE + + PUBLIC :: CS_COARE, WL_COARE + !! * Substitutions +# include "do_loop_substitute.h90" + + !! Cool-skin related parameters: + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_cs !: dT due to cool-skin effect + ! ! => temperature difference between air-sea interface (z=0) + ! ! and right below viscous layer (z=delta) + + !! Warm-layer related parameters: + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_wl !: dT due to warm-layer effect + ! ! => difference between "almost surface (right below + ! ! viscous layer, z=delta) and depth of bulk SST (z=gdept_1d(1)) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Hz_wl !: depth (aka thickness) of warm-layer [m] + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Qnt_ac !: time integral / accumulated heat stored by the warm layer + ! ! Qxdt => [J/m^2] (reset to zero every midnight) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Tau_ac !: time integral / accumulated momentum + ! ! Tauxdt => [N.s/m^2] (reset to zero every midnight) + + REAL(wp), PARAMETER, PUBLIC :: Hwl_max = 20._wp !: maximum depth of warm layer (adjustable) + ! + REAL(wp), PARAMETER :: rich = 0.65_wp !: critical Richardson number + ! + REAL(wp), PARAMETER :: zfr0 = 0.5_wp !: initial value of solar flux absorption + ! + !!---------------------------------------------------------------------- +CONTAINS + + + SUBROUTINE CS_COARE( pQsw, pQnsol, pustar, pSST, pQlat ) + !!--------------------------------------------------------------------- + !! + !! Cool-skin parameterization, based on Fairall et al., 1996, + !! revisited for COARE 3.6 (Fairall et al., 2019) + !! + !! Fairall, C. W., Bradley, E. F., Godfrey, J. S., Wick, G. A., + !! Edson, J. B., and Young, G. S. ( 1996), Cool‐skin and warm‐layer + !! effects on sea surface temperature, J. Geophys. Res., 101( C1), 1295-1308, + !! doi:10.1029/95JC03190. + !! + !!------------------------------------------------------------------ + !! + !! ** INPUT: + !! *pQsw* surface net solar radiation into the ocean [W/m^2] => >= 0 ! + !! *pQnsol* surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + !! *pustar* friction velocity u* [m/s] + !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] + !! *pQlat* surface latent heat flux [K] + !!------------------------------------------------------------------ + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQlat ! latent heat flux [W/m^2] + !!--------------------------------------------------------------------- + INTEGER :: ji, jj, jc + REAL(wp) :: zQabs, zdlt, zfr, zalfa, zqlat, zus + !!--------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + + zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta, + ! ! => we DO not miss a lot assuming 0 solar flux absorbed in the tiny layer of thicknes zdlt... + + zalfa = alpha_sw(pSST(ji,jj)) ! (crude) thermal expansion coefficient of sea-water [1/K] + zqlat = pQlat(ji,jj) + zus = pustar(ji,jj) + + + zdlt = delta_skin_layer( zalfa, zQabs, zqlat, zus ) + + DO jc = 1, 4 ! because implicit in terms of zdlt... + zfr = MAX( 0.137_wp + 11._wp*zdlt & + & - 6.6E-5_wp/zdlt*(1._wp - EXP(-zdlt/8.E-4_wp)) & + & , 0.01_wp ) ! Solar absorption, Eq.16 (Fairall al. 1996b) + ! !LB: why 0.065 and not 0.137 like in the paper??? Beljaars & Zeng use 0.065, not 0.137 ! + zQabs = pQnsol(ji,jj) + zfr*pQsw(ji,jj) + zdlt = delta_skin_layer( zalfa, zQabs, zqlat, zus ) + END DO + + dT_cs(ji,jj) = zQabs*zdlt/rk0_w ! temperature increment, yes dT_cs can actually > 0, if Qabs > 0 (rare but possible!) + + END_2D + + END SUBROUTINE CS_COARE + + + SUBROUTINE WL_COARE( pQsw, pQnsol, pTau, pSST, iwait ) + !!--------------------------------------------------------------------- + !! + !! Warm-Layer scheme according to COARE 3.6 (Fairall et al, 2019) + !! ------------------------------------------------------------------ + !! + !! ** INPUT: + !! *pQsw* surface net solar radiation into the ocean [W/m^2] => >= 0 ! + !! *pQnsol* surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + !! *pTau* surface wind stress [N/m^2] + !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] + !! *iwait* if /= 0 then wait before updating accumulated fluxes, we are within a converging itteration loop... + !!--------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pTau ! wind stress [N/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K] + INTEGER , INTENT(in) :: iwait ! if /= 0 then wait before updating accumulated fluxes + !! + INTEGER :: ji,jj + ! + REAL(wp) :: zdTwl, zHwl, zQabs, zfr + REAL(wp) :: zqac, ztac + REAL(wp) :: zalfa, zcd1, zcd2, flg + !!--------------------------------------------------------------------- + + REAL(wp) :: ztime, znoon, zmidn + INTEGER :: jl + + LOGICAL :: l_exit, l_destroy_wl + + !! INITIALIZATION: + zQabs = 0._wp ! total heat flux absorped in warm layer + zfr = zfr0 ! initial value of solar flux absorption !#LB: save it and use previous value !!! + + IF( .NOT. ln_dm2dc ) CALL sbc_dcy_param() ! we need to call sbc_dcy_param (sbcdcy.F90) because rdawn_dcy and rdusk_dcy are unkonwn otherwize! + + ztime = REAL(nsec_day,wp)/(24._wp*3600._wp) ! time of current time step since 00:00 for current day (UTC) -> ztime = 0 -> 00:00 / ztime = 0.5 -> 12:00 ... + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + + l_exit = .FALSE. + l_destroy_wl = .FALSE. + + zdTwl = dT_wl(ji,jj) ! value of previous time step as first guess + zHwl = MAX( MIN(Hz_wl(ji,jj),Hwl_max),0.1_wp) ! " " " + + zqac = Qnt_ac(ji,jj) ! previous time step Qnt_ac + ztac = Tau_ac(ji,jj) + + !***** variables for warm layer *** + zalfa = alpha_sw( pSST(ji,jj) ) ! (crude) thermal expansion coefficient of sea-water [1/K] (SST accurate enough!) + + zcd1 = SQRT(2._wp*rich*rCp0_w/(zalfa*grav*rho0_w)) !mess-o-constants 1 + zcd2 = SQRT(2._wp*zalfa*grav/(rich*rho0_w))/(rCp0_w**1.5) !mess-o-constants 2 + + + znoon = MOD( 0.5_wp*(rdawn_dcy(ji,jj)+rdusk_dcy(ji,jj)), 1._wp ) ! 0 rnoon*24 = UTC time of local noon + zmidn = MOD( znoon-0.5_wp , 1._wp ) + zmidn = MOD( zmidn + 0.125_wp , 1._wp ) ! 3 hours past the local midnight + + IF( (ztime >= zmidn) .AND. (ztime < rdawn_dcy(ji,jj)) ) THEN + ! Dawn reset to 0! + l_exit = .TRUE. + l_destroy_wl = .TRUE. + ENDIF + + IF( .NOT. l_exit ) THEN + !! Initial test on initial guess of absorbed heat flux in warm-layer: + zQabs = frac_solar_abs(zHwl)*pQsw(ji,jj) + pQnsol(ji,jj) ! first guess of tot. heat flux absorbed in warm layer + ! ! => #LB: depends of zfr, which is wild guess... Wrong!!! + IF( (ABS(zdTwl) < 1.E-6_wp) .AND. (zQabs <= 0._wp) ) THEN + ! We have not started to build a WL yet (dT==0) and there's no way it can occur now + ! since zQabs <= 0._wp + ! => no need to go further + l_exit = .TRUE. + ENDIF + + ENDIF + + ! Okay test on updated absorbed flux: + !#LB: remove??? has a strong influence !!! + IF( (.NOT. l_exit).AND.(Qnt_ac(ji,jj) + zQabs*rn_Dt <= 0._wp) ) THEN + l_exit = .TRUE. + l_destroy_wl = .TRUE. + ENDIF + + + IF( .NOT. l_exit) THEN + + ! Two possibilities at this point: + ! 1/ A warm layer already exists (dT>0) but it is cooling down because Qabs<0 + ! 2/ Regardless of WL formed (dT==0 or dT>0), we are in the process to initiate one or warm further it ! + + ztac = Tau_ac(ji,jj) + MAX(.002_wp , pTau(ji,jj))*rn_Dt ! updated momentum integral + !PRINT *, '#LBD: updated value for Tac=', REAL(ztac,4) + + !! We update the value of absorbtion and zQabs: + !! some part is useless if Qsw=0 !!! + DO jl = 1, 5 + zQabs = frac_solar_abs(zHwl)*pQsw(ji,jj) + pQnsol(ji,jj) + zqac = Qnt_ac(ji,jj) + zQabs*rn_Dt ! updated heat absorbed + IF( zqac <= 0._wp ) EXIT + zHwl = MAX( MIN( Hwl_max , zcd1*ztac/SQRT(zqac)) , 0.1_wp ) ! Warm-layer depth + END DO + + IF( zqac <= 0._wp ) THEN + l_destroy_wl = .TRUE. + l_exit = .TRUE. + ELSE + zdTwl = zcd2*zqac**1.5/ztac * MAX(zqac/ABS(zqac),0._wp) !! => IF(zqac>0._wp): zdTwl=zcd2*zqac**1.5/ztac ; ELSE: zdTwl=0. / ! normally: zqac > 0 ! + !PRINT *, '#LBD: updated preliminary value for dT_wl=', REAL(zdTwl,4) + ! Warm layer correction + flg = 0.5_wp + SIGN( 0.5_wp , gdept_1d(1)-zHwl ) ! => 1 when gdept_1d(1)>zHwl (zdTwl = zdTwl) | 0 when gdept_1d(1) term "Q + Rs*fs" in eq.6 of Fairall et al. 1996 + REAL(wp), INTENT(in) :: pQlat ! latent heat flux [W/m^2] + REAL(wp), INTENT(in) :: pustar_a ! friction velocity in the air (u*) [m/s] + !!--------------------------------------------------------------------- + REAL(wp) :: zusw, zusw2, zlamb, zQd, ztf, ztmp + !!--------------------------------------------------------------------- + + zQd = pQd + 0.026*MIN(pQlat,0._wp)*rCp0_w/rLevap/palpha ! #LB: Double check sign + division by palpha !!! units are okay! + + ztf = 0.5_wp + SIGN(0.5_wp, zQd) ! Qabs < 0 => cooling of the viscous layer => ztf = 0 (regular case) + ! ! Qabs > 0 => warming of the viscous layer => ztf = 1 (ex: weak evaporation and strong positive sensible heat flux) + ! + zusw = MAX(pustar_a, 1.E-4_wp) * sq_radrw ! u* in the water + zusw2 = zusw*zusw + ! + zlamb = 6._wp*( 1._wp + MAX(palpha*rcst_cs/(zusw2*zusw2)*zQd, 0._wp)**0.75 )**(-1./3.) ! see Eq.(14) in Fairall et al., 1996 + ! => zlamb is not used when Qd > 0, and since rcst_cs < 0, we just use this "MAX" to prevent FPE errors (something_negative)**0.75 + ! + ztmp = rnu0_w/zusw + delta_skin_layer = (1._wp-ztf) * zlamb*ztmp & ! regular case, Qd < 0, see Eq.(12) in Fairall et al., 1996 + & + ztf * MIN(6._wp*ztmp , 0.007_wp) ! when Qd > 0 + END FUNCTION delta_skin_layer + + + FUNCTION frac_solar_abs( pHwl ) + !!--------------------------------------------------------------------- + !! Fraction of solar heat flux absorbed inside warm layer + !!--------------------------------------------------------------------- + REAL(wp) :: frac_solar_abs + REAL(wp), INTENT(in) :: pHwl ! thickness of warm-layer [m] + !!--------------------------------------------------------------------- + frac_solar_abs = 1._wp - ( 0.28*0.014 *(1._wp - EXP(-pHwl/0.014)) & + & + 0.27*0.357*(1._wp - EXP(-pHwl/0.357)) & + & + 0.45*12.82*(1-EXP(-pHwl/12.82)) ) / pHwl + END FUNCTION frac_solar_abs + + !!====================================================================== +END MODULE sbcblk_skin_coare \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_skin_ecmwf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_skin_ecmwf.F90 new file mode 100644 index 0000000..cf9b990 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcblk_skin_ecmwf.F90 @@ -0,0 +1,310 @@ +MODULE sbcblk_skin_ecmwf + !!====================================================================== + !! *** MODULE sbcblk_skin_ecmwf *** + !! + !! Module that gathers the cool-skin and warm-layer parameterization used + !! by the IFS at ECMWF (recoded from scratch => + !! https://github.com/brodeau/aerobulk) + !! + !! Mainly based on Zeng & Beljaars, 2005 with the more recent add-up from + !! Takaya et al., 2010 when it comes to the warm-layer parameterization + !! (contribution of extra mixing due to Langmuir circulation) + !! + !! - Zeng X., and A. Beljaars, 2005: A prognostic scheme of sea surface skin + !! temperature for modeling and data assimilation. Geophysical Research + !! Letters, 32 (14) , pp. 1-4. + !! + !! - Takaya, Y., J.-R. Bildot, A. C. M. Beljaars, and P. A. E. M. Janssen, + !! 2010: Refinements to a prognostic scheme of skin sea surface + !! temperature. J. Geophys. Res., 115, C06009, doi:10.1029/2009JC005985 + !! + !! Most of the formula are taken from the documentation of IFS of ECMWF + !! (cycle 40r1) (avaible online on the ECMWF's website) + !! + !! Routine 'sbcblk_skin_ecmwf' also maintained and developed in AeroBulk (as + !! 'mod_skin_ecmwf') + !! (https://github.com/brodeau/aerobulk) + !! + !! ** Author: L. Brodeau, November 2019 / AeroBulk (https://github.com/brodeau/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.0 ! 2019-11 (L.Brodeau) Original code + !! 4.2 ! 2020-12 (L. Brodeau) Introduction of various air-ice bulk parameterizations + improvements + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbc_oce ! Surface boundary condition: ocean fields + + USE sbc_phy ! Catalog of functions for physical/meteorological parameters in the marine boundary layer + + USE lib_mpp ! distribued memory computing library + USE in_out_manager ! I/O manager + USE lib_fortran ! to use key_nosignedzero + + IMPLICIT NONE + PRIVATE + + PUBLIC :: CS_ECMWF, WL_ECMWF + !! * Substitutions +# include "do_loop_substitute.h90" + + !! Cool-skin related parameters: + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_cs !: dT due to cool-skin effect + ! ! => temperature difference between air-sea interface (z=0) + ! ! and right below viscous layer (z=delta) + + !! Warm-layer related parameters: + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: dT_wl !: dT due to warm-layer effect + ! ! => difference between "almost surface (right below + ! ! viscous layer, z=delta) and depth of bulk SST (z=gdept_1d(1)) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: Hz_wl !: depth (aka thickness) of warm-layer [m] + ! + REAL(wp), PARAMETER, PUBLIC :: rd0 = 3. !: Depth scale [m] of warm layer, "d" in Eq.11 (Zeng & Beljaars 2005) + REAL(wp), PARAMETER :: zRhoCp_w = rho0_w*rCp0_w + ! + REAL(wp), PARAMETER :: rNuwl0 = 0.5 !: Nu (exponent of temperature profile) Eq.11 + ! !: (Zeng & Beljaars 2005) !: set to 0.5 instead of + ! !: 0.3 to respect a warming of +3 K in calm + ! !: condition for the insolation peak of +1000W/m^2 + !!---------------------------------------------------------------------- +CONTAINS + + + SUBROUTINE CS_ECMWF( pQsw, pQnsol, pustar, pSST ) + !!--------------------------------------------------------------------- + !! + !! Cool-skin parameterization, based on Fairall et al., 1996: + !! + !! - Zeng X., and A. Beljaars, 2005: A prognostic scheme of sea surface + !! skin temperature for modeling and data assimilation. Geophysical + !! Research Letters, 32 (14) , pp. 1-4. + !! + !!------------------------------------------------------------------ + !! + !! ** INPUT: + !! *pQsw* surface net solar radiation into the ocean [W/m^2] => >= 0 ! + !! *pQnsol* surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + !! *pustar* friction velocity u* [m/s] + !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] + !!------------------------------------------------------------------ + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! net solar a.k.a shortwave radiation into the ocean (after albedo) [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! non-solar heat flux to the ocean [W/m^2] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity, temperature and humidity (u*,t*,q*) + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST [K] + !!--------------------------------------------------------------------- + INTEGER :: ji, jj, jc + REAL(wp) :: zQabs, zdlt, zfr, zalfa, zus + !!--------------------------------------------------------------------- + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + + zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta, + ! ! => we DO not miss a lot assuming 0 solar flux absorbed in the tiny layer of thicknes zdlt... + + zalfa = alpha_sw(pSST(ji,jj)) ! (crude) thermal expansion coefficient of sea-water [1/K] + zus = pustar(ji,jj) + + zdlt = delta_skin_layer( zalfa, zQabs, zus ) + + DO jc = 1, 4 ! because implicit in terms of zdlt... + zfr = MAX( 0.065_wp + 11._wp*zdlt & + & - 6.6E-5_wp/zdlt*(1._wp - EXP(-zdlt/8.E-4_wp)) & + & , 0.01_wp ) ! Solar absorption, Eq.(5) Zeng & Beljaars, 2005 + ! ! => (WARNING: 0.065 rather than 0.137 in Fairal et al. 1996) + zQabs = pQnsol(ji,jj) + zfr*pQsw(ji,jj) + zdlt = delta_skin_layer( zalfa, zQabs, zus ) + END DO + + dT_cs(ji,jj) = zQabs*zdlt/rk0_w ! temperature increment, yes dT_cs can actually > 0, if Qabs > 0 (rare but possible!) + + END_2D + + END SUBROUTINE CS_ECMWF + + + SUBROUTINE WL_ECMWF( pQsw, pQnsol, pustar, pSST, pustk ) + !!--------------------------------------------------------------------- + !! + !! Warm-Layer scheme according to Zeng & Beljaars, 2005 (GRL) with the + !! more recent add-up from Takaya et al., 2010 when it comes to the + !! warm-layer parameterization (contribution of extra mixing due to + !! Langmuir circulation) + !! + !! - Zeng X., and A. Beljaars, 2005: A prognostic scheme of sea surface skin + !! temperature for modeling and data assimilation. Geophysical Research + !! Letters, 32 (14) , pp. 1-4. + !! + !! - Takaya, Y., J.-R. Bildot, A. C. M. Beljaars, and P. A. E. M. Janssen, + !! 2010: Refinements to a prognostic scheme of skin sea surface + !! temperature. J. Geophys. Res., 115, C06009, doi:10.1029/2009JC005985 + !! + !! STIL NO PROGNOSTIC EQUATION FOR THE DEPTH OF THE WARM-LAYER! + !! + !! ------------------------------------------------------------------ + !! + !! ** INPUT: + !! *pQsw* surface net solar radiation into the ocean [W/m^2] => >= 0 ! + !! *pQnsol* surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + !! *pustar* friction velocity u* [m/s] + !! *pSST* bulk SST (taken at depth gdept_1d(1)) [K] + !!------------------------------------------------------------------ + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQsw ! surface net solar radiation into the ocean [W/m^2] => >= 0 ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pQnsol ! surface net non-solar heat flux into the ocean [W/m^2] => normally < 0 ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pustar ! friction velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pSST ! bulk SST at depth gdept_1d(1) [K] + !! + REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: pustk ! surface Stokes velocity [m/s] + ! + INTEGER :: ji, jj, jc + ! + REAL(wp) :: zHwl !: thickness of the warm-layer [m] + REAL(wp) :: ztcorr !: correction of dT w.r.t measurement depth of bulk SST (first T-point) + REAL(wp) :: zalfa !: thermal expansion coefficient of sea-water [1/K] + REAL(wp) :: zdTwl_b, zdTwl_n !: temp. diff. between "almost surface (right below viscous layer) and bottom of WL + REAL(wp) :: zfr, zeta + REAL(wp) :: zusw, zusw2 + REAL(wp) :: zLa, zfLa + REAL(wp) :: flg, zwf, zQabs + REAL(wp) :: ZA, ZB, zL1, zL2 + REAL(wp) :: zcst0, zcst1, zcst2, zcst3 + ! + LOGICAL :: l_pustk_known + !!--------------------------------------------------------------------- + + l_pustk_known = .FALSE. + IF( PRESENT(pustk) ) l_pustk_known = .TRUE. + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + + zHwl = Hz_wl(ji,jj) ! first guess for warm-layer depth (and unique..., less advanced than COARE3p6 !) + ! it is = rd0 (3m) in default Zeng & Beljaars case... + + !! Previous value of dT / warm-layer, adapted to depth: + flg = 0.5_wp + SIGN( 0.5_wp , gdept_1d(1)-zHwl ) ! => 1 when gdept_1d(1)>zHwl (dT_wl(ji,jj) = zdTwl) | 0 when z_s$ + ztcorr = flg + (1._wp - flg)*gdept_1d(1)/zHwl + zdTwl_b = MAX ( dT_wl(ji,jj) / ztcorr , 0._wp ) + ! zdTwl is the difference between "almost surface (right below viscous layer) and bottom of WL (here zHwl) + ! pdT " " and depth of bulk SST (here gdept_1d(1))! + !! => but of course in general the bulk SST is taken shallower than zHwl !!! So correction less pronounced! + !! => so here since pdT is difference between surface and gdept_1d(1), need to increase fof zdTwl ! + + zalfa = alpha_sw( pSST(ji,jj) ) ! (crude) thermal expansion coefficient of sea-water [1/K] (SST accurate enough!) + + ! *** zfr = Fraction of solar radiation absorbed in warm layer (-) + zfr = 1._wp - 0.28_wp*EXP(-71.5_wp*zHwl) - 0.27_wp*EXP(-2.8_wp*zHwl) - 0.45_wp*EXP(-0.07_wp*zHwl) !: Eq. 8.157 + + zQabs = zfr*pQsw(ji,jj) + pQnsol(ji,jj) ! tot heat absorbed in warm layer + + zusw = MAX( pustar(ji,jj), 1.E-4_wp ) * sq_radrw ! u* in the water + zusw2 = zusw*zusw + + ! Langmuir: + IF( l_pustk_known ) THEN + zLa = SQRT(zusw/MAX(pustk(ji,jj),1.E-6)) + ELSE + zla = 0.3_wp + ENDIF + zfLa = MAX( zla**(-2._wp/3._wp) , 1._wp ) ! Eq.(6) + + zwf = 0.5_wp + SIGN(0.5_wp, zQabs) ! zQabs > 0. => 1. / zQabs < 0. => 0. + + zcst1 = vkarmn*grav*zalfa + + ! 1/L when zQabs > 0 : + zL2 = zcst1*zQabs / (zRhoCp_w*zusw2*zusw) + + zcst2 = zcst1 / ( 5._wp*zHwl*zusw2 ) !OR: zcst2 = zcst1*rNuwl0 / ( 5._wp*zHwl*zusw2 ) ??? + + zcst0 = rn_Dt * (rNuwl0 + 1._wp) / zHwl + + ZA = zcst0 * zQabs / ( rNuwl0 * zRhoCp_w ) + + zcst3 = -zcst0 * vkarmn * zusw * zfLa + + !! Sorry about all these constants ( constant w.r.t zdTwl), it's for + !! the sake of optimizations... So all these operations are not done + !! over and over within the iteration loop... + + !! T R U L L Y I M P L I C I T => needs itteration + !! => have to itterate just because the 1/(Monin-Obukhov length), zL1, uses zdTwl when zQabs < 0.. + !! (without this term otherwize the implicit analytical solution is straightforward...) + zdTwl_n = zdTwl_b + DO jc = 1, 10 + + zdTwl_n = 0.5_wp * ( zdTwl_n + zdTwl_b ) ! semi implicit, for faster convergence + + ! 1/L when zdTwl > 0 .AND. zQabs < 0 : + zL1 = SQRT( zdTwl_n * zcst2 ) ! / zusw !!! Or??? => vkarmn * SQRT( zdTwl_n*grav*zalfa/( 5._wp*zHwl ) ) / zusw + + ! Stability parameter (z/L): + zeta = (1._wp - zwf) * zHwl*zL1 + zwf * zHwl*zL2 + + ZB = zcst3 / PHI(zeta) + + zdTwl_n = MAX ( zdTwl_b + ZA + ZB*zdTwl_n , 0._wp ) ! Eq.(6) + + END DO + + !! Update: + dT_wl(ji,jj) = zdTwl_n * ztcorr + + END_2D + + END SUBROUTINE WL_ECMWF + + + FUNCTION delta_skin_layer( palpha, pQd, pustar_a ) + !!--------------------------------------------------------------------- + !! Computes the thickness (m) of the viscous skin layer. + !! Based on Fairall et al., 1996 + !! + !! Fairall, C. W., Bradley, E. F., Godfrey, J. S., Wick, G. A., + !! Edson, J. B., and Young, G. S. ( 1996), Cool‐skin and warm‐layer + !! effects on sea surface temperature, J. Geophys. Res., 101( C1), 1295-1308, + !! doi:10.1029/95JC03190. + !! + !! L. Brodeau, october 2019 + !!--------------------------------------------------------------------- + REAL(wp) :: delta_skin_layer + REAL(wp), INTENT(in) :: palpha ! thermal expansion coefficient of sea-water (SST accurate enough!) + REAL(wp), INTENT(in) :: pQd ! < 0 !!! part of the net heat flux actually absorbed in the WL [W/m^2] + ! ! => term "Q + Rs*fs" in eq.6 of Fairall et al. 1996 + REAL(wp), INTENT(in) :: pustar_a ! friction velocity in the air (u*) [m/s] + !!--------------------------------------------------------------------- + REAL(wp) :: zusw, zusw2, zlamb, ztf, ztmp + !!--------------------------------------------------------------------- + ztf = 0.5_wp + SIGN(0.5_wp, pQd) ! Qabs < 0 => cooling of the viscous layer => ztf = 0 (regular case) + ! ! Qabs > 0 => warming of the viscous layer => ztf = 1 + ! ! (ex: weak evaporation and strong positive sensible heat flux) + zusw = MAX(pustar_a, 1.E-4_wp) * sq_radrw ! u* in the water + zusw2 = zusw*zusw + ! + zlamb = 6._wp*( 1._wp + MAX(palpha*rcst_cs/(zusw2*zusw2)*pQd, 0._wp)**0.75 )**(-1./3.) ! see Eq.(14) in Fairall et al., 1996 + ! => zlamb is not used when Qd > 0, and since rcst_cs < 0, we just use this "MAX" to prevent FPE errors (something_negative)**0.75 + ! + ztmp = rnu0_w/zusw + delta_skin_layer = (1._wp-ztf) * zlamb*ztmp & ! regular case, Qd < 0, see Eq.(12) in Fairall et al., 1996 + & + ztf * MIN(6._wp*ztmp , 0.007_wp) ! when Qd > 0 + END FUNCTION delta_skin_layer + + + FUNCTION PHI( pzeta) + !!--------------------------------------------------------------------- + !! + !! Takaya et al., 2010 + !! Eq.(5) + !! L. Brodeau, october 2019 + !!--------------------------------------------------------------------- + REAL(wp) :: PHI + REAL(wp), INTENT(in) :: pzeta ! stability parameter + !!--------------------------------------------------------------------- + REAL(wp) :: ztf, zzt2 + !!--------------------------------------------------------------------- + zzt2 = pzeta*pzeta + ztf = 0.5_wp + SIGN(0.5_wp, pzeta) ! zeta > 0 => ztf = 1 + ! ! zeta < 0 => ztf = 0 + PHI = ztf * ( 1. + (5.*pzeta + 4.*zzt2)/(1. + 3.*pzeta + 0.25*zzt2) ) & ! zeta > 0 + & + (1. - ztf) * 1./SQRT( 1. - 16.*(-ABS(pzeta)) ) ! zeta < 0 + END FUNCTION PHI + + !!====================================================================== +END MODULE sbcblk_skin_ecmwf \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcclo.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcclo.F90 new file mode 100644 index 0000000..edcb234 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcclo.F90 @@ -0,0 +1,352 @@ +MODULE sbcclo + !!====================================================================== + !! *** MODULE sbcclo *** + !! Ocean forcing: redistribution of emp unbalance over closed sea into river mouth or open ocean + !!===================================================================== + !! History : 4.0 and earlier ! see closea.F90 history + !! NEMO 4.1 ! 2019-09 (P. Mathiot) rewrite sbc_clo module to match new closed sea mask definition (original sbcclo.F90) + !! + !!---------------------------------------------------------------------- + ! + !!---------------------------------------------------------------------- + !! Public subroutines: + !! sbc_clo : update emp and qns over target area and source area + !! sbc_clo_init : initialise all variable needed for closed sea correction + !! + !! Private subroutines: + !! alloc_csarr : allocate closed sea array + !! get_cssrcsurf : compute source surface area + !! get_cstrgsurf : compute target surface area + !! prt_csctl : closed sea control print + !! sbc_csupdate : compute net fw from closed sea + !!---------------------------------------------------------------------- + ! + USE closea ! closed sea + USE in_out_manager ! I/O manager + ! + USE dom_oce, ONLY: e1e2t ! ocean space and time domain + USE phycst , ONLY: rcp ! physical constants + USE sbc_oce, ONLY: emp, qns, rnf, sst_m ! ocean surface boundary conditions + USE iom , ONLY: iom_put ! I/O routines + USE lib_fortran, ONLY: glob_sum ! fortran library + USE lib_mpp , ONLY: mpp_min, ctl_stop ! MPP library + ! + IMPLICIT NONE + ! + PRIVATE + ! + PUBLIC sbc_clo + PUBLIC sbc_clo_init + ! + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrcg, rsurftrgg !: closed sea source/target glo surface areas + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrcr, rsurftrgr !: closed sea source/target rnf surface areas + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:) :: rsurfsrce, rsurftrge !: closed sea source/target emp surface areas + ! + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: mcsgrpg, mcsgrpr, mcsgrpe !: closed sea group for glo, rnf and emp + ! + CONTAINS + ! + !!---------------------------------------------------------------------- + !! Public subroutines + !!---------------------------------------------------------------------- + ! + SUBROUTINE sbc_clo_init + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_clo_init *** + !! + !! ** Purpose : Initialisation of the variable needed for the net fw closed sea correction + !! + !! ** Method : - compute source surface area for each closed sea + !! - defined the group of each closed sea + !! (needed to manage multiple closed sea and one target area like great lakes / St Laurent outlet) + !! - compute target surface area + !!---------------------------------------------------------------------- + ! + ! 0. Allocate cs variables (surf) + CALL alloc_csarr( ncsg, rsurfsrcg, rsurftrgg, mcsgrpg ) + CALL alloc_csarr( ncsr, rsurfsrcr, rsurftrgr, mcsgrpr ) + CALL alloc_csarr( ncse, rsurfsrce, rsurftrge, mcsgrpe ) + ! + ! 1. compute source surface area + CALL get_cssrcsurf( ncsg, mask_csglo, rsurfsrcg ) + CALL get_cssrcsurf( ncsr, mask_csrnf, rsurfsrcr ) + CALL get_cssrcsurf( ncse, mask_csemp, rsurfsrce ) + ! + ! 2. compute target surface area and group number (mcsgrp) for all cs and cases + ! glo could be simpler but for lisibility, all treated the same way + ! It is only done once, so not a big deal + CALL get_cstrgsurf( ncsg, mask_csglo, mask_csgrpglo, rsurftrgg, mcsgrpg ) + CALL get_cstrgsurf( ncsr, mask_csrnf, mask_csgrprnf, rsurftrgr, mcsgrpr ) + CALL get_cstrgsurf( ncse, mask_csemp, mask_csgrpemp, rsurftrge, mcsgrpe ) + ! + ! 3. print out in ocean.ouput + IF ( lwp ) WRITE(numout,*) 'sbc_clo_init : compute surface area for source (closed sea) and target (river mouth)' + IF ( lwp ) WRITE(numout,*) '~~~~~~~~~~~~~~' + CALL prt_csctl( ncsg, rsurfsrcg, rsurftrgg, mcsgrpg, 'glo' ) + CALL prt_csctl( ncsr, rsurfsrcr, rsurftrgr, mcsgrpr, 'rnf' ) + CALL prt_csctl( ncse, rsurfsrce, rsurftrge, mcsgrpe, 'emp' ) + + END SUBROUTINE sbc_clo_init + + SUBROUTINE sbc_clo( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_clo *** + !! + !! ** Purpose : Special handling of closed seas + !! + !! ** Method : Water flux is forced to zero over closed sea + !! Excess is shared between remaining ocean, or + !! put as run-off in open ocean. + !! + !! ** Action : - compute surface freshwater fluxes and associated heat content flux at kt + !! - output closed sea contribution to fw and heat budget + !! - update emp and qns + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean model time step + ! + REAL(wp), DIMENSION(jpi,jpj) :: zwcs, zqcs ! water flux and heat flux correction due to closed seas + !!---------------------------------------------------------------------- + ! + ! 0. initialisation + zwcs(:,:) = 0._wp ; zqcs(:,:) = 0._wp + ! + ! 1. update emp and qns + CALL sbc_csupdate( ncsg, mcsgrpg, mask_csglo, mask_csgrpglo, rsurfsrcg, rsurftrgg, 'glo', mask_opnsea, rsurftrgg, zwcs, zqcs ) + CALL sbc_csupdate( ncsr, mcsgrpr, mask_csrnf, mask_csgrprnf, rsurfsrcr, rsurftrgr, 'rnf', mask_opnsea, rsurftrgg, zwcs, zqcs ) + CALL sbc_csupdate( ncse, mcsgrpe, mask_csemp, mask_csgrpemp, rsurfsrce, rsurftrge, 'emp', mask_opnsea, rsurftrgg, zwcs, zqcs ) + ! + ! 2. ouput closed sea contributions + CALL iom_put('wclosea',zwcs) + CALL iom_put('qclosea',zqcs) + ! + ! 3. update emp and qns + emp(:,:) = emp(:,:) + zwcs(:,:) + qns(:,:) = qns(:,:) + zqcs(:,:) + ! + END SUBROUTINE sbc_clo + ! + !!---------------------------------------------------------------------- + !! Private subroutines + !!---------------------------------------------------------------------- + ! + SUBROUTINE get_cssrcsurf(kncs, kmaskcs, psurfsrc) + !!----------------------------------------------------------------------- + !! *** routine get_cssrcsurf *** + !! + !! ** Purpose : compute closed sea (source) surface area + !!---------------------------------------------------------------------- + ! subroutine parameters + INTEGER , INTENT(in ) :: kncs ! closed sea number + INTEGER , DIMENSION(:,:), INTENT(in ) :: kmaskcs ! closed sea mask + REAL(wp), DIMENSION(:) , INTENT( out) :: psurfsrc ! source surface area + + ! local variables + INTEGER :: jcs ! loop index + INTEGER, DIMENSION(jpi,jpj) :: imsksrc ! source mask + !!---------------------------------------------------------------------- + ! + DO jcs = 1,kncs ! loop over closed seas + ! + ! 0. build river mouth mask for this lake + WHERE ( kmaskcs == jcs ) + imsksrc = 1 + ELSE WHERE + imsksrc = 0 + END WHERE + ! + ! 1. compute target area + psurfsrc(jcs) = glob_sum('closea', e1e2t(:,:) * imsksrc(:,:) ) + ! + END DO ! jcs + + END SUBROUTINE get_cssrcsurf + + SUBROUTINE get_cstrgsurf(kncs, kmaskcs, kmaskcsgrp, psurftrg, kcsgrp ) + !!----------------------------------------------------------------------- + !! *** routine get_cstrgsurf *** + !! + !! ** Purpose : compute closed sea (target) surface area + !!---------------------------------------------------------------------- + ! subroutine parameters + ! input + INTEGER, INTENT(in ) :: kncs ! closed sea number + INTEGER, DIMENSION(:,:), INTENT(in ) :: kmaskcs, kmaskcsgrp ! closed sea and group mask + + ! output + INTEGER , DIMENSION(:) , INTENT( out) :: kcsgrp ! closed sea group number + REAL(wp), DIMENSION(:) , INTENT( out) :: psurftrg ! target surface area + + ! local variables + INTEGER :: jcs, jtmp ! tmp + INTEGER, DIMENSION(jpi,jpj) :: imskgrp, imsksrc, imsktrg, imsk ! tmp group, source, target and tmp mask + !!---------------------------------------------------------------------- + ! + DO jcs = 1,kncs ! loop over closed seas + ! + !! 0. find group number for cs number jcs + imskgrp(:,:) = kmaskcsgrp(:,:) + imsksrc(:,:) = kmaskcs(:,:) + ! + ! set cs value where cs is defined + ! imsk = HUGE outside the cs id jcs + imsk(:,:) = HUGE(1) + WHERE ( imsksrc(:,:) == jcs ) imsk(:,:) = jcs + ! + ! jtmp = jcs - group id for this lake + imsk(:,:) = imsk(:,:) - imskgrp(:,:) + jtmp = MINVAL(imsk(:,:)) ; CALL mpp_min('closea',jtmp) + ! kcsgrp = group id corresponding to the cs id jcs + ! kcsgrp(jcs)=(jcs - (jcs - group id))=group id + kcsgrp(jcs) = jcs - jtmp + ! + !! 1. build the target river mouth mask for this lake + WHERE ( imskgrp(:,:) * mask_opnsea(:,:) == kcsgrp(jcs) ) + imsktrg(:,:) = 1 + ELSE WHERE + imsktrg(:,:) = 0 + END WHERE + ! + !! 2. compute target area + psurftrg(jcs) = glob_sum('closea', e1e2t(:,:) * imsktrg(:,:) ) + ! + END DO ! jcs + + END SUBROUTINE get_cstrgsurf + + SUBROUTINE prt_csctl(kncs, psurfsrc, psurftrg, kcsgrp, cdcstype) + !!----------------------------------------------------------------------- + !! *** routine prt_csctl *** + !! + !! ** Purpose : output information about each closed sea (src id, trg id, src area and trg area) + !!---------------------------------------------------------------------- + ! subroutine parameters + INTEGER, INTENT(in ) :: kncs ! closed sea number + INTEGER, DIMENSION(:) , INTENT(in ) :: kcsgrp ! closed sea group number + ! + REAL(wp), DIMENSION(:), INTENT(in ) :: psurfsrc, psurftrg ! source and target surface area + ! + CHARACTER(LEN=3) , INTENT(in ) :: cdcstype ! closed sea scheme used for redistribution + !!---------------------------------------------------------------------- + ! local variable + INTEGER :: jcs + !!---------------------------------------------------------------------- + ! + IF ( lwp .AND. kncs > 0 ) THEN + WRITE(numout,*)'' + ! + WRITE(numout,*)'Closed sea target ',TRIM(cdcstype),' : ' + ! + DO jcs = 1,kncs + WRITE(numout,FMT='(3a,i3,a,i3)') ' ',TRIM(cdcstype),' closed sea id is ',jcs,' and trg group id is : ', kcsgrp(jcs) + WRITE(numout,FMT='(a,f12.2)' ) ' src surface areas (km2) : ', psurfsrc(jcs) * 1.0e-6 + WRITE(numout,FMT='(a,f12.2)' ) ' trg surface areas (km2) : ', psurftrg(jcs) * 1.0e-6 + END DO + ! + WRITE(numout,*)'' + END IF + + END SUBROUTINE prt_csctl + + SUBROUTINE sbc_csupdate(kncs, kcsgrp, kmsk_src, kmsk_grp, psurfsrc, psurftrg, cdcstype, kmsk_opnsea, psurf_opnsea, pwcs, pqcs) + !!----------------------------------------------------------------------- + !! *** routine sbc_csupdate *** + !! + !! ** Purpose : - compute the net freshwater fluxes over each closed seas + !! - apply correction to closed sea source/target net fwf accordingly + !!---------------------------------------------------------------------- + ! subroutine parameters + CHARACTER(LEN=3) , INTENT(in ) :: cdcstype ! closed sea scheme used for redistribution + ! + INTEGER, INTENT(in) :: kncs ! closed sea id + INTEGER, DIMENSION(: ), INTENT(in) :: kcsgrp ! closed sea group id + INTEGER, DIMENSION(:,:), INTENT(in) :: kmsk_src, kmsk_grp, kmsk_opnsea ! source, target, open ocean mask + + REAL(wp), DIMENSION(:) , INTENT(in ) :: psurfsrc, psurftrg, psurf_opnsea ! source, target and open ocean surface area + REAL(wp), DIMENSION(:,:), INTENT(inout) :: pwcs, pqcs ! water and heat flux correction due to closed seas + + + ! local variables + INTEGER :: jcs ! loop index over closed sea + INTEGER, DIMENSION(jpi,jpj) :: imsk_src, imsk_trg ! tmp array source and target closed sea masks + + REAL(wp) :: zcsfw, zcsh ! total fresh water and associated heat over one closed sea + REAL(wp) :: zcsfwf ! mean fresh water flux over one closed sea + REAL(wp) :: zsurftrg, zsurfsrc ! total target surface area + !!---------------------------------------------------------------------- + ! + DO jcs = 1, kncs ! loop over closed seas + ! + !! 0. get mask and surface of the closed sea + ! mask src + WHERE ( kmsk_src(:,:) == jcs ) + imsk_src(:,:) = 1 + ELSEWHERE + imsk_src(:,:) = 0 + END WHERE + ! area src + zsurfsrc = psurfsrc(jcs) + ! + !! 1. Work out net freshwater over the closed sea from EMP - RNF. + !! Work out net heat associated with the correction (needed for conservation) + !! (PM: should we consider used delayed glob sum ?) + zcsfw = glob_sum( 'closea', e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * imsk_src(:,:) ) + ! + !! 2. Deal with runoff special case (net evaporation spread globally) + !! and compute trg mask + IF (cdcstype == 'rnf' .AND. zcsfw > 0._wp) THEN + zsurftrg = psurf_opnsea(1) ! change the target area surface + imsk_trg = kcsgrp(jcs) * kmsk_opnsea ! trg mask is now the open sea mask + ELSE + zsurftrg = psurftrg(jcs) + imsk_trg = kmsk_grp * kmsk_opnsea + END IF + ! + IF( zsurftrg > 0._wp ) THEN ! target area /=0 + !! 3. Subtract residuals from source points + zcsfwf = zcsfw / zsurfsrc + pwcs(:,:) = pwcs(:,:) - zcsfwf * imsk_src(:,:) + pqcs(:,:) = pqcs(:,:) + rcp * zcsfwf * sst_m(:,:) * imsk_src(:,:) + ! + !! 4. Add residuals to target points + !! Do not use pqcs(:,:) = pqcs(:,:) - rcp * zcsfw * sst_m(:,:) / zsurftrg + !! as there is no reason heat will be conserved with this formulation + zcsh = glob_sum( 'closea', e1e2t(:,:) * rcp * zcsfwf * sst_m(:,:) * imsk_src(:,:) ) + WHERE( imsk_trg(:,:) == kcsgrp(jcs) ) + pwcs(:,:) = pwcs(:,:) + zcsfw / zsurftrg + pqcs(:,:) = pqcs(:,:) - zcsh / zsurftrg + ENDWHERE + ENDIF + ! + END DO ! jcs + + END SUBROUTINE sbc_csupdate + + SUBROUTINE alloc_csarr( klen, pvarsrc, pvartrg, kvargrp ) + !!----------------------------------------------------------------------- + !! *** routine alloc_cssurf *** + !! + !! ** Purpose : allocate closed sea surface array + !!---------------------------------------------------------------------- + ! subroutine parameters + INTEGER, INTENT(in) :: klen + INTEGER, ALLOCATABLE, DIMENSION(:), INTENT( out) :: kvargrp + REAL(wp), ALLOCATABLE, DIMENSION(:), INTENT( out) :: pvarsrc, pvartrg + ! + ! local variables + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + ! klen (number of lake) can be zero so use MAX(klen,1) to avoid 0 length array + ALLOCATE( pvarsrc(MAX(klen,1)) , pvartrg(MAX(klen,1)) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate surf array') + ! + ALLOCATE( kvargrp(MAX(klen,1)) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate group array') + ! + ! initialise to 0 + pvarsrc(:) = 0.e0_wp + pvartrg(:) = 0.e0_wp + kvargrp(:) = 0 + END SUBROUTINE alloc_csarr + +END MODULE \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbccpl.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbccpl.F90 new file mode 100644 index 0000000..b6db648 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbccpl.F90 @@ -0,0 +1,2789 @@ +MODULE sbccpl + !!====================================================================== + !! *** MODULE sbccpl *** + !! Surface Boundary Condition : momentum, heat and freshwater fluxes in coupled mode + !!====================================================================== + !! History : 2.0 ! 2007-06 (R. Redler, N. Keenlyside, W. Park) Original code split into flxmod & taumod + !! 3.0 ! 2008-02 (G. Madec, C Talandier) surface module + !! 3.1 ! 2009_02 (G. Madec, S. Masson, E. Maisonave, A. Caubel) generic coupled interface + !! 3.4 ! 2011_11 (C. Harris) more flexibility + multi-category fields + !! 4.2 ! 2020-12 (G. Madec, E. Clementi) wave coupling updates + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! namsbc_cpl : coupled formulation namlist + !! sbc_cpl_init : initialisation of the coupled exchanges + !! sbc_cpl_rcv : receive fields from the atmosphere over the ocean (ocean only) + !! receive stress from the atmosphere over the ocean (ocean-ice case) + !! sbc_cpl_ice_tau : receive stress from the atmosphere over ice + !! sbc_cpl_ice_flx : receive fluxes from the atmosphere over ice + !! sbc_cpl_snd : send fields to the atmosphere + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + USE trc_oce ! share SMS/Ocean variables + USE sbc_ice ! Surface boundary condition: ice fields + USE sbcapr ! Stochastic param. : ??? + USE sbcdcy ! surface boundary condition: diurnal cycle + USE sbcwave ! surface boundary condition: waves + USE phycst ! physical constants + USE isf_oce , ONLY : l_isfoasis, fwfisf_oasis ! ice shelf boundary condition +#if defined key_si3 + USE ice ! ice variables +#endif + USE cpl_oasis3 ! OASIS3 coupling + USE geo2ocean ! + USE oce , ONLY : ts, uu, vv, ssh, fraqsr_1lev + USE ocealb ! + USE eosbn2 ! + USE sbcrnf , ONLY : l_rnfcpl +#if defined key_cice + USE ice_domain_size, only: ncat +#endif +#if defined key_si3 + USE icevar ! for CALL ice_var_snwblow +#endif + ! + USE in_out_manager ! I/O manager + USE iom ! NetCDF library + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + +#if defined key_oasis3 + USE mod_oasis, ONLY : OASIS_Sent, OASIS_ToRest, OASIS_SentOut, OASIS_ToRestOut +#endif + + USE sbc_phy, ONLY : pp_cldf, rpref + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_cpl_init ! routine called by sbcmod.F90 + PUBLIC sbc_cpl_rcv ! routine called by icestp.F90 + PUBLIC sbc_cpl_snd ! routine called by step.F90 + PUBLIC sbc_cpl_ice_tau ! routine called by icestp.F90 + PUBLIC sbc_cpl_ice_flx ! routine called by icestp.F90 + PUBLIC sbc_cpl_alloc ! routine called in sbcice_cice.F90 + + INTEGER, PARAMETER :: jpr_otx1 = 1 ! 3 atmosphere-ocean stress components on grid 1 + INTEGER, PARAMETER :: jpr_oty1 = 2 ! + INTEGER, PARAMETER :: jpr_otz1 = 3 ! + INTEGER, PARAMETER :: jpr_otx2 = 4 ! 3 atmosphere-ocean stress components on grid 2 + INTEGER, PARAMETER :: jpr_oty2 = 5 ! + INTEGER, PARAMETER :: jpr_otz2 = 6 ! + INTEGER, PARAMETER :: jpr_itx1 = 7 ! 3 atmosphere-ice stress components on grid 1 + INTEGER, PARAMETER :: jpr_ity1 = 8 ! + INTEGER, PARAMETER :: jpr_itz1 = 9 ! + INTEGER, PARAMETER :: jpr_itx2 = 10 ! 3 atmosphere-ice stress components on grid 2 + INTEGER, PARAMETER :: jpr_ity2 = 11 ! + INTEGER, PARAMETER :: jpr_itz2 = 12 ! + INTEGER, PARAMETER :: jpr_qsroce = 13 ! Qsr above the ocean + INTEGER, PARAMETER :: jpr_qsrice = 14 ! Qsr above the ice + INTEGER, PARAMETER :: jpr_qsrmix = 15 + INTEGER, PARAMETER :: jpr_qnsoce = 16 ! Qns above the ocean + INTEGER, PARAMETER :: jpr_qnsice = 17 ! Qns above the ice + INTEGER, PARAMETER :: jpr_qnsmix = 18 + INTEGER, PARAMETER :: jpr_rain = 19 ! total liquid precipitation (rain) + INTEGER, PARAMETER :: jpr_snow = 20 ! solid precipitation over the ocean (snow) + INTEGER, PARAMETER :: jpr_tevp = 21 ! total evaporation + INTEGER, PARAMETER :: jpr_ievp = 22 ! solid evaporation (sublimation) + INTEGER, PARAMETER :: jpr_sbpr = 23 ! sublimation - liquid precipitation - solid precipitation + INTEGER, PARAMETER :: jpr_semp = 24 ! solid freshwater budget (sublimation - snow) + INTEGER, PARAMETER :: jpr_oemp = 25 ! ocean freshwater budget (evap - precip) + INTEGER, PARAMETER :: jpr_w10m = 26 ! 10m wind + INTEGER, PARAMETER :: jpr_dqnsdt = 27 ! d(Q non solar)/d(temperature) + INTEGER, PARAMETER :: jpr_rnf = 28 ! runoffs + INTEGER, PARAMETER :: jpr_cal = 29 ! calving + INTEGER, PARAMETER :: jpr_taum = 30 ! wind stress module + INTEGER, PARAMETER :: jpr_co2 = 31 + INTEGER, PARAMETER :: jpr_topm = 32 ! topmeltn + INTEGER, PARAMETER :: jpr_botm = 33 ! botmeltn + INTEGER, PARAMETER :: jpr_sflx = 34 ! salt flux + INTEGER, PARAMETER :: jpr_toce = 35 ! ocean temperature + INTEGER, PARAMETER :: jpr_soce = 36 ! ocean salinity + INTEGER, PARAMETER :: jpr_ocx1 = 37 ! ocean current on grid 1 + INTEGER, PARAMETER :: jpr_ocy1 = 38 ! + INTEGER, PARAMETER :: jpr_ssh = 39 ! sea surface height + INTEGER, PARAMETER :: jpr_fice = 40 ! ice fraction + INTEGER, PARAMETER :: jpr_e3t1st = 41 ! first T level thickness + INTEGER, PARAMETER :: jpr_fraqsr = 42 ! fraction of solar net radiation absorbed in the first ocean level + INTEGER, PARAMETER :: jpr_mslp = 43 ! mean sea level pressure + !** surface wave coupling ** + INTEGER, PARAMETER :: jpr_hsig = 44 ! Hsig + INTEGER, PARAMETER :: jpr_phioc = 45 ! Wave=>ocean energy flux + INTEGER, PARAMETER :: jpr_sdrftx = 46 ! Stokes drift on grid 1 + INTEGER, PARAMETER :: jpr_sdrfty = 47 ! Stokes drift on grid 2 + INTEGER, PARAMETER :: jpr_wper = 48 ! Mean wave period + INTEGER, PARAMETER :: jpr_wnum = 49 ! Mean wavenumber + INTEGER, PARAMETER :: jpr_wstrf = 50 ! Stress fraction adsorbed by waves + INTEGER, PARAMETER :: jpr_wdrag = 51 ! Neutral surface drag coefficient + INTEGER, PARAMETER :: jpr_charn = 52 ! Chranock coefficient + INTEGER, PARAMETER :: jpr_twox = 53 ! wave to ocean momentum flux + INTEGER, PARAMETER :: jpr_twoy = 54 ! wave to ocean momentum flux + INTEGER, PARAMETER :: jpr_tawx = 55 ! net wave-supported stress + INTEGER, PARAMETER :: jpr_tawy = 56 ! net wave-supported stress + INTEGER, PARAMETER :: jpr_bhd = 57 ! Bernoulli head. waves' induced surface pressure + INTEGER, PARAMETER :: jpr_tusd = 58 ! zonal stokes transport + INTEGER, PARAMETER :: jpr_tvsd = 59 ! meridional stokes tranmport + INTEGER, PARAMETER :: jpr_isf = 60 + INTEGER, PARAMETER :: jpr_icb = 61 + INTEGER, PARAMETER :: jpr_ts_ice = 62 ! Sea ice surface temp + !!INTEGER, PARAMETER :: jpr_qtrice = 63 ! Transmitted solar thru sea-ice + + INTEGER, PARAMETER :: jprcv = 62 ! total number of fields received + + INTEGER, PARAMETER :: jps_fice = 1 ! ice fraction sent to the atmosphere + INTEGER, PARAMETER :: jps_toce = 2 ! ocean temperature + INTEGER, PARAMETER :: jps_tice = 3 ! ice temperature + INTEGER, PARAMETER :: jps_tmix = 4 ! mixed temperature (ocean+ice) + INTEGER, PARAMETER :: jps_albice = 5 ! ice albedo + INTEGER, PARAMETER :: jps_albmix = 6 ! mixed albedo + INTEGER, PARAMETER :: jps_hice = 7 ! ice thickness + INTEGER, PARAMETER :: jps_hsnw = 8 ! snow thickness + INTEGER, PARAMETER :: jps_ocx1 = 9 ! ocean current on grid 1 + INTEGER, PARAMETER :: jps_ocy1 = 10 ! + INTEGER, PARAMETER :: jps_ocz1 = 11 ! + INTEGER, PARAMETER :: jps_ivx1 = 12 ! ice current on grid 1 + INTEGER, PARAMETER :: jps_ivy1 = 13 ! + INTEGER, PARAMETER :: jps_ivz1 = 14 ! + INTEGER, PARAMETER :: jps_co2 = 15 + INTEGER, PARAMETER :: jps_soce = 16 ! ocean salinity + INTEGER, PARAMETER :: jps_ssh = 17 ! sea surface height + INTEGER, PARAMETER :: jps_qsroce = 18 ! Qsr above the ocean + INTEGER, PARAMETER :: jps_qnsoce = 19 ! Qns above the ocean + INTEGER, PARAMETER :: jps_oemp = 20 ! ocean freshwater budget (evap - precip) + INTEGER, PARAMETER :: jps_sflx = 21 ! salt flux + INTEGER, PARAMETER :: jps_otx1 = 22 ! 2 atmosphere-ocean stress components on grid 1 + INTEGER, PARAMETER :: jps_oty1 = 23 ! + INTEGER, PARAMETER :: jps_rnf = 24 ! runoffs + INTEGER, PARAMETER :: jps_taum = 25 ! wind stress module + INTEGER, PARAMETER :: jps_fice2 = 26 ! ice fraction sent to OCE (by SAS when doing SAS-OCE coupling) + INTEGER, PARAMETER :: jps_e3t1st = 27 ! first level depth (vvl) + INTEGER, PARAMETER :: jps_fraqsr = 28 ! fraction of solar net radiation absorbed in the first ocean level + INTEGER, PARAMETER :: jps_ficet = 29 ! total ice fraction + INTEGER, PARAMETER :: jps_ocxw = 30 ! currents on grid 1 + INTEGER, PARAMETER :: jps_ocyw = 31 ! currents on grid 2 + INTEGER, PARAMETER :: jps_wlev = 32 ! water level + INTEGER, PARAMETER :: jps_fice1 = 33 ! first-order ice concentration (for semi-implicit coupling of atmos-ice fluxes) + INTEGER, PARAMETER :: jps_a_p = 34 ! meltpond area fraction + INTEGER, PARAMETER :: jps_ht_p = 35 ! meltpond thickness + INTEGER, PARAMETER :: jps_kice = 36 ! sea ice effective conductivity + INTEGER, PARAMETER :: jps_sstfrz = 37 ! sea surface freezing temperature + INTEGER, PARAMETER :: jps_ttilyr = 38 ! sea ice top layer temp + + INTEGER, PARAMETER :: jpsnd = 38 ! total number of fields sent + +#if ! defined key_oasis3 + ! Dummy variables to enable compilation when oasis3 is not being used + INTEGER :: OASIS_Sent = -1 + INTEGER :: OASIS_SentOut = -1 + INTEGER :: OASIS_ToRest = -1 + INTEGER :: OASIS_ToRestOut = -1 +#endif + + ! !!** namelist namsbc_cpl ** + TYPE :: FLD_C ! + CHARACTER(len = 32) :: cldes ! desciption of the coupling strategy + CHARACTER(len = 32) :: clcat ! multiple ice categories strategy + CHARACTER(len = 32) :: clvref ! reference of vector ('spherical' or 'cartesian') + CHARACTER(len = 32) :: clvor ! orientation of vector fields ('eastward-northward' or 'local grid') + CHARACTER(len = 32) :: clvgrd ! grids on which is located the vector fields + END TYPE FLD_C + ! ! Send to the atmosphere + TYPE(FLD_C) :: sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2, & + & sn_snd_thick1, sn_snd_cond, sn_snd_mpnd , sn_snd_sstfrz, sn_snd_ttilyr + ! ! Received from the atmosphere + TYPE(FLD_C) :: sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau, sn_rcv_dqnsdt, sn_rcv_qsr, & + & sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf, sn_rcv_ts_ice + TYPE(FLD_C) :: sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2, sn_rcv_mslp, sn_rcv_icb, sn_rcv_isf + ! ! Send to waves + TYPE(FLD_C) :: sn_snd_ifrac, sn_snd_crtw, sn_snd_wlev + ! ! Received from waves + TYPE(FLD_C) :: sn_rcv_hsig, sn_rcv_phioc, sn_rcv_sdrfx, sn_rcv_sdrfy, sn_rcv_wper, sn_rcv_wnum, & + & sn_rcv_wstrf, sn_rcv_wdrag, sn_rcv_charn, sn_rcv_taw, sn_rcv_bhd, sn_rcv_tusd, sn_rcv_tvsd + ! ! Other namelist parameters +!! TYPE(FLD_C) :: sn_rcv_qtrice + INTEGER :: nn_cplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data + LOGICAL :: ln_usecplmask ! use a coupling mask file to merge data received from several models + ! -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel) + LOGICAL :: ln_scale_ice_flux ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration) + + TYPE :: DYNARR + REAL(wp), POINTER, DIMENSION(:,:,:) :: z3 + END TYPE DYNARR + + TYPE( DYNARR ), SAVE, DIMENSION(jprcv) :: frcv ! all fields recieved from the atmosphere + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: alb_oce_mix ! ocean albedo sent to atmosphere (mix clear/overcast sky) +#if defined key_si3 || defined key_cice + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i_last_couple !: Ice fractional area at last coupling time +#endif + + INTEGER , ALLOCATABLE, SAVE, DIMENSION(:) :: nrcvinfo ! OASIS info argument + + !! Substitution +# include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbccpl.F90 15551 2021-11-28 20:19:36Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_cpl_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_cpl_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(4) + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! + ALLOCATE( alb_oce_mix(jpi,jpj), nrcvinfo(jprcv), STAT=ierr(1) ) + +#if ! defined key_si3 && ! defined key_cice + ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) ) ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init) +#endif + ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) ) + ! + IF( .NOT. ln_apr_dyn ) ALLOCATE( ssh_ib(jpi,jpj), ssh_ibb(jpi,jpj), apr(jpi, jpj), STAT=ierr(4) ) + + sbc_cpl_alloc = MAXVAL( ierr ) + CALL mpp_sum ( 'sbccpl', sbc_cpl_alloc ) + IF( sbc_cpl_alloc > 0 ) CALL ctl_warn('sbc_cpl_alloc: allocation of arrays failed') + ! + END FUNCTION sbc_cpl_alloc + + + SUBROUTINE sbc_cpl_init( k_ice ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_cpl_init *** + !! + !! ** Purpose : Initialisation of send and received information from + !! the atmospheric component + !! + !! ** Method : * Read namsbc_cpl namelist + !! * define the receive interface + !! * define the send interface + !! * initialise the OASIS coupler + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3) + ! + INTEGER :: jn ! dummy loop index + INTEGER :: ios, inum ! Local integer + REAL(wp), DIMENSION(jpi,jpj) :: zacs, zaos + !! + NAMELIST/namsbc_cpl/ nn_cplmodel , ln_usecplmask, nn_cats_cpl , ln_scale_ice_flux, & + & sn_snd_temp , sn_snd_alb , sn_snd_thick, sn_snd_crt , sn_snd_co2 , & + & sn_snd_ttilyr, sn_snd_cond , sn_snd_mpnd , sn_snd_sstfrz, sn_snd_thick1, & + & sn_snd_ifrac , sn_snd_crtw , sn_snd_wlev , sn_rcv_hsig , sn_rcv_phioc , & + & sn_rcv_w10m , sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr , & + & sn_rcv_sdrfx , sn_rcv_sdrfy , sn_rcv_wper , sn_rcv_wnum , sn_rcv_wstrf , & + & sn_rcv_charn , sn_rcv_taw , sn_rcv_bhd , sn_rcv_tusd , sn_rcv_tvsd, & + & sn_rcv_wdrag , sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , & + & sn_rcv_iceflx, sn_rcv_co2 , sn_rcv_icb , sn_rcv_isf , sn_rcv_ts_ice, & !!, sn_rcv_qtrice + & sn_rcv_mslp + + !!--------------------------------------------------------------------- + ! + ! ================================ ! + ! Namelist informations ! + ! ================================ ! + ! + READ ( numnam_ref, namsbc_cpl, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in reference namelist' ) + ! + READ ( numnam_cfg, namsbc_cpl, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_cpl ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*)'sbc_cpl_init : namsbc_cpl namelist ' + WRITE(numout,*)'~~~~~~~~~~~~' + ENDIF + IF( lwp .AND. ln_cpl ) THEN ! control print + WRITE(numout,*)' nn_cplmodel = ', nn_cplmodel + WRITE(numout,*)' ln_usecplmask = ', ln_usecplmask + WRITE(numout,*)' ln_scale_ice_flux = ', ln_scale_ice_flux + WRITE(numout,*)' nn_cats_cpl = ', nn_cats_cpl + WRITE(numout,*)' received fields (mutiple ice categogies)' + WRITE(numout,*)' 10m wind module = ', TRIM(sn_rcv_w10m%cldes ), ' (', TRIM(sn_rcv_w10m%clcat ), ')' + WRITE(numout,*)' stress module = ', TRIM(sn_rcv_taumod%cldes), ' (', TRIM(sn_rcv_taumod%clcat), ')' + WRITE(numout,*)' surface stress = ', TRIM(sn_rcv_tau%cldes ), ' (', TRIM(sn_rcv_tau%clcat ), ')' + WRITE(numout,*)' - referential = ', sn_rcv_tau%clvref + WRITE(numout,*)' - orientation = ', sn_rcv_tau%clvor + WRITE(numout,*)' - mesh = ', sn_rcv_tau%clvgrd + WRITE(numout,*)' non-solar heat flux sensitivity = ', TRIM(sn_rcv_dqnsdt%cldes), ' (', TRIM(sn_rcv_dqnsdt%clcat), ')' + WRITE(numout,*)' solar heat flux = ', TRIM(sn_rcv_qsr%cldes ), ' (', TRIM(sn_rcv_qsr%clcat ), ')' + WRITE(numout,*)' non-solar heat flux = ', TRIM(sn_rcv_qns%cldes ), ' (', TRIM(sn_rcv_qns%clcat ), ')' + WRITE(numout,*)' freshwater budget = ', TRIM(sn_rcv_emp%cldes ), ' (', TRIM(sn_rcv_emp%clcat ), ')' + WRITE(numout,*)' runoffs = ', TRIM(sn_rcv_rnf%cldes ), ' (', TRIM(sn_rcv_rnf%clcat ), ')' + WRITE(numout,*)' calving = ', TRIM(sn_rcv_cal%cldes ), ' (', TRIM(sn_rcv_cal%clcat ), ')' + WRITE(numout,*)' iceberg = ', TRIM(sn_rcv_icb%cldes ), ' (', TRIM(sn_rcv_icb%clcat ), ')' + WRITE(numout,*)' ice shelf = ', TRIM(sn_rcv_isf%cldes ), ' (', TRIM(sn_rcv_isf%clcat ), ')' + WRITE(numout,*)' sea ice heat fluxes = ', TRIM(sn_rcv_iceflx%cldes), ' (', TRIM(sn_rcv_iceflx%clcat), ')' +!! WRITE(numout,*)' transmitted solar thru sea-ice = ', TRIM(sn_rcv_qtrice%cldes), ' (', TRIM(sn_rcv_qtrice%clcat), ')' + WRITE(numout,*)' atm co2 = ', TRIM(sn_rcv_co2%cldes ), ' (', TRIM(sn_rcv_co2%clcat ), ')' + WRITE(numout,*)' Sea ice surface skin temperature= ', TRIM(sn_rcv_ts_ice%cldes), ' (', TRIM(sn_rcv_ts_ice%clcat), ')' + WRITE(numout,*)' surface waves:' + WRITE(numout,*)' significant wave heigth = ', TRIM(sn_rcv_hsig%cldes ), ' (', TRIM(sn_rcv_hsig%clcat ), ')' + WRITE(numout,*)' wave to oce energy flux = ', TRIM(sn_rcv_phioc%cldes ), ' (', TRIM(sn_rcv_phioc%clcat ), ')' + WRITE(numout,*)' Surface Stokes drift grid u = ', TRIM(sn_rcv_sdrfx%cldes ), ' (', TRIM(sn_rcv_sdrfx%clcat ), ')' + WRITE(numout,*)' Surface Stokes drift grid v = ', TRIM(sn_rcv_sdrfy%cldes ), ' (', TRIM(sn_rcv_sdrfy%clcat ), ')' + WRITE(numout,*)' Mean wave period = ', TRIM(sn_rcv_wper%cldes ), ' (', TRIM(sn_rcv_wper%clcat ), ')' + WRITE(numout,*)' Mean wave number = ', TRIM(sn_rcv_wnum%cldes ), ' (', TRIM(sn_rcv_wnum%clcat ), ')' + WRITE(numout,*)' Stress frac adsorbed by waves = ', TRIM(sn_rcv_wstrf%cldes ), ' (', TRIM(sn_rcv_wstrf%clcat ), ')' + WRITE(numout,*)' Neutral surf drag coefficient = ', TRIM(sn_rcv_wdrag%cldes ), ' (', TRIM(sn_rcv_wdrag%clcat ), ')' + WRITE(numout,*)' Charnock coefficient = ', TRIM(sn_rcv_charn%cldes ), ' (', TRIM(sn_rcv_charn%clcat ), ')' + WRITE(numout,*)' sent fields (multiple ice categories)' + WRITE(numout,*)' surface temperature = ', TRIM(sn_snd_temp%cldes ), ' (', TRIM(sn_snd_temp%clcat ), ')' + WRITE(numout,*)' top ice layer temperature = ', TRIM(sn_snd_ttilyr%cldes), ' (', TRIM(sn_snd_ttilyr%clcat), ')' + WRITE(numout,*)' albedo = ', TRIM(sn_snd_alb%cldes ), ' (', TRIM(sn_snd_alb%clcat ), ')' + WRITE(numout,*)' ice/snow thickness = ', TRIM(sn_snd_thick%cldes ), ' (', TRIM(sn_snd_thick%clcat ), ')' + WRITE(numout,*)' total ice fraction = ', TRIM(sn_snd_ifrac%cldes ), ' (', TRIM(sn_snd_ifrac%clcat ), ')' + WRITE(numout,*)' surface current = ', TRIM(sn_snd_crt%cldes ), ' (', TRIM(sn_snd_crt%clcat ), ')' + WRITE(numout,*)' - referential = ', sn_snd_crt%clvref + WRITE(numout,*)' - orientation = ', sn_snd_crt%clvor + WRITE(numout,*)' - mesh = ', sn_snd_crt%clvgrd + WRITE(numout,*)' oce co2 flux = ', TRIM(sn_snd_co2%cldes ), ' (', TRIM(sn_snd_co2%clcat ), ')' + WRITE(numout,*)' ice effective conductivity = ', TRIM(sn_snd_cond%cldes ), ' (', TRIM(sn_snd_cond%clcat ), ')' + WRITE(numout,*)' meltponds fraction and depth = ', TRIM(sn_snd_mpnd%cldes ), ' (', TRIM(sn_snd_mpnd%clcat ), ')' + WRITE(numout,*)' sea surface freezing temp = ', TRIM(sn_snd_sstfrz%cldes), ' (', TRIM(sn_snd_sstfrz%clcat), ')' + WRITE(numout,*)' water level = ', TRIM(sn_snd_wlev%cldes ), ' (', TRIM(sn_snd_wlev%clcat ), ')' + WRITE(numout,*)' mean sea level pressure = ', TRIM(sn_rcv_mslp%cldes ), ' (', TRIM(sn_rcv_mslp%clcat ), ')' + WRITE(numout,*)' surface current to waves = ', TRIM(sn_snd_crtw%cldes ), ' (', TRIM(sn_snd_crtw%clcat ), ')' + WRITE(numout,*)' - referential = ', sn_snd_crtw%clvref + WRITE(numout,*)' - orientation = ', sn_snd_crtw%clvor + WRITE(numout,*)' - mesh = ', sn_snd_crtw%clvgrd + ENDIF + IF( lwp .AND. ln_wave) THEN ! control print + WRITE(numout,*)' surface waves:' + WRITE(numout,*)' Significant wave heigth = ', TRIM(sn_rcv_hsig%cldes ), ' (', TRIM(sn_rcv_hsig%clcat ), ')' + WRITE(numout,*)' Wave to oce energy flux = ', TRIM(sn_rcv_phioc%cldes ), ' (', TRIM(sn_rcv_phioc%clcat ), ')' + WRITE(numout,*)' Surface Stokes drift grid u = ', TRIM(sn_rcv_sdrfx%cldes ), ' (', TRIM(sn_rcv_sdrfx%clcat ), ')' + WRITE(numout,*)' Surface Stokes drift grid v = ', TRIM(sn_rcv_sdrfy%cldes ), ' (', TRIM(sn_rcv_sdrfy%clcat ), ')' + WRITE(numout,*)' Mean wave period = ', TRIM(sn_rcv_wper%cldes ), ' (', TRIM(sn_rcv_wper%clcat ), ')' + WRITE(numout,*)' Mean wave number = ', TRIM(sn_rcv_wnum%cldes ), ' (', TRIM(sn_rcv_wnum%clcat ), ')' + WRITE(numout,*)' Stress frac adsorbed by waves = ', TRIM(sn_rcv_wstrf%cldes ), ' (', TRIM(sn_rcv_wstrf%clcat ), ')' + WRITE(numout,*)' Neutral surf drag coefficient = ', TRIM(sn_rcv_wdrag%cldes ), ' (', TRIM(sn_rcv_wdrag%clcat ), ')' + WRITE(numout,*)' Charnock coefficient = ', TRIM(sn_rcv_charn%cldes ), ' (', TRIM(sn_rcv_charn%clcat ), ')' + WRITE(numout,*)' Transport associated to Stokes drift grid u = ', TRIM(sn_rcv_tusd%cldes ), ' (', TRIM(sn_rcv_tusd%clcat ), ')' + WRITE(numout,*)' Transport associated to Stokes drift grid v = ', TRIM(sn_rcv_tvsd%cldes ), ' (', TRIM(sn_rcv_tvsd%clcat ), ')' + WRITE(numout,*)' Bernouilli pressure head = ', TRIM(sn_rcv_bhd%cldes ), ' (', TRIM(sn_rcv_bhd%clcat ), ')' + WRITE(numout,*)'Wave to ocean momentum flux and Net wave-supported stress = ', TRIM(sn_rcv_taw%cldes ), ' (', TRIM(sn_rcv_taw%clcat ), ')' + WRITE(numout,*)' Surface current to waves = ', TRIM(sn_snd_crtw%cldes ), ' (', TRIM(sn_snd_crtw%clcat ), ')' + WRITE(numout,*)' - referential = ', sn_snd_crtw%clvref + WRITE(numout,*)' - orientation = ', sn_snd_crtw%clvor + WRITE(numout,*)' - mesh = ', sn_snd_crtw%clvgrd + ENDIF + ! ! allocate sbccpl arrays + IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' ) + + ! ================================ ! + ! Define the receive interface ! + ! ================================ ! + nrcvinfo(:) = OASIS_idle ! needed by nrcvinfo(jpr_otx1) if we do not receive ocean stress + + ! for each field: define the OASIS name (srcv(:)%clname) + ! define receive or not from the namelist parameters (srcv(:)%laction) + ! define the north fold type of lbc (srcv(:)%nsgn) + + ! default definitions of srcv + srcv(:)%laction = .FALSE. ; srcv(:)%clgrid = 'T' ; srcv(:)%nsgn = 1. ; srcv(:)%nct = 1 + + ! ! ------------------------- ! + ! ! ice and ocean wind stress ! + ! ! ------------------------- ! + ! ! Name + srcv(jpr_otx1)%clname = 'O_OTaux1' ! 1st ocean component on grid ONE (T or U) + srcv(jpr_oty1)%clname = 'O_OTauy1' ! 2nd - - - - + srcv(jpr_otz1)%clname = 'O_OTauz1' ! 3rd - - - - + srcv(jpr_otx2)%clname = 'O_OTaux2' ! 1st ocean component on grid TWO (V) + srcv(jpr_oty2)%clname = 'O_OTauy2' ! 2nd - - - - + srcv(jpr_otz2)%clname = 'O_OTauz2' ! 3rd - - - - + ! + srcv(jpr_itx1)%clname = 'O_ITaux1' ! 1st ice component on grid ONE (T, F, I or U) + srcv(jpr_ity1)%clname = 'O_ITauy1' ! 2nd - - - - + srcv(jpr_itz1)%clname = 'O_ITauz1' ! 3rd - - - - + srcv(jpr_itx2)%clname = 'O_ITaux2' ! 1st ice component on grid TWO (V) + srcv(jpr_ity2)%clname = 'O_ITauy2' ! 2nd - - - - + srcv(jpr_itz2)%clname = 'O_ITauz2' ! 3rd - - - - + ! + ! Vectors: change of sign at north fold ONLY if on the local grid + IF( TRIM( sn_rcv_tau%cldes ) == 'oce only' .OR. TRIM( sn_rcv_tau%cldes ) == 'oce and ice' & + .OR. TRIM( sn_rcv_tau%cldes ) == 'mixed oce-ice' ) THEN ! avoid working with the atmospheric fields if they are not coupled + ! + IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) srcv(jpr_otx1:jpr_itz2)%nsgn = -1. + + ! ! Set grid and action + SELECT CASE( TRIM( sn_rcv_tau%clvgrd ) ) ! 'T', 'U,V', 'U,V,I', 'U,V,F', 'T,I', 'T,F', or 'T,U,V' + CASE( 'T' ) + srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point + srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 + srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 + CASE( 'U,V' ) + srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point + srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point + srcv(jpr_itx1:jpr_itz1)%clgrid = 'U' ! ice components given at U-point + srcv(jpr_itx2:jpr_itz2)%clgrid = 'V' ! and V-point + srcv(jpr_otx1:jpr_itz2)%laction = .TRUE. ! receive oce and ice components on both grid 1 & 2 + CASE( 'U,V,T' ) + srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point + srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point + srcv(jpr_itx1:jpr_itz1)%clgrid = 'T' ! ice components given at T-point + srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2 + srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only + CASE( 'U,V,I' ) + srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point + srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point + srcv(jpr_itx1:jpr_itz1)%clgrid = 'I' ! ice components given at I-point + srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2 + srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only + CASE( 'U,V,F' ) + srcv(jpr_otx1:jpr_otz1)%clgrid = 'U' ! oce components given at U-point + srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point + srcv(jpr_itx1:jpr_itz1)%clgrid = 'F' ! ice components given at F-point + srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2 + srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only + CASE( 'T,I' ) + srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point + srcv(jpr_itx1:jpr_itz1)%clgrid = 'I' ! ice components given at I-point + srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 + srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 + CASE( 'T,F' ) + srcv(jpr_otx1:jpr_itz2)%clgrid = 'T' ! oce and ice components given at T-point + srcv(jpr_itx1:jpr_itz1)%clgrid = 'F' ! ice components given at F-point + srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 + srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 + CASE( 'T,U,V' ) + srcv(jpr_otx1:jpr_otz1)%clgrid = 'T' ! oce components given at T-point + srcv(jpr_itx1:jpr_itz1)%clgrid = 'U' ! ice components given at U-point + srcv(jpr_itx2:jpr_itz2)%clgrid = 'V' ! and V-point + srcv(jpr_otx1:jpr_otz1)%laction = .TRUE. ! receive oce components on grid 1 only + srcv(jpr_itx1:jpr_itz2)%laction = .TRUE. ! receive ice components on grid 1 & 2 + CASE default + CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_tau%clvgrd' ) + END SELECT + ! + IF( TRIM( sn_rcv_tau%clvref ) == 'spherical' ) & ! spherical: 3rd component not received + & srcv( (/jpr_otz1, jpr_otz2, jpr_itz1, jpr_itz2/) )%laction = .FALSE. + ! + IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' ) THEN ! already on local grid -> no need of the second grid + srcv(jpr_otx2:jpr_otz2)%laction = .FALSE. + srcv(jpr_itx2:jpr_itz2)%laction = .FALSE. + srcv(jpr_oty1)%clgrid = srcv(jpr_oty2)%clgrid ! not needed but cleaner... + srcv(jpr_ity1)%clgrid = srcv(jpr_ity2)%clgrid ! not needed but cleaner... + ENDIF + ! + IF( TRIM( sn_rcv_tau%cldes ) /= 'oce and ice' ) THEN ! 'oce and ice' case ocean stress on ocean mesh used + srcv(jpr_itx1:jpr_itz2)%laction = .FALSE. ! ice components not received + srcv(jpr_itx1)%clgrid = 'U' ! ocean stress used after its transformation + srcv(jpr_ity1)%clgrid = 'V' ! i.e. it is always at U- & V-points for i- & j-comp. resp. + ENDIF + ENDIF + + ! ! ------------------------- ! + ! ! freshwater budget ! E-P + ! ! ------------------------- ! + ! we suppose that atmosphere modele do not make the difference between precipiration (liquide or solid) + ! over ice of free ocean within the same atmospheric cell.cd + srcv(jpr_rain)%clname = 'OTotRain' ! Rain = liquid precipitation + srcv(jpr_snow)%clname = 'OTotSnow' ! Snow = solid precipitation + srcv(jpr_tevp)%clname = 'OTotEvap' ! total evaporation (over oce + ice sublimation) + srcv(jpr_ievp)%clname = 'OIceEvap' ! evaporation over ice = sublimation + srcv(jpr_sbpr)%clname = 'OSubMPre' ! sublimation - liquid precipitation - solid precipitation + srcv(jpr_semp)%clname = 'OISubMSn' ! ice solid water budget = sublimation - solid precipitation + srcv(jpr_oemp)%clname = 'OOEvaMPr' ! ocean water budget = ocean Evap - ocean precip + SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) + CASE( 'none' ) ! nothing to do + CASE( 'oce only' ) ; srcv(jpr_oemp)%laction = .TRUE. + CASE( 'conservative' ) + srcv( (/jpr_rain, jpr_snow, jpr_ievp, jpr_tevp/) )%laction = .TRUE. + IF( k_ice <= 1 ) srcv(jpr_ievp)%laction = .FALSE. + CASE( 'oce and ice' ) ; srcv( (/jpr_ievp, jpr_sbpr, jpr_semp, jpr_oemp/) )%laction = .TRUE. + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_emp%cldes' ) + END SELECT + ! + ! ! ------------------------- ! + ! ! Runoffs & Calving ! + ! ! ------------------------- ! + srcv(jpr_rnf )%clname = 'O_Runoff' + IF( TRIM( sn_rcv_rnf%cldes ) == 'coupled' ) THEN + srcv(jpr_rnf)%laction = .TRUE. + l_rnfcpl = .TRUE. ! -> no need to read runoffs in sbcrnf + ln_rnf = nn_components /= jp_iam_sas ! -> force to go through sbcrnf if not sas + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' runoffs received from oasis -> force ln_rnf = ', ln_rnf + ENDIF + ! + srcv(jpr_cal)%clname = 'OCalving' ; IF( TRIM( sn_rcv_cal%cldes) == 'coupled' ) srcv(jpr_cal)%laction = .TRUE. + srcv(jpr_isf)%clname = 'OIcshelf' ; IF( TRIM( sn_rcv_isf%cldes) == 'coupled' ) srcv(jpr_isf)%laction = .TRUE. + srcv(jpr_icb)%clname = 'OIceberg' ; IF( TRIM( sn_rcv_icb%cldes) == 'coupled' ) srcv(jpr_icb)%laction = .TRUE. + + IF( srcv(jpr_isf)%laction ) THEN + l_isfoasis = .TRUE. ! -> isf fwf comes from oasis + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' iceshelf received from oasis ' + ENDIF + ! + ! + ! ! ------------------------- ! + ! ! non solar radiation ! Qns + ! ! ------------------------- ! + srcv(jpr_qnsoce)%clname = 'O_QnsOce' + srcv(jpr_qnsice)%clname = 'O_QnsIce' + srcv(jpr_qnsmix)%clname = 'O_QnsMix' + SELECT CASE( TRIM( sn_rcv_qns%cldes ) ) + CASE( 'none' ) ! nothing to do + CASE( 'oce only' ) ; srcv( jpr_qnsoce )%laction = .TRUE. + CASE( 'conservative' ) ; srcv( (/jpr_qnsice, jpr_qnsmix/) )%laction = .TRUE. + CASE( 'oce and ice' ) ; srcv( (/jpr_qnsice, jpr_qnsoce/) )%laction = .TRUE. + CASE( 'mixed oce-ice' ) ; srcv( jpr_qnsmix )%laction = .TRUE. + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_qns%cldes' ) + END SELECT + IF( TRIM( sn_rcv_qns%cldes ) == 'mixed oce-ice' .AND. nn_cats_cpl > 1 ) & + CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qns%cldes not currently allowed to be mixed oce-ice for multi-category ice' ) + ! + ! ! ------------------------- ! + ! ! solar radiation ! Qsr + ! ! ------------------------- ! + srcv(jpr_qsroce)%clname = 'O_QsrOce' + srcv(jpr_qsrice)%clname = 'O_QsrIce' + srcv(jpr_qsrmix)%clname = 'O_QsrMix' + SELECT CASE( TRIM( sn_rcv_qsr%cldes ) ) + CASE( 'none' ) ! nothing to do + CASE( 'oce only' ) ; srcv( jpr_qsroce )%laction = .TRUE. + CASE( 'conservative' ) ; srcv( (/jpr_qsrice, jpr_qsrmix/) )%laction = .TRUE. + CASE( 'oce and ice' ) ; srcv( (/jpr_qsrice, jpr_qsroce/) )%laction = .TRUE. + CASE( 'mixed oce-ice' ) ; srcv( jpr_qsrmix )%laction = .TRUE. + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_rcv_qsr%cldes' ) + END SELECT + IF( TRIM( sn_rcv_qsr%cldes ) == 'mixed oce-ice' .AND. nn_cats_cpl > 1 ) & + CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qsr%cldes not currently allowed to be mixed oce-ice for multi-category ice' ) + ! + ! ! ------------------------- ! + ! ! non solar sensitivity ! d(Qns)/d(T) + ! ! ------------------------- ! + srcv(jpr_dqnsdt)%clname = 'O_dQnsdT' + IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'coupled' ) srcv(jpr_dqnsdt)%laction = .TRUE. + ! + ! non solar sensitivity mandatory for mixed oce-ice solar radiation coupling technique + IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. TRIM( sn_rcv_qns%cldes ) == 'mixed oce-ice' ) & + & CALL ctl_stop( 'sbc_cpl_init: namsbc_cpl namelist mismatch between sn_rcv_qns%cldes and sn_rcv_dqnsdt%cldes' ) + ! + ! ! ------------------------- ! + ! ! 10m wind module ! + ! ! ------------------------- ! + srcv(jpr_w10m)%clname = 'O_Wind10' ; IF( TRIM(sn_rcv_w10m%cldes ) == 'coupled' ) srcv(jpr_w10m)%laction = .TRUE. + ! + ! ! ------------------------- ! + ! ! wind stress module ! + ! ! ------------------------- ! + srcv(jpr_taum)%clname = 'O_TauMod' ; IF( TRIM(sn_rcv_taumod%cldes) == 'coupled' ) srcv(jpr_taum)%laction = .TRUE. + ! + ! ! ------------------------- ! + ! ! Atmospheric CO2 ! + ! ! ------------------------- ! + srcv(jpr_co2 )%clname = 'O_AtmCO2' + IF( TRIM(sn_rcv_co2%cldes ) == 'coupled' ) THEN + srcv(jpr_co2 )%laction = .TRUE. + l_co2cpl = .TRUE. + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Atmospheric pco2 received from oasis ' + IF(lwp) WRITE(numout,*) + ENDIF + ! + ! ! ------------------------- ! + ! ! Mean Sea Level Pressure ! + ! ! ------------------------- ! + srcv(jpr_mslp)%clname = 'O_MSLP' ; IF( TRIM(sn_rcv_mslp%cldes ) == 'coupled' ) srcv(jpr_mslp)%laction = .TRUE. + ! + ! ! --------------------------------- ! + ! ! ice topmelt and conduction flux ! + ! ! --------------------------------- ! + srcv(jpr_topm )%clname = 'OTopMlt' + srcv(jpr_botm )%clname = 'OBotMlt' + IF( TRIM(sn_rcv_iceflx%cldes) == 'coupled' ) THEN + IF( TRIM( sn_rcv_iceflx%clcat ) == 'yes' ) THEN + srcv(jpr_topm:jpr_botm)%nct = nn_cats_cpl + ELSE + CALL ctl_stop( 'sbc_cpl_init: sn_rcv_iceflx%clcat should always be set to yes currently' ) + ENDIF + srcv(jpr_topm:jpr_botm)%laction = .TRUE. + ENDIF +!! ! ! --------------------------- ! +!! ! ! transmitted solar thru ice ! +!! ! ! --------------------------- ! +!! srcv(jpr_qtrice)%clname = 'OQtr' +!! IF( TRIM(sn_rcv_qtrice%cldes) == 'coupled' ) THEN +!! IF ( TRIM( sn_rcv_qtrice%clcat ) == 'yes' ) THEN +!! srcv(jpr_qtrice)%nct = nn_cats_cpl +!! ELSE +!! CALL ctl_stop( 'sbc_cpl_init: sn_rcv_qtrice%clcat should always be set to yes currently' ) +!! ENDIF +!! srcv(jpr_qtrice)%laction = .TRUE. +!! ENDIF + ! ! ------------------------- ! + ! ! ice skin temperature ! + ! ! ------------------------- ! + srcv(jpr_ts_ice)%clname = 'OTsfIce' ! needed by Met Office + IF( TRIM( sn_rcv_ts_ice%cldes ) == 'ice' ) srcv(jpr_ts_ice)%laction = .TRUE. + IF( TRIM( sn_rcv_ts_ice%clcat ) == 'yes' ) srcv(jpr_ts_ice)%nct = nn_cats_cpl + IF( TRIM( sn_rcv_emp%clcat ) == 'yes' ) srcv(jpr_ievp)%nct = nn_cats_cpl + +#if defined key_si3 + IF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN + IF( .NOT.srcv(jpr_ts_ice)%laction ) & + & CALL ctl_stop( 'sbc_cpl_init: srcv(jpr_ts_ice)%laction should be set to true when ln_cndflx=T' ) + ENDIF +#endif + ! ! ------------------------- ! + ! ! Wave breaking ! + ! ! ------------------------- ! + srcv(jpr_hsig)%clname = 'O_Hsigwa' ! significant wave height + IF( TRIM(sn_rcv_hsig%cldes ) == 'coupled' ) THEN + srcv(jpr_hsig)%laction = .TRUE. + cpl_hsig = .TRUE. + ENDIF + srcv(jpr_phioc)%clname = 'O_PhiOce' ! wave to ocean energy + IF( TRIM(sn_rcv_phioc%cldes ) == 'coupled' ) THEN + srcv(jpr_phioc)%laction = .TRUE. + cpl_phioc = .TRUE. + ENDIF + srcv(jpr_sdrftx)%clname = 'O_Sdrfx' ! Stokes drift in the u direction + IF( TRIM(sn_rcv_sdrfx%cldes ) == 'coupled' ) THEN + srcv(jpr_sdrftx)%laction = .TRUE. + cpl_sdrftx = .TRUE. + ENDIF + srcv(jpr_sdrfty)%clname = 'O_Sdrfy' ! Stokes drift in the v direction + IF( TRIM(sn_rcv_sdrfy%cldes ) == 'coupled' ) THEN + srcv(jpr_sdrfty)%laction = .TRUE. + cpl_sdrfty = .TRUE. + ENDIF + srcv(jpr_wper)%clname = 'O_WPer' ! mean wave period + IF( TRIM(sn_rcv_wper%cldes ) == 'coupled' ) THEN + srcv(jpr_wper)%laction = .TRUE. + cpl_wper = .TRUE. + ENDIF + srcv(jpr_wnum)%clname = 'O_WNum' ! mean wave number + IF( TRIM(sn_rcv_wnum%cldes ) == 'coupled' ) THEN + srcv(jpr_wnum)%laction = .TRUE. + cpl_wnum = .TRUE. + ENDIF + srcv(jpr_wstrf)%clname = 'O_WStrf' ! stress fraction adsorbed by the wave + IF( TRIM(sn_rcv_wstrf%cldes ) == 'coupled' ) THEN + srcv(jpr_wstrf)%laction = .TRUE. + cpl_wstrf = .TRUE. + ENDIF + srcv(jpr_wdrag)%clname = 'O_WDrag' ! neutral surface drag coefficient + IF( TRIM(sn_rcv_wdrag%cldes ) == 'coupled' ) THEN + srcv(jpr_wdrag)%laction = .TRUE. + cpl_wdrag = .TRUE. + ENDIF + srcv(jpr_charn)%clname = 'O_Charn' ! Chranock coefficient + IF( TRIM(sn_rcv_charn%cldes ) == 'coupled' ) THEN + srcv(jpr_charn)%laction = .TRUE. + cpl_charn = .TRUE. + ENDIF + srcv(jpr_bhd)%clname = 'O_Bhd' ! Bernoulli head. waves' induced surface pressure + IF( TRIM(sn_rcv_bhd%cldes ) == 'coupled' ) THEN + srcv(jpr_bhd)%laction = .TRUE. + cpl_bhd = .TRUE. + ENDIF + srcv(jpr_tusd)%clname = 'O_Tusd' ! zonal stokes transport + IF( TRIM(sn_rcv_tusd%cldes ) == 'coupled' ) THEN + srcv(jpr_tusd)%laction = .TRUE. + cpl_tusd = .TRUE. + ENDIF + srcv(jpr_tvsd)%clname = 'O_Tvsd' ! meridional stokes tranmport + IF( TRIM(sn_rcv_tvsd%cldes ) == 'coupled' ) THEN + srcv(jpr_tvsd)%laction = .TRUE. + cpl_tvsd = .TRUE. + ENDIF + + srcv(jpr_twox)%clname = 'O_Twox' ! wave to ocean momentum flux in the u direction + srcv(jpr_twoy)%clname = 'O_Twoy' ! wave to ocean momentum flux in the v direction + srcv(jpr_tawx)%clname = 'O_Tawx' ! Net wave-supported stress in the u direction + srcv(jpr_tawy)%clname = 'O_Tawy' ! Net wave-supported stress in the v direction + IF( TRIM(sn_rcv_taw%cldes ) == 'coupled' ) THEN + srcv(jpr_twox)%laction = .TRUE. + srcv(jpr_twoy)%laction = .TRUE. + srcv(jpr_tawx)%laction = .TRUE. + srcv(jpr_tawy)%laction = .TRUE. + cpl_taw = .TRUE. + ENDIF + ! + ! ! ------------------------------- ! + ! ! OCE-SAS coupling - rcv by opa ! + ! ! ------------------------------- ! + srcv(jpr_sflx)%clname = 'O_SFLX' + srcv(jpr_fice)%clname = 'RIceFrc' + ! + IF( nn_components == jp_iam_oce ) THEN ! OCE coupled to SAS via OASIS: force received field by OCE (sent by SAS) + srcv(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling + srcv(:)%clgrid = 'T' ! force default definition in case of opa <-> sas coupling + srcv(:)%nsgn = 1. ! force default definition in case of opa <-> sas coupling + srcv( (/jpr_qsroce, jpr_qnsoce, jpr_oemp, jpr_sflx, jpr_fice, jpr_otx1, jpr_oty1, jpr_taum/) )%laction = .TRUE. + srcv(jpr_otx1)%clgrid = 'U' ! oce components given at U-point + srcv(jpr_oty1)%clgrid = 'V' ! and V-point + ! Vectors: change of sign at north fold ONLY if on the local grid + srcv( (/jpr_otx1,jpr_oty1/) )%nsgn = -1. + sn_rcv_tau%clvgrd = 'U,V' + sn_rcv_tau%clvor = 'local grid' + sn_rcv_tau%clvref = 'spherical' + sn_rcv_emp%cldes = 'oce only' + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*)' Special conditions for SAS-OCE coupling ' + WRITE(numout,*)' OCE component ' + WRITE(numout,*) + WRITE(numout,*)' received fields from SAS component ' + WRITE(numout,*)' ice cover ' + WRITE(numout,*)' oce only EMP ' + WRITE(numout,*)' salt flux ' + WRITE(numout,*)' mixed oce-ice solar flux ' + WRITE(numout,*)' mixed oce-ice non solar flux ' + WRITE(numout,*)' wind stress U,V on local grid and sperical coordinates ' + WRITE(numout,*)' wind stress module' + WRITE(numout,*) + ENDIF + ENDIF + ! ! -------------------------------- ! + ! ! OCE-SAS coupling - rcv by sas ! + ! ! -------------------------------- ! + srcv(jpr_toce )%clname = 'I_SSTSST' + srcv(jpr_soce )%clname = 'I_SSSal' + srcv(jpr_ocx1 )%clname = 'I_OCurx1' + srcv(jpr_ocy1 )%clname = 'I_OCury1' + srcv(jpr_ssh )%clname = 'I_SSHght' + srcv(jpr_e3t1st)%clname = 'I_E3T1st' + srcv(jpr_fraqsr)%clname = 'I_FraQsr' + ! + IF( nn_components == jp_iam_sas ) THEN + IF( .NOT. ln_cpl ) srcv(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling + IF( .NOT. ln_cpl ) srcv(:)%clgrid = 'T' ! force default definition in case of opa <-> sas coupling + IF( .NOT. ln_cpl ) srcv(:)%nsgn = 1. ! force default definition in case of opa <-> sas coupling + srcv( (/jpr_toce, jpr_soce, jpr_ssh, jpr_fraqsr, jpr_ocx1, jpr_ocy1/) )%laction = .TRUE. + srcv( jpr_e3t1st )%laction = .NOT.ln_linssh + srcv(jpr_ocx1)%clgrid = 'U' ! oce components given at U-point + srcv(jpr_ocy1)%clgrid = 'V' ! and V-point + ! Vectors: change of sign at north fold ONLY if on the local grid + srcv(jpr_ocx1:jpr_ocy1)%nsgn = -1. + ! Change first letter to couple with atmosphere if already coupled OCE + ! this is nedeed as each variable name used in the namcouple must be unique: + ! for example O_Runoff received by OCE from SAS and therefore S_Runoff received by SAS from the Atmosphere + DO jn = 1, jprcv + IF( srcv(jn)%clname(1:1) == "O" ) srcv(jn)%clname = "S"//srcv(jn)%clname(2:LEN(srcv(jn)%clname)) + END DO + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*)' Special conditions for SAS-OCE coupling ' + WRITE(numout,*)' SAS component ' + WRITE(numout,*) + IF( .NOT. ln_cpl ) THEN + WRITE(numout,*)' received fields from OCE component ' + ELSE + WRITE(numout,*)' Additional received fields from OCE component : ' + ENDIF + WRITE(numout,*)' sea surface temperature (Celsius) ' + WRITE(numout,*)' sea surface salinity ' + WRITE(numout,*)' surface currents ' + WRITE(numout,*)' sea surface height ' + WRITE(numout,*)' thickness of first ocean T level ' + WRITE(numout,*)' fraction of solar net radiation absorbed in the first ocean level' + WRITE(numout,*) + ENDIF + ENDIF + + ! =================================================== ! + ! Allocate all parts of frcv used for received fields ! + ! =================================================== ! + DO jn = 1, jprcv + IF( srcv(jn)%laction ) ALLOCATE( frcv(jn)%z3(jpi,jpj,srcv(jn)%nct) ) + END DO + ! Allocate taum part of frcv which is used even when not received as coupling field + IF( .NOT. srcv(jpr_taum)%laction ) ALLOCATE( frcv(jpr_taum)%z3(jpi,jpj,srcv(jpr_taum)%nct) ) + ! Allocate w10m part of frcv which is used even when not received as coupling field + IF( .NOT. srcv(jpr_w10m)%laction ) ALLOCATE( frcv(jpr_w10m)%z3(jpi,jpj,srcv(jpr_w10m)%nct) ) + ! Allocate jpr_otx1 part of frcv which is used even when not received as coupling field + IF( .NOT. srcv(jpr_otx1)%laction ) ALLOCATE( frcv(jpr_otx1)%z3(jpi,jpj,srcv(jpr_otx1)%nct) ) + IF( .NOT. srcv(jpr_oty1)%laction ) ALLOCATE( frcv(jpr_oty1)%z3(jpi,jpj,srcv(jpr_oty1)%nct) ) + ! Allocate itx1 and ity1 as they are used in sbc_cpl_ice_tau even if srcv(jpr_itx1)%laction = .FALSE. + IF( k_ice /= 0 ) THEN + IF( .NOT. srcv(jpr_itx1)%laction ) ALLOCATE( frcv(jpr_itx1)%z3(jpi,jpj,srcv(jpr_itx1)%nct) ) + IF( .NOT. srcv(jpr_ity1)%laction ) ALLOCATE( frcv(jpr_ity1)%z3(jpi,jpj,srcv(jpr_ity1)%nct) ) + ENDIF + + ! ================================ ! + ! Define the send interface ! + ! ================================ ! + ! for each field: define the OASIS name (ssnd(:)%clname) + ! define send or not from the namelist parameters (ssnd(:)%laction) + ! define the north fold type of lbc (ssnd(:)%nsgn) + + ! default definitions of nsnd + ssnd(:)%laction = .FALSE. ; ssnd(:)%clgrid = 'T' ; ssnd(:)%nsgn = 1. ; ssnd(:)%nct = 1 + + ! ! ------------------------- ! + ! ! Surface temperature ! + ! ! ------------------------- ! + ssnd(jps_toce)%clname = 'O_SSTSST' + ssnd(jps_tice)%clname = 'O_TepIce' + ssnd(jps_ttilyr)%clname = 'O_TtiLyr' + ssnd(jps_tmix)%clname = 'O_TepMix' + SELECT CASE( TRIM( sn_snd_temp%cldes ) ) + CASE( 'none' ) ! nothing to do + CASE( 'oce only' ) ; ssnd( jps_toce )%laction = .TRUE. + CASE( 'oce and ice' , 'weighted oce and ice' , 'oce and weighted ice' ) + ssnd( (/jps_toce, jps_tice/) )%laction = .TRUE. + IF( TRIM( sn_snd_temp%clcat ) == 'yes' ) ssnd(jps_tice)%nct = nn_cats_cpl + CASE( 'mixed oce-ice' ) ; ssnd( jps_tmix )%laction = .TRUE. + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_temp%cldes' ) + END SELECT + + ! ! ------------------------- ! + ! ! Albedo ! + ! ! ------------------------- ! + ssnd(jps_albice)%clname = 'O_AlbIce' + ssnd(jps_albmix)%clname = 'O_AlbMix' + SELECT CASE( TRIM( sn_snd_alb%cldes ) ) + CASE( 'none' ) ! nothing to do + CASE( 'ice' , 'weighted ice' ) ; ssnd(jps_albice)%laction = .TRUE. + CASE( 'mixed oce-ice' ) ; ssnd(jps_albmix)%laction = .TRUE. + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_alb%cldes' ) + END SELECT + ! + ! Need to calculate oceanic albedo if + ! 1. sending mixed oce-ice albedo or + ! 2. receiving mixed oce-ice solar radiation + IF( TRIM ( sn_snd_alb%cldes ) == 'mixed oce-ice' .OR. TRIM ( sn_rcv_qsr%cldes ) == 'mixed oce-ice' ) THEN + CALL oce_alb( zaos, zacs ) + ! Due to lack of information on nebulosity : mean clear/overcast sky + alb_oce_mix(:,:) = ( zacs(:,:) + zaos(:,:) ) * 0.5 + ENDIF + ! ! ------------------------- ! + ! ! Ice fraction & Thickness ! + ! ! ------------------------- ! + ssnd(jps_fice)%clname = 'OIceFrc' + ssnd(jps_ficet)%clname = 'OIceFrcT' + ssnd(jps_hice)%clname = 'OIceTck' + ssnd(jps_a_p)%clname = 'OPndFrc' + ssnd(jps_ht_p)%clname = 'OPndTck' + ssnd(jps_hsnw)%clname = 'OSnwTck' + ssnd(jps_fice1)%clname = 'OIceFrd' + IF( k_ice /= 0 ) THEN + ssnd(jps_fice)%laction = .TRUE. ! if ice treated in the ocean (even in climato case) + ssnd(jps_fice1)%laction = .TRUE. ! First-order regridded ice concentration, to be used producing atmos-to-ice fluxes (Met Office requirement) +! Currently no namelist entry to determine sending of multi-category ice fraction so use the thickness entry for now + IF( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_fice)%nct = nn_cats_cpl + IF( TRIM( sn_snd_thick1%clcat ) == 'yes' ) ssnd(jps_fice1)%nct = nn_cats_cpl + ENDIF + + IF(TRIM( sn_snd_ifrac%cldes ) == 'coupled') ssnd(jps_ficet)%laction = .TRUE. + + SELECT CASE ( TRIM( sn_snd_thick%cldes ) ) + CASE( 'none' ) ! nothing to do + CASE( 'ice and snow' ) + ssnd(jps_hice:jps_hsnw)%laction = .TRUE. + IF( TRIM( sn_snd_thick%clcat ) == 'yes' ) THEN + ssnd(jps_hice:jps_hsnw)%nct = nn_cats_cpl + ENDIF + CASE ( 'weighted ice and snow' ) + ssnd(jps_hice:jps_hsnw)%laction = .TRUE. + IF( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_hice:jps_hsnw)%nct = nn_cats_cpl + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_thick%cldes' ) + END SELECT + + ! ! ------------------------- ! + ! ! Ice Meltponds ! + ! ! ------------------------- ! + ! Needed by Met Office + ssnd(jps_a_p)%clname = 'OPndFrc' + ssnd(jps_ht_p)%clname = 'OPndTck' + SELECT CASE ( TRIM( sn_snd_mpnd%cldes ) ) + CASE ( 'none' ) + ssnd(jps_a_p)%laction = .FALSE. + ssnd(jps_ht_p)%laction = .FALSE. + CASE ( 'ice only' ) + ssnd(jps_a_p)%laction = .TRUE. + ssnd(jps_ht_p)%laction = .TRUE. + IF( TRIM( sn_snd_mpnd%clcat ) == 'yes' ) THEN + ssnd(jps_a_p)%nct = nn_cats_cpl + ssnd(jps_ht_p)%nct = nn_cats_cpl + ELSE + IF( nn_cats_cpl > 1 ) THEN + CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_mpnd%cldes if not exchanging category fields' ) + ENDIF + ENDIF + CASE ( 'weighted ice' ) + ssnd(jps_a_p)%laction = .TRUE. + ssnd(jps_ht_p)%laction = .TRUE. + IF( TRIM( sn_snd_mpnd%clcat ) == 'yes' ) THEN + ssnd(jps_a_p)%nct = nn_cats_cpl + ssnd(jps_ht_p)%nct = nn_cats_cpl + ENDIF + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_mpnd%cldes; '//sn_snd_mpnd%cldes ) + END SELECT + + ! ! ------------------------- ! + ! ! Surface current ! + ! ! ------------------------- ! + ! ocean currents ! ice velocities + ssnd(jps_ocx1)%clname = 'O_OCurx1' ; ssnd(jps_ivx1)%clname = 'O_IVelx1' + ssnd(jps_ocy1)%clname = 'O_OCury1' ; ssnd(jps_ivy1)%clname = 'O_IVely1' + ssnd(jps_ocz1)%clname = 'O_OCurz1' ; ssnd(jps_ivz1)%clname = 'O_IVelz1' + ssnd(jps_ocxw)%clname = 'O_OCurxw' + ssnd(jps_ocyw)%clname = 'O_OCuryw' + ! + ssnd(jps_ocx1:jps_ivz1)%nsgn = -1. ! vectors: change of the sign at the north fold + + IF( sn_snd_crt%clvgrd == 'U,V' ) THEN + ssnd(jps_ocx1)%clgrid = 'U' ; ssnd(jps_ocy1)%clgrid = 'V' + ELSE IF( sn_snd_crt%clvgrd /= 'T' ) THEN + CALL ctl_stop( 'sn_snd_crt%clvgrd must be equal to T' ) + ENDIF + ssnd(jps_ocx1:jps_ivz1)%laction = .TRUE. ! default: all are send + IF( TRIM( sn_snd_crt%clvref ) == 'spherical' ) ssnd( (/jps_ocz1, jps_ivz1/) )%laction = .FALSE. + IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) ssnd(jps_ocx1:jps_ivz1)%nsgn = 1. + SELECT CASE( TRIM( sn_snd_crt%cldes ) ) + CASE( 'none' ) ; ssnd(jps_ocx1:jps_ivz1)%laction = .FALSE. + CASE( 'oce only' ) ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE. + CASE( 'weighted oce and ice' ) ! nothing to do + CASE( 'mixed oce-ice' ) ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE. + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_crt%cldes' ) + END SELECT + + ssnd(jps_ocxw:jps_ocyw)%nsgn = -1. ! vectors: change of the sign at the north fold + + IF( sn_snd_crtw%clvgrd == 'U,V' ) THEN + ssnd(jps_ocxw)%clgrid = 'U' ; ssnd(jps_ocyw)%clgrid = 'V' + ELSE IF( sn_snd_crtw%clvgrd /= 'T' ) THEN + CALL ctl_stop( 'sn_snd_crtw%clvgrd must be equal to T' ) + ENDIF + IF( TRIM( sn_snd_crtw%clvor ) == 'eastward-northward' ) ssnd(jps_ocxw:jps_ocyw)%nsgn = 1. + SELECT CASE( TRIM( sn_snd_crtw%cldes ) ) + CASE( 'none' ) ; ssnd(jps_ocxw:jps_ocyw)%laction = .FALSE. + CASE( 'oce only' ) ; ssnd(jps_ocxw:jps_ocyw)%laction = .TRUE. + CASE( 'weighted oce and ice' ) ! nothing to do + CASE( 'mixed oce-ice' ) ; ssnd(jps_ivx1:jps_ivz1)%laction = .FALSE. + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_crtw%cldes' ) + END SELECT + + ! ! ------------------------- ! + ! ! CO2 flux ! + ! ! ------------------------- ! + ssnd(jps_co2)%clname = 'O_CO2FLX' ; IF( TRIM(sn_snd_co2%cldes) == 'coupled' ) ssnd(jps_co2 )%laction = .TRUE. + ! + ! ! ------------------------- ! + ! ! Sea surface freezing temp ! + ! ! ------------------------- ! + ! needed by Met Office + ssnd(jps_sstfrz)%clname = 'O_SSTFrz' ; IF( TRIM(sn_snd_sstfrz%cldes) == 'coupled' ) ssnd(jps_sstfrz)%laction = .TRUE. + ! + ! ! ------------------------- ! + ! ! Ice conductivity ! + ! ! ------------------------- ! + ! needed by Met Office + ! Note that ultimately we will move to passing an ocean effective conductivity as well so there + ! will be some changes to the parts of the code which currently relate only to ice conductivity + ssnd(jps_ttilyr )%clname = 'O_TtiLyr' + SELECT CASE ( TRIM( sn_snd_ttilyr%cldes ) ) + CASE ( 'none' ) + ssnd(jps_ttilyr)%laction = .FALSE. + CASE ( 'ice only' ) + ssnd(jps_ttilyr)%laction = .TRUE. + IF( TRIM( sn_snd_ttilyr%clcat ) == 'yes' ) THEN + ssnd(jps_ttilyr)%nct = nn_cats_cpl + ELSE + IF( nn_cats_cpl > 1 ) THEN + CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_ttilyr%cldes if not exchanging category fields' ) + ENDIF + ENDIF + CASE ( 'weighted ice' ) + ssnd(jps_ttilyr)%laction = .TRUE. + IF( TRIM( sn_snd_ttilyr%clcat ) == 'yes' ) ssnd(jps_ttilyr)%nct = nn_cats_cpl + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_ttilyr%cldes;'//sn_snd_ttilyr%cldes ) + END SELECT + + ssnd(jps_kice )%clname = 'OIceKn' + SELECT CASE ( TRIM( sn_snd_cond%cldes ) ) + CASE ( 'none' ) + ssnd(jps_kice)%laction = .FALSE. + CASE ( 'ice only' ) + ssnd(jps_kice)%laction = .TRUE. + IF( TRIM( sn_snd_cond%clcat ) == 'yes' ) THEN + ssnd(jps_kice)%nct = nn_cats_cpl + ELSE + IF( nn_cats_cpl > 1 ) THEN + CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_cond%cldes if not exchanging category fields' ) + ENDIF + ENDIF + CASE ( 'weighted ice' ) + ssnd(jps_kice)%laction = .TRUE. + IF( TRIM( sn_snd_cond%clcat ) == 'yes' ) ssnd(jps_kice)%nct = nn_cats_cpl + CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_cond%cldes;'//sn_snd_cond%cldes ) + END SELECT + ! + ! ! ------------------------- ! + ! ! Sea surface height ! + ! ! ------------------------- ! + ssnd(jps_wlev)%clname = 'O_Wlevel' ; IF( TRIM(sn_snd_wlev%cldes) == 'coupled' ) ssnd(jps_wlev)%laction = .TRUE. + + ! ! ------------------------------- ! + ! ! OCE-SAS coupling - snd by opa ! + ! ! ------------------------------- ! + ssnd(jps_ssh )%clname = 'O_SSHght' + ssnd(jps_soce )%clname = 'O_SSSal' + ssnd(jps_e3t1st)%clname = 'O_E3T1st' + ssnd(jps_fraqsr)%clname = 'O_FraQsr' + ! + IF( nn_components == jp_iam_oce ) THEN + ssnd(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling + ssnd( (/jps_toce, jps_soce, jps_ssh, jps_fraqsr, jps_ocx1, jps_ocy1/) )%laction = .TRUE. + ssnd( jps_e3t1st )%laction = .NOT.ln_linssh + ! vector definition: not used but cleaner... + ssnd(jps_ocx1)%clgrid = 'U' ! oce components given at U-point + ssnd(jps_ocy1)%clgrid = 'V' ! and V-point + sn_snd_crt%clvgrd = 'U,V' + sn_snd_crt%clvor = 'local grid' + sn_snd_crt%clvref = 'spherical' + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*)' sent fields to SAS component ' + WRITE(numout,*)' sea surface temperature (T before, Celsius) ' + WRITE(numout,*)' sea surface salinity ' + WRITE(numout,*)' surface currents U,V on local grid and spherical coordinates' + WRITE(numout,*)' sea surface height ' + WRITE(numout,*)' thickness of first ocean T level ' + WRITE(numout,*)' fraction of solar net radiation absorbed in the first ocean level' + WRITE(numout,*) + ENDIF + ENDIF + ! ! ------------------------------- ! + ! ! OCE-SAS coupling - snd by sas ! + ! ! ------------------------------- ! + ssnd(jps_sflx )%clname = 'I_SFLX' + ssnd(jps_fice2 )%clname = 'IIceFrc' + ssnd(jps_qsroce)%clname = 'I_QsrOce' + ssnd(jps_qnsoce)%clname = 'I_QnsOce' + ssnd(jps_oemp )%clname = 'IOEvaMPr' + ssnd(jps_otx1 )%clname = 'I_OTaux1' + ssnd(jps_oty1 )%clname = 'I_OTauy1' + ssnd(jps_rnf )%clname = 'I_Runoff' + ssnd(jps_taum )%clname = 'I_TauMod' + ! + IF( nn_components == jp_iam_sas ) THEN + IF( .NOT. ln_cpl ) ssnd(:)%laction = .FALSE. ! force default definition in case of opa <-> sas coupling + ssnd( (/jps_qsroce, jps_qnsoce, jps_oemp, jps_fice2, jps_sflx, jps_otx1, jps_oty1, jps_taum/) )%laction = .TRUE. + ! + ! Change first letter to couple with atmosphere if already coupled with sea_ice + ! this is nedeed as each variable name used in the namcouple must be unique: + ! for example O_SSTSST sent by OCE to SAS and therefore S_SSTSST sent by SAS to the Atmosphere + DO jn = 1, jpsnd + IF( ssnd(jn)%clname(1:1) == "O" ) ssnd(jn)%clname = "S"//ssnd(jn)%clname(2:LEN(ssnd(jn)%clname)) + END DO + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + IF( .NOT. ln_cpl ) THEN + WRITE(numout,*)' sent fields to OCE component ' + ELSE + WRITE(numout,*)' Additional sent fields to OCE component : ' + ENDIF + WRITE(numout,*)' ice cover ' + WRITE(numout,*)' oce only EMP ' + WRITE(numout,*)' salt flux ' + WRITE(numout,*)' mixed oce-ice solar flux ' + WRITE(numout,*)' mixed oce-ice non solar flux ' + WRITE(numout,*)' wind stress U,V components' + WRITE(numout,*)' wind stress module' + ENDIF + ENDIF + + ! + ! ================================ ! + ! initialisation of the coupler ! + ! ================================ ! + CALL cpl_define(jprcv, jpsnd, nn_cplmodel) + + IF(ln_usecplmask) THEN + xcplmask(:,:,:) = 0. + CALL iom_open( 'cplmask', inum ) + CALL iom_get( inum, jpdom_unknown, 'cplmask', xcplmask(1:jpi,1:jpj,1:nn_cplmodel), & + & kstart = (/ mig(1),mjg(1),1 /), kcount = (/ jpi,jpj,nn_cplmodel /) ) + CALL iom_close( inum ) + ELSE + xcplmask(:,:,:) = 1. + ENDIF + xcplmask(:,:,0) = 1. - SUM( xcplmask(:,:,1:nn_cplmodel), dim = 3 ) + ! + ! + END SUBROUTINE sbc_cpl_init + + + SUBROUTINE sbc_cpl_rcv( kt, k_fsbc, k_ice, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_cpl_rcv *** + !! + !! ** Purpose : provide the stress over the ocean and, if no sea-ice, + !! provide the ocean heat and freshwater fluxes. + !! + !! ** Method : - Receive all the atmospheric fields (stored in frcv array). called at each time step. + !! OASIS controls if there is something do receive or not. nrcvinfo contains the info + !! to know if the field was really received or not + !! + !! --> If ocean stress was really received: + !! + !! - transform the received ocean stress vector from the received + !! referential and grid into an atmosphere-ocean stress in + !! the (i,j) ocean referencial and at the ocean velocity point. + !! The received stress are : + !! - defined by 3 components (if cartesian coordinate) + !! or by 2 components (if spherical) + !! - oriented along geographical coordinate (if eastward-northward) + !! or along the local grid coordinate (if local grid) + !! - given at U- and V-point, resp. if received on 2 grids + !! or at T-point if received on 1 grid + !! Therefore and if necessary, they are successively + !! processed in order to obtain them + !! first as 2 components on the sphere + !! second as 2 components oriented along the local grid + !! third as 2 components on the U,V grid + !! + !! --> + !! + !! - In 'ocean only' case, non solar and solar ocean heat fluxes + !! and total ocean freshwater fluxes + !! + !! ** Method : receive all fields from the atmosphere and transform + !! them into ocean surface boundary condition fields + !! + !! ** Action : update utau, vtau ocean stress at U,V grid + !! taum wind stress module at T-point + !! wndm wind speed module at T-point over free ocean or leads in presence of sea-ice + !! qns non solar heat fluxes including emp heat content (ocean only case) + !! and the latent heat flux of solid precip. melting + !! qsr solar ocean heat fluxes (ocean only case) + !! emp upward mass flux [evap. - precip. (- runoffs) (- calving)] (ocean only case) + !!---------------------------------------------------------------------- + USE zdf_oce, ONLY : ln_zdfswm + ! + INTEGER, INTENT(in) :: kt ! ocean model time step index + INTEGER, INTENT(in) :: k_fsbc ! frequency of sbc (-> ice model) computation + INTEGER, INTENT(in) :: k_ice ! ice management in the sbc (=0/1/2/3) + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean model time level indices + !! + LOGICAL :: llnewtx, llnewtau ! update wind stress components and module?? + INTEGER :: ji, jj, jn ! dummy loop indices + INTEGER :: isec ! number of seconds since nit000 (assuming rdt did not change since nit000) + REAL(wp) :: zcumulneg, zcumulpos ! temporary scalars + REAL(wp) :: zcoef ! temporary scalar + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: zzx, zzy ! temporary variables + REAL(wp) :: r1_grau ! = 1.e0 / (grav * rho0) + REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty, zmsk, zemp, zqns, zqsr, zcloud_fra + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + ! cannot be done in the init phase when we use agrif as cpl_freq requires that oasis_enddef is done + ncpl_qsr_freq = cpl_freq( 'O_QsrOce' ) + cpl_freq( 'O_QsrMix' ) + cpl_freq( 'I_QsrOce' ) + cpl_freq( 'I_QsrMix' ) + IF( ln_dm2dc .AND. ncpl_qsr_freq /= 86400 ) & + & CALL ctl_stop( 'sbc_cpl_rcv: diurnal cycle reconstruction (ln_dm2dc) needs daily couping for solar radiation' ) + + IF ( ln_wave .AND. nn_components == 0 ) THEN + ncpl_qsr_freq = 1; + WRITE(numout,*) 'ncpl_qsr_freq is set to 1 when coupling NEMO with wave (without SAS) ' + ENDIF + ENDIF + ! + IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) + ! + ! ! ======================================================= ! + ! ! Receive all the atmos. fields (including ice information) + ! ! ======================================================= ! + isec = ( kt - nit000 ) * NINT( rn_Dt ) ! date of exchanges + DO jn = 1, jprcv ! received fields sent by the atmosphere + IF( srcv(jn)%laction ) CALL cpl_rcv( jn, isec, frcv(jn)%z3, xcplmask(:,:,1:nn_cplmodel), nrcvinfo(jn) ) + END DO + + ! ! ========================= ! + IF( srcv(jpr_otx1)%laction ) THEN ! ocean stress components ! + ! ! ========================= ! + ! define frcv(jpr_otx1)%z3(:,:,1) and frcv(jpr_oty1)%z3(:,:,1): stress at U/V point along model grid + ! => need to be done only when we receive the field + IF( nrcvinfo(jpr_otx1) == OASIS_Rcv ) THEN + ! + IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN ! 2 components on the sphere + ! ! (cartesian to spherical -> 3 to 2 components) + ! + CALL geo2oce( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), frcv(jpr_otz1)%z3(:,:,1), & + & srcv(jpr_otx1)%clgrid, ztx, zty ) + frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 1st grid + frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 1st grid + ! + IF( srcv(jpr_otx2)%laction ) THEN + CALL geo2oce( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), frcv(jpr_otz2)%z3(:,:,1), & + & srcv(jpr_otx2)%clgrid, ztx, zty ) + frcv(jpr_otx2)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 2nd grid + frcv(jpr_oty2)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 2nd grid + ENDIF + ! + ENDIF + ! + IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid + ! ! (geographical to local grid -> rotate the components) + CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx ) + IF( srcv(jpr_otx2)%laction ) THEN + CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty ) + ELSE + CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty ) + ENDIF + frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid + frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 2nd grid + ENDIF + ! + IF( srcv(jpr_otx1)%clgrid == 'T' ) THEN + DO_2D( 0, 0, 0, 0 ) ! T ==> (U,V) + frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) ) + frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) + END_2D + CALL lbc_lnk( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U', -1.0_wp, frcv(jpr_oty1)%z3(:,:,1), 'V', -1.0_wp ) + ENDIF + llnewtx = .TRUE. + ELSE + llnewtx = .FALSE. + ENDIF + ! ! ========================= ! + ELSE ! No dynamical coupling ! + ! ! ========================= ! + frcv(jpr_otx1)%z3(:,:,1) = 0.e0 ! here simply set to zero + frcv(jpr_oty1)%z3(:,:,1) = 0.e0 ! an external read in a file can be added instead + llnewtx = .TRUE. + ! + ENDIF + ! ! ========================= ! + ! ! wind stress module ! (taum) + ! ! ========================= ! + IF( .NOT. srcv(jpr_taum)%laction ) THEN ! compute wind stress module from its components if not received + ! => need to be done only when otx1 was changed + IF( llnewtx ) THEN + DO_2D( 0, 0, 0, 0 ) + zzx = frcv(jpr_otx1)%z3(ji-1,jj ,1) + frcv(jpr_otx1)%z3(ji,jj,1) + zzy = frcv(jpr_oty1)%z3(ji ,jj-1,1) + frcv(jpr_oty1)%z3(ji,jj,1) + frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy ) + END_2D + CALL lbc_lnk( 'sbccpl', frcv(jpr_taum)%z3(:,:,1), 'T', 1.0_wp ) + llnewtau = .TRUE. + ELSE + llnewtau = .FALSE. + ENDIF + ELSE + llnewtau = nrcvinfo(jpr_taum) == OASIS_Rcv + ! Stress module can be negative when received (interpolation problem) + IF( llnewtau ) THEN + frcv(jpr_taum)%z3(:,:,1) = MAX( 0._wp, frcv(jpr_taum)%z3(:,:,1) ) + ENDIF + ENDIF + ! + ! ! ========================= ! + ! ! 10 m wind speed ! (wndm) + ! ! ========================= ! + IF( .NOT. srcv(jpr_w10m)%laction ) THEN ! compute wind spreed from wind stress module if not received + ! => need to be done only when taumod was changed + IF( llnewtau ) THEN + zcoef = 1. / ( zrhoa * zcdrag ) + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef ) + END_2D + ENDIF + ENDIF +!!$ ! ! ========================= ! +!!$ SELECT CASE( TRIM( sn_rcv_clouds%cldes ) ) ! cloud fraction ! +!!$ ! ! ========================= ! +!!$ cloud_fra(:,:) = frcv(jpr_clfra)*z3(:,:,1) +!!$ END SELECT +!!$ + zcloud_fra(:,:) = pp_cldf ! should be real cloud fraction instead (as in the bulk) but needs to be read from atm. + IF( ln_mixcpl ) THEN + cloud_fra(:,:) = cloud_fra(:,:) * xcplmask(:,:,0) + zcloud_fra(:,:)* zmsk(:,:) + ELSE + cloud_fra(:,:) = zcloud_fra(:,:) + ENDIF + ! ! ========================= ! + ! u(v)tau and taum will be modified by ice model + ! -> need to be reset before each call of the ice/fsbc + IF( MOD( kt-1, k_fsbc ) == 0 ) THEN + ! + IF( ln_mixcpl ) THEN + utau(:,:) = utau(:,:) * xcplmask(:,:,0) + frcv(jpr_otx1)%z3(:,:,1) * zmsk(:,:) + vtau(:,:) = vtau(:,:) * xcplmask(:,:,0) + frcv(jpr_oty1)%z3(:,:,1) * zmsk(:,:) + taum(:,:) = taum(:,:) * xcplmask(:,:,0) + frcv(jpr_taum)%z3(:,:,1) * zmsk(:,:) + wndm(:,:) = wndm(:,:) * xcplmask(:,:,0) + frcv(jpr_w10m)%z3(:,:,1) * zmsk(:,:) + ELSE + utau(:,:) = frcv(jpr_otx1)%z3(:,:,1) + vtau(:,:) = frcv(jpr_oty1)%z3(:,:,1) + taum(:,:) = frcv(jpr_taum)%z3(:,:,1) + wndm(:,:) = frcv(jpr_w10m)%z3(:,:,1) + ENDIF + CALL iom_put( "taum_oce", taum ) ! output wind stress module + ! + ENDIF + + ! ! ================== ! + ! ! atmosph. CO2 (ppm) ! + ! ! ================== ! + IF( srcv(jpr_co2)%laction ) atm_co2(:,:) = frcv(jpr_co2)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Mean Sea Level Pressure ! (taum) + ! ! ========================= ! + IF( srcv(jpr_mslp)%laction ) THEN ! UKMO SHELF effect of atmospheric pressure on SSH + IF( kt /= nit000 ) ssh_ibb(:,:) = ssh_ib(:,:) !* Swap of ssh_ib fields + + r1_grau = 1.e0 / (grav * rho0) !* constant for optimization + ssh_ib(:,:) = - ( frcv(jpr_mslp)%z3(:,:,1) - rpref ) * r1_grau ! equivalent ssh (inverse barometer) + apr (:,:) = frcv(jpr_mslp)%z3(:,:,1) !atmospheric pressure + + IF( kt == nit000 ) ssh_ibb(:,:) = ssh_ib(:,:) ! correct this later (read from restart if possible) + ENDIF + ! + IF( ln_sdw ) THEN ! Stokes Drift correction activated + ! ! ========================= ! + ! ! Stokes drift u ! + ! ! ========================= ! + IF( srcv(jpr_sdrftx)%laction ) ut0sd(:,:) = frcv(jpr_sdrftx)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Stokes drift v ! + ! ! ========================= ! + IF( srcv(jpr_sdrfty)%laction ) vt0sd(:,:) = frcv(jpr_sdrfty)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Wave mean period ! + ! ! ========================= ! + IF( srcv(jpr_wper)%laction ) wmp(:,:) = frcv(jpr_wper)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Significant wave height ! + ! ! ========================= ! + IF( srcv(jpr_hsig)%laction ) hsw(:,:) = frcv(jpr_hsig)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Vertical mixing Qiao ! + ! ! ========================= ! + IF( srcv(jpr_wnum)%laction .AND. ln_zdfswm ) wnum(:,:) = frcv(jpr_wnum)%z3(:,:,1) + + ! Calculate the 3D Stokes drift both in coupled and not fully uncoupled mode + IF( srcv(jpr_sdrftx)%laction .OR. srcv(jpr_sdrfty)%laction .OR. & + srcv(jpr_wper)%laction .OR. srcv(jpr_hsig)%laction ) THEN + CALL sbc_stokes( Kmm ) + ENDIF + ENDIF + ! ! ========================= ! + ! ! Stress adsorbed by waves ! + ! ! ========================= ! + IF( srcv(jpr_wstrf)%laction .AND. ln_tauoc ) tauoc_wave(:,:) = frcv(jpr_wstrf)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Wave drag coefficient ! + ! ! ========================= ! + IF( srcv(jpr_wdrag)%laction .AND. ln_cdgw ) cdn_wave(:,:) = frcv(jpr_wdrag)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Chranock coefficient ! + ! ! ========================= ! + IF( srcv(jpr_charn)%laction .AND. ln_charn ) charn(:,:) = frcv(jpr_charn)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! net wave-supported stress ! + ! ! ========================= ! + IF( srcv(jpr_tawx)%laction .AND. ln_taw ) tawx(:,:) = frcv(jpr_tawx)%z3(:,:,1) + IF( srcv(jpr_tawy)%laction .AND. ln_taw ) tawy(:,:) = frcv(jpr_tawy)%z3(:,:,1) + ! + ! ! ========================= ! + ! !wave to ocean momentum flux! + ! ! ========================= ! + IF( srcv(jpr_twox)%laction .AND. ln_taw ) twox(:,:) = frcv(jpr_twox)%z3(:,:,1) + IF( srcv(jpr_twoy)%laction .AND. ln_taw ) twoy(:,:) = frcv(jpr_twoy)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! wave TKE flux at sfc ! + ! ! ========================= ! + IF( srcv(jpr_phioc)%laction .AND. ln_phioc ) phioc(:,:) = frcv(jpr_phioc)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Bernoulli head ! + ! ! ========================= ! + IF( srcv(jpr_bhd)%laction .AND. ln_bern_srfc ) bhd_wave(:,:) = frcv(jpr_bhd)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Stokes transport u dir ! + ! ! ========================= ! + IF( srcv(jpr_tusd)%laction .AND. ln_breivikFV_2016 ) tusd(:,:) = frcv(jpr_tusd)%z3(:,:,1) + ! + ! ! ========================= ! + ! ! Stokes transport v dir ! + ! ! ========================= ! + IF( srcv(jpr_tvsd)%laction .AND. ln_breivikFV_2016 ) tvsd(:,:) = frcv(jpr_tvsd)%z3(:,:,1) + ! + ! Fields received by SAS when OASIS coupling + ! (arrays no more filled at sbcssm stage) + ! ! ================== ! + ! ! SSS ! + ! ! ================== ! + IF( srcv(jpr_soce)%laction ) THEN ! received by sas in case of opa <-> sas coupling + sss_m(:,:) = frcv(jpr_soce)%z3(:,:,1) + CALL iom_put( 'sss_m', sss_m ) + ENDIF + ! + ! ! ================== ! + ! ! SST ! + ! ! ================== ! + IF( srcv(jpr_toce)%laction ) THEN ! received by sas in case of opa <-> sas coupling + sst_m(:,:) = frcv(jpr_toce)%z3(:,:,1) + IF( srcv(jpr_soce)%laction .AND. l_useCT ) THEN ! make sure that sst_m is the potential temperature + sst_m(:,:) = eos_pt_from_ct( sst_m(:,:), sss_m(:,:) ) + ENDIF + ENDIF + ! ! ================== ! + ! ! SSH ! + ! ! ================== ! + IF( srcv(jpr_ssh )%laction ) THEN ! received by sas in case of opa <-> sas coupling + ssh_m(:,:) = frcv(jpr_ssh )%z3(:,:,1) + CALL iom_put( 'ssh_m', ssh_m ) + ENDIF + ! ! ================== ! + ! ! surface currents ! + ! ! ================== ! + IF( srcv(jpr_ocx1)%laction ) THEN ! received by sas in case of opa <-> sas coupling + ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) + uu(:,:,1,Kbb) = ssu_m(:,:) ! will be used in icestp in the call of ice_forcing_tau + uu(:,:,1,Kmm) = ssu_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling + CALL iom_put( 'ssu_m', ssu_m ) + ENDIF + IF( srcv(jpr_ocy1)%laction ) THEN + ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) + vv(:,:,1,Kbb) = ssv_m(:,:) ! will be used in icestp in the call of ice_forcing_tau + vv(:,:,1,Kmm) = ssv_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling + CALL iom_put( 'ssv_m', ssv_m ) + ENDIF + ! ! ======================== ! + ! ! first T level thickness ! + ! ! ======================== ! + IF( srcv(jpr_e3t1st )%laction ) THEN ! received by sas in case of opa <-> sas coupling + e3t_m(:,:) = frcv(jpr_e3t1st )%z3(:,:,1) + CALL iom_put( 'e3t_m', e3t_m(:,:) ) + ENDIF + ! ! ================================ ! + ! ! fraction of solar net radiation ! + ! ! ================================ ! + IF( srcv(jpr_fraqsr)%laction ) THEN ! received by sas in case of opa <-> sas coupling + frq_m(:,:) = frcv(jpr_fraqsr)%z3(:,:,1) + CALL iom_put( 'frq_m', frq_m ) + ENDIF + + ! ! ========================= ! + IF( k_ice <= 1 .AND. MOD( kt-1, k_fsbc ) == 0 ) THEN ! heat & freshwater fluxes ! (Ocean only case) + ! ! ========================= ! + ! + ! ! total freshwater fluxes over the ocean (emp) + IF( srcv(jpr_oemp)%laction .OR. srcv(jpr_rain)%laction ) THEN + SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) ! evaporation - precipitation + CASE( 'conservative' ) + zemp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ( frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1) ) + CASE( 'oce only', 'oce and ice' ) + zemp(:,:) = frcv(jpr_oemp)%z3(:,:,1) + CASE default + CALL ctl_stop( 'sbc_cpl_rcv: wrong definition of sn_rcv_emp%cldes' ) + END SELECT + ELSE + zemp(:,:) = 0._wp + ENDIF + ! + ! ! runoffs and calving (added in emp) + IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) + IF( srcv(jpr_cal)%laction ) zemp(:,:) = zemp(:,:) - frcv(jpr_cal)%z3(:,:,1) + + IF( srcv(jpr_icb)%laction ) THEN + fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) + rnf(:,:) = rnf(:,:) + fwficb(:,:) ! iceberg added to runfofs + ENDIF + ! + ! ice shelf fwf + IF( srcv(jpr_isf)%laction ) THEN + fwfisf_oasis(:,:) = frcv(jpr_isf)%z3(:,:,1) ! fresh water flux from the isf to the ocean ( > 0 = melting ) + END IF + + IF( ln_mixcpl ) THEN ; emp(:,:) = emp(:,:) * xcplmask(:,:,0) + zemp(:,:) * zmsk(:,:) + ELSE ; emp(:,:) = zemp(:,:) + ENDIF + ! + ! ! non solar heat flux over the ocean (qns) + IF( srcv(jpr_qnsoce)%laction ) THEN ; zqns(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) + ELSE IF( srcv(jpr_qnsmix)%laction ) THEN ; zqns(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) + ELSE ; zqns(:,:) = 0._wp + ENDIF + ! update qns over the free ocean with: + IF( nn_components /= jp_iam_oce ) THEN + zqns(:,:) = zqns(:,:) - zemp(:,:) * sst_m(:,:) * rcp ! remove heat content due to mass flux (assumed to be at SST) + IF( srcv(jpr_snow )%laction ) THEN + zqns(:,:) = zqns(:,:) - frcv(jpr_snow)%z3(:,:,1) * rLfus ! energy for melting solid precipitation over the free ocean + ENDIF + ENDIF + ! + IF( srcv(jpr_icb)%laction ) zqns(:,:) = zqns(:,:) - frcv(jpr_icb)%z3(:,:,1) * rLfus ! remove heat content associated to iceberg melting + ! + IF( ln_mixcpl ) THEN ; qns(:,:) = qns(:,:) * xcplmask(:,:,0) + zqns(:,:) * zmsk(:,:) + ELSE ; qns(:,:) = zqns(:,:) + ENDIF + + ! ! solar flux over the ocean (qsr) + IF ( srcv(jpr_qsroce)%laction ) THEN ; zqsr(:,:) = frcv(jpr_qsroce)%z3(:,:,1) + ELSE IF( srcv(jpr_qsrmix)%laction ) then ; zqsr(:,:) = frcv(jpr_qsrmix)%z3(:,:,1) + ELSE ; zqsr(:,:) = 0._wp + ENDIF + IF( ln_dm2dc .AND. ln_cpl ) zqsr(:,:) = sbc_dcy( zqsr ) ! modify qsr to include the diurnal cycle + IF( ln_mixcpl ) THEN ; qsr(:,:) = qsr(:,:) * xcplmask(:,:,0) + zqsr(:,:) * zmsk(:,:) + ELSE ; qsr(:,:) = zqsr(:,:) + ENDIF + ! + ! salt flux over the ocean (received by opa in case of opa <-> sas coupling) + IF( srcv(jpr_sflx )%laction ) sfx(:,:) = frcv(jpr_sflx )%z3(:,:,1) + ! Ice cover (received by opa in case of opa <-> sas coupling) + IF( srcv(jpr_fice )%laction ) fr_i(:,:) = frcv(jpr_fice )%z3(:,:,1) + ! + ENDIF + ! + END SUBROUTINE sbc_cpl_rcv + + + SUBROUTINE sbc_cpl_ice_tau( p_taui, p_tauj ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_cpl_ice_tau *** + !! + !! ** Purpose : provide the stress over sea-ice in coupled mode + !! + !! ** Method : transform the received stress from the atmosphere into + !! an atmosphere-ice stress in the (i,j) ocean referencial + !! and at the velocity point of the sea-ice model: + !! 'C'-grid : i- (j-) components given at U- (V-) point + !! + !! The received stress are : + !! - defined by 3 components (if cartesian coordinate) + !! or by 2 components (if spherical) + !! - oriented along geographical coordinate (if eastward-northward) + !! or along the local grid coordinate (if local grid) + !! - given at U- and V-point, resp. if received on 2 grids + !! or at a same point (T or I) if received on 1 grid + !! Therefore and if necessary, they are successively + !! processed in order to obtain them + !! first as 2 components on the sphere + !! second as 2 components oriented along the local grid + !! third as 2 components on the ice grid point + !! + !! Except in 'oce and ice' case, only one vector stress field + !! is received. It has already been processed in sbc_cpl_rcv + !! so that it is now defined as (i,j) components given at U- + !! and V-points, respectively. + !! + !! ** Action : return ptau_i, ptau_j, the stress over the ice + !!---------------------------------------------------------------------- + REAL(wp), INTENT(inout), DIMENSION(:,:) :: p_taui ! i- & j-components of atmos-ice stress [N/m2] + REAL(wp), INTENT(inout), DIMENSION(:,:) :: p_tauj ! at I-point (B-grid) or U & V-point (C-grid) + !! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: itx ! index of taux over ice + REAL(wp) :: zztmp1, zztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: ztx, zty + !!---------------------------------------------------------------------- + ! +#if defined key_si3 || defined key_cice + ! + IF( srcv(jpr_itx1)%laction ) THEN ; itx = jpr_itx1 + ELSE ; itx = jpr_otx1 + ENDIF + + ! do something only if we just received the stress from atmosphere + IF( nrcvinfo(itx) == OASIS_Rcv ) THEN + ! ! ======================= ! + IF( srcv(jpr_itx1)%laction ) THEN ! ice stress received ! + ! ! ======================= ! + ! + IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN ! 2 components on the sphere + ! ! (cartesian to spherical -> 3 to 2 components) + CALL geo2oce( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), frcv(jpr_itz1)%z3(:,:,1), & + & srcv(jpr_itx1)%clgrid, ztx, zty ) + frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 1st grid + frcv(jpr_ity1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 1st grid + ! + IF( srcv(jpr_itx2)%laction ) THEN + CALL geo2oce( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), frcv(jpr_itz2)%z3(:,:,1), & + & srcv(jpr_itx2)%clgrid, ztx, zty ) + frcv(jpr_itx2)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 2nd grid + frcv(jpr_ity2)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 2nd grid + ENDIF + ! + ENDIF + ! + IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid + ! ! (geographical to local grid -> rotate the components) + CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->i', ztx ) + IF( srcv(jpr_itx2)%laction ) THEN + CALL rot_rep( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), srcv(jpr_itx2)%clgrid, 'en->j', zty ) + ELSE + CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->j', zty ) + ENDIF + frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid + frcv(jpr_ity1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 1st grid + ENDIF + ! ! ======================= ! + ELSE ! use ocean stress ! + ! ! ======================= ! + frcv(jpr_itx1)%z3(:,:,1) = frcv(jpr_otx1)%z3(:,:,1) + frcv(jpr_ity1)%z3(:,:,1) = frcv(jpr_oty1)%z3(:,:,1) + ! + ENDIF + ! ! ======================= ! + ! ! put on ice grid ! + ! ! ======================= ! + ! + ! j+1 j -----V---F + ! ice stress on ice velocity point ! | + ! (C-grid ==>(U,V)) j | T U + ! | | + ! j j-1 -I-------| + ! (for I) | | + ! i-1 i i + ! i i+1 (for I) + SELECT CASE ( srcv(jpr_itx1)%clgrid ) + CASE( 'U' ) + p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1) ! (U,V) ==> (U,V) + p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1) + CASE( 'T' ) + DO_2D( 0, 0, 0, 0 ) ! T ==> (U,V) + ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology + zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) ) + zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji ,jj+1,1) ) + p_taui(ji,jj) = zztmp1 * ( frcv(jpr_itx1)%z3(ji+1,jj ,1) + frcv(jpr_itx1)%z3(ji,jj,1) ) + p_tauj(ji,jj) = zztmp2 * ( frcv(jpr_ity1)%z3(ji ,jj+1,1) + frcv(jpr_ity1)%z3(ji,jj,1) ) + END_2D + CALL lbc_lnk( 'sbccpl', p_taui, 'U', -1., p_tauj, 'V', -1. ) + END SELECT + + ENDIF + ! +#endif + ! + END SUBROUTINE sbc_cpl_ice_tau + + + SUBROUTINE sbc_cpl_ice_flx( kt, picefr, palbi, psst, pist, phs, phi ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_cpl_ice_flx *** + !! + !! ** Purpose : provide the heat and freshwater fluxes of the ocean-ice system + !! + !! ** Method : transform the fields received from the atmosphere into + !! surface heat and fresh water boundary condition for the + !! ice-ocean system. The following fields are provided: + !! * total non solar, solar and freshwater fluxes (qns_tot, + !! qsr_tot and emp_tot) (total means weighted ice-ocean flux) + !! NB: emp_tot include runoffs and calving. + !! * fluxes over ice (qns_ice, qsr_ice, emp_ice) where + !! emp_ice = sublimation - solid precipitation as liquid + !! precipitation are re-routed directly to the ocean and + !! calving directly enter the ocean (runoffs are read but included in trasbc.F90) + !! * solid precipitation (sprecip), used to add to qns_tot + !! the heat lost associated to melting solid precipitation + !! over the ocean fraction. + !! * heat content of rain, snow and evap can also be provided, + !! otherwise heat flux associated with these mass flux are + !! guessed (qemp_oce, qemp_ice) + !! + !! - the fluxes have been separated from the stress as + !! (a) they are updated at each ice time step compare to + !! an update at each coupled time step for the stress, and + !! (b) the conservative computation of the fluxes over the + !! sea-ice area requires the knowledge of the ice fraction + !! after the ice advection and before the ice thermodynamics, + !! so that the stress is updated before the ice dynamics + !! while the fluxes are updated after it. + !! + !! ** Details + !! qns_tot = (1-a) * qns_oce + a * qns_ice => provided + !! + qemp_oce + qemp_ice => recalculated and added up to qns + !! + !! qsr_tot = (1-a) * qsr_oce + a * qsr_ice => provided + !! + !! emp_tot = emp_oce + emp_ice => calving is provided and added to emp_tot (and emp_oce). + !! runoff (which includes rivers+icebergs) and iceshelf + !! are provided but not included in emp here. Only runoff will + !! be included in emp in other parts of NEMO code + !! + !! ** Note : In case of the ice-atm coupling with conduction fluxes (such as Jules interface for the Met-Office), + !! qsr_ice and qns_ice are not provided and they are not supposed to be used in the ice code. + !! However, by precaution we also "fake" qns_ice and qsr_ice this way: + !! qns_ice = qml_ice + qcn_ice ?? + !! qsr_ice = qtr_ice_top ?? + !! + !! ** Action : update at each nf_ice time step: + !! qns_tot, qsr_tot non-solar and solar total heat fluxes + !! qns_ice, qsr_ice non-solar and solar heat fluxes over the ice + !! emp_tot total evaporation - precipitation(liquid and solid) (-calving) + !! emp_ice ice sublimation - solid precipitation over the ice + !! dqns_ice d(non-solar heat flux)/d(Temperature) over the ice + !! sprecip solid precipitation over the ocean + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean model time step index (only for a_i_last_couple) + REAL(wp), INTENT(in) , DIMENSION(:,:) :: picefr ! ice fraction [0 to 1] + ! !! ! optional arguments, used only in 'mixed oce-ice' case or for Met-Office coupling + REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo + REAL(wp), INTENT(in) , DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius] + REAL(wp), INTENT(inout), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] => inout for Met-Office + REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phs ! snow depth [m] + REAL(wp), INTENT(in) , DIMENSION(:,:,:), OPTIONAL :: phi ! ice thickness [m] + ! + INTEGER :: ji, jj, jl ! dummy loop index + REAL(wp), DIMENSION(jpi,jpj) :: zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw + REAL(wp), DIMENSION(jpi,jpj) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip , zevap_oce, zdevap_ice + REAL(wp), DIMENSION(jpi,jpj) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice + REAL(wp), DIMENSION(jpi,jpj) :: zevap_ice_total + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zevap_ice, zqtr_ice_top, ztsu + REAL(wp), DIMENSION(jpi,jpj) :: ztri + !!---------------------------------------------------------------------- + ! +#if defined key_si3 || defined key_cice + ! + IF( kt == nit000 ) THEN + ! allocate ice fractions from last coupling time here and not in sbc_cpl_init because of jpl + IF( .NOT.ALLOCATED(a_i_last_couple) ) ALLOCATE( a_i_last_couple(jpi,jpj,jpl) ) + ! initialize to a_i for the 1st time step + a_i_last_couple(:,:,:) = a_i(:,:,:) + ENDIF + ! + IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) + ziceld(:,:) = 1._wp - picefr(:,:) + zcptn (:,:) = rcp * sst_m(:,:) + ! + ! ! ========================= ! + ! ! freshwater budget ! (emp_tot) + ! ! ========================= ! + ! + ! ! solid Precipitation (sprecip) + ! ! liquid + solid Precipitation (tprecip) + ! ! total Evaporation - total Precipitation (emp_tot) + ! ! sublimation - solid precipitation (cell average) (emp_ice) + SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) + CASE( 'conservative' ) ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp + zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1) ! May need to ensure positive here + ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here + zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) + CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp + zemp_tot(:,:) = ziceld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + picefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) + zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * picefr(:,:) + zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) + ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) + CASE( 'none' ) ! Not available as for now: needs additional coding below when computing zevap_oce + ! ! since fields received are not defined with none option + CALL ctl_stop('STOP', 'sbccpl/sbc_cpl_ice_flx: some fields are not defined. Change sn_rcv_emp value in namelist namsbc_cpl') + END SELECT + + ! --- evaporation over ice (kg/m2/s) --- ! + IF (ln_scale_ice_flux) THEN ! typically met-office requirements + IF (sn_rcv_emp%clcat == 'yes') THEN + WHERE( a_i(:,:,:) > 1.e-10 ) ; zevap_ice(:,:,:) = frcv(jpr_ievp)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) + ELSEWHERE ; zevap_ice(:,:,:) = 0._wp + END WHERE + WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) / picefr(:,:) + ELSEWHERE ; zevap_ice_total(:,:) = 0._wp + END WHERE + ELSE + WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) * SUM( a_i_last_couple, dim=3 ) / picefr(:,:) + ELSEWHERE ; zevap_ice(:,:,1) = 0._wp + END WHERE + zevap_ice_total(:,:) = zevap_ice(:,:,1) + DO jl = 2, jpl + zevap_ice(:,:,jl) = zevap_ice(:,:,1) + ENDDO + ENDIF + ELSE + IF (sn_rcv_emp%clcat == 'yes') THEN + zevap_ice(:,:,1:jpl) = frcv(jpr_ievp)%z3(:,:,1:jpl) + WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) / picefr(:,:) + ELSEWHERE ; zevap_ice_total(:,:) = 0._wp + END WHERE + ELSE + zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) + zevap_ice_total(:,:) = zevap_ice(:,:,1) + DO jl = 2, jpl + zevap_ice(:,:,jl) = zevap_ice(:,:,1) + ENDDO + ENDIF + ENDIF + + IF ( TRIM( sn_rcv_emp%cldes ) == 'conservative' ) THEN + ! For conservative case zemp_ice has not been defined yet. Do it now. + zemp_ice(:,:) = zevap_ice_total(:,:) * picefr(:,:) - frcv(jpr_snow)%z3(:,:,1) * picefr(:,:) + ENDIF + + ! zsnw = snow fraction over ice after wind blowing (=picefr if no blowing) + zsnw(:,:) = 0._wp ; CALL ice_var_snwblow( ziceld, zsnw ) + + ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! + zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( picefr(:,:) - zsnw(:,:) ) ! emp_ice = A * sublimation - zsnw * sprecip + zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:) ! emp_oce = emp_tot - emp_ice + + ! --- evaporation over ocean (used later for qemp) --- ! + zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - zevap_ice_total(:,:) * picefr(:,:) + + ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 + ! therefore, sublimation is not redistributed over the ice categories when no subgrid scale fluxes are provided by atm. + zdevap_ice(:,:) = 0._wp + + ! --- Continental fluxes --- ! + IF( srcv(jpr_rnf)%laction ) THEN ! runoffs (included in emp later on) + rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) + ENDIF + IF( srcv(jpr_cal)%laction ) THEN ! calving (put in emp_tot and emp_oce) + zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) + zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1) + ENDIF + IF( srcv(jpr_icb)%laction ) THEN ! iceberg added to runoffs + fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) + rnf(:,:) = rnf(:,:) + fwficb(:,:) + ENDIF + IF( srcv(jpr_isf)%laction ) THEN ! iceshelf (fwfisf > 0 mean melting) + fwfisf_oasis(:,:) = frcv(jpr_isf)%z3(:,:,1) + ENDIF + + IF( ln_mixcpl ) THEN + emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) + emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) + emp_oce(:,:) = emp_oce(:,:) * xcplmask(:,:,0) + zemp_oce(:,:) * zmsk(:,:) + sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) + tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) + DO jl = 1, jpl + evap_ice (:,:,jl) = evap_ice (:,:,jl) * xcplmask(:,:,0) + zevap_ice (:,:,jl) * zmsk(:,:) + devap_ice(:,:,jl) = devap_ice(:,:,jl) * xcplmask(:,:,0) + zdevap_ice(:,:) * zmsk(:,:) + END DO + ELSE + emp_tot (:,:) = zemp_tot (:,:) + emp_ice (:,:) = zemp_ice (:,:) + emp_oce (:,:) = zemp_oce (:,:) + sprecip (:,:) = zsprecip (:,:) + tprecip (:,:) = ztprecip (:,:) + evap_ice(:,:,:) = zevap_ice(:,:,:) + DO jl = 1, jpl + devap_ice(:,:,jl) = zdevap_ice(:,:) + END DO + ENDIF + +!! for CICE ?? +!!$ zsnw(:,:) = picefr(:,:) +!!$ ! --- Continental fluxes --- ! +!!$ IF( srcv(jpr_rnf)%laction ) THEN ! runoffs (included in emp later on) +!!$ rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) +!!$ ENDIF +!!$ IF( srcv(jpr_cal)%laction ) THEN ! calving (put in emp_tot) +!!$ zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) +!!$ ENDIF +!!$ IF( srcv(jpr_icb)%laction ) THEN ! iceberg added to runoffs +!!$ fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) +!!$ rnf(:,:) = rnf(:,:) + fwficb(:,:) +!!$ ENDIF +!!$ IF( srcv(jpr_isf)%laction ) THEN ! iceshelf (fwfisf >0 mean melting) +!!$ fwfisf_oasis(:,:) = frcv(jpr_isf)%z3(:,:,1) +!!$ ENDIF +!!$ ! +!!$ IF( ln_mixcpl ) THEN +!!$ emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) +!!$ emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) +!!$ sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) +!!$ tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) +!!$ ELSE +!!$ emp_tot(:,:) = zemp_tot(:,:) +!!$ emp_ice(:,:) = zemp_ice(:,:) +!!$ sprecip(:,:) = zsprecip(:,:) +!!$ tprecip(:,:) = ztprecip(:,:) +!!$ ENDIF + ! + ! outputs + IF( srcv(jpr_cal)%laction ) CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(:,:,1) ) ! calving + IF( srcv(jpr_icb)%laction ) CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(:,:,1) ) ! icebergs + IF( iom_use('snowpre') ) CALL iom_put( 'snowpre' , sprecip(:,:) ) ! Snow + IF( iom_use('precip') ) CALL iom_put( 'precip' , tprecip(:,:) ) ! total precipitation + IF( iom_use('rain') ) CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation + IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average) + IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea' , sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average) + IF( iom_use('rain_ao_cea') ) CALL iom_put( 'rain_ao_cea' , ( tprecip(:,:) - sprecip(:,:) ) * ziceld(:,:) ) ! liquid precipitation over ocean (cell average) + IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , zevap_ice_total(:,:) * picefr(:,:) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average) + IF( iom_use('evap_ao_cea') ) CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1) & + & - zevap_ice_total(:,:) * picefr(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average) + ! note: runoff output is done in sbcrnf (which includes icebergs too) and iceshelf output is done in sbcisf +!! IF( srcv(jpr_rnf)%laction ) CALL iom_put( 'runoffs' , rnf(:,:) * tmask(:,:,1) ) ! runoff +!! IF( srcv(jpr_isf)%laction ) CALL iom_put( 'iceshelf_cea', fwfisf(:,:) * tmask(:,:,1) ) ! iceshelf + ! + ! ! ========================= ! + SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) ) ! ice topmelt and botmelt ! + ! ! ========================= ! + CASE ('coupled') + IF (ln_scale_ice_flux) THEN + WHERE( a_i(:,:,:) > 1.e-10_wp ) + qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) + qcn_ice(:,:,:) = frcv(jpr_botm)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) + ELSEWHERE + qml_ice(:,:,:) = 0.0_wp + qcn_ice(:,:,:) = 0.0_wp + END WHERE + ELSE + qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) + qcn_ice(:,:,:) = frcv(jpr_botm)%z3(:,:,:) + ENDIF + END SELECT + ! + ! ! ========================= ! + SELECT CASE( TRIM( sn_rcv_qns%cldes ) ) ! non solar heat fluxes ! (qns) + ! ! ========================= ! + CASE( 'oce only' ) ! the required field is directly provided + ! Get the sea ice non solar heat flux from conductive, melting and sublimation fluxes + IF( TRIM(sn_rcv_iceflx%cldes) == 'coupled' ) THEN + zqns_ice(:,:,:) = qml_ice(:,:,:) + qcn_ice(:,:,:) + ELSE + zqns_ice(:,:,:) = 0._wp + ENDIF + ! Calculate the total non solar heat flux. The ocean only non solar heat flux (zqns_oce) will be recalculated after this CASE + ! statement to be consistent with other coupling methods even though .zqns_oce = frcv(jpr_qnsoce)%z3(:,:,1) + zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) + SUM( zqns_ice(:,:,:) * a_i(:,:,:), dim=3 ) + CASE( 'conservative' ) ! the required fields are directly provided + zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) + IF( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN + zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) + ELSE + DO jl = 1, jpl + zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) ! Set all category values equal + END DO + ENDIF + CASE( 'oce and ice' ) ! the total flux is computed from ocean and ice fluxes + zqns_tot(:,:) = ziceld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) + IF( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN + DO jl=1,jpl + zqns_tot(:,: ) = zqns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl) + zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl) + ENDDO + ELSE + zqns_tot(:,:) = zqns_tot(:,:) + picefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) + DO jl = 1, jpl + zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) + END DO + ENDIF + CASE( 'mixed oce-ice' ) ! the ice flux is cumputed from the total flux, the SST and ice informations +! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** + zqns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1) + IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN + DO jl = 1, jpl + zqns_ice(:,:,jl) = frcv(jpr_qnsmix)%z3(:,:,jl) & + & + frcv(jpr_dqnsdt)%z3(:,:,jl) * ( pist(:,:,jl) - ( ( rt0 + psst(:,:) ) * ziceld(:,:) & + & + pist(:,:,jl) * picefr(:,:) ) ) + END DO + ELSE + DO jl = 1, jpl + zqns_ice(:,:,jl) = frcv(jpr_qnsmix)%z3(:,:, 1) & + & + frcv(jpr_dqnsdt)%z3(:,:, 1) * ( pist(:,:,jl) - ( ( rt0 + psst(:,:) ) * ziceld(:,:) & + & + pist(:,:,jl) * picefr(:,:) ) ) + END DO + ENDIF + END SELECT + ! + ! --- calving (removed from qns_tot) --- ! + IF( srcv(jpr_cal)%laction ) zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * rLfus ! remove latent heat of calving + ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean + ! --- iceberg (removed from qns_tot) --- ! + IF( srcv(jpr_icb)%laction ) zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_icb)%z3(:,:,1) * rLfus ! remove latent heat of iceberg melting + + ! --- non solar flux over ocean --- ! + ! note: ziceld cannot be = 0 since we limit the ice concentration to amax + zqns_oce = 0._wp + WHERE( ziceld /= 0._wp ) zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / ziceld(:,:) + + ! Heat content per unit mass of snow (J/kg) + WHERE( SUM( a_i, dim=3 ) > 1.e-10 ) ; zcptsnw(:,:) = rcpi * SUM( (tn_ice - rt0) * a_i, dim=3 ) / SUM( a_i, dim=3 ) + ELSEWHERE ; zcptsnw(:,:) = zcptn(:,:) + ENDWHERE + ! Heat content per unit mass of rain (J/kg) + zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) - rt0) * a_i(:,:,:), dim=3 ) + sst_m(:,:) * ziceld(:,:) ) + + ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! + zqprec_ice(:,:) = rhos * ( zcptsnw(:,:) - rLfus ) + + ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! + DO jl = 1, jpl + zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * rcpi ) but atm. does not take it into account + END DO + + ! --- heat flux associated with emp (W/m2) --- ! + zqemp_oce(:,:) = - zevap_oce(:,:) * zcptn (:,:) & ! evap + & + ( ztprecip(:,:) - zsprecip(:,:) ) * zcptrain(:,:) & ! liquid precip + & + zsprecip(:,:) * ( 1._wp - zsnw ) * ( zcptsnw (:,:) - rLfus ) ! solid precip over ocean + snow melting + zqemp_ice(:,:) = zsprecip(:,:) * zsnw * ( zcptsnw (:,:) - rLfus ) ! solid precip over ice (qevap_ice=0 since atm. does not take it into account) +!! zqemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * zcptsnw (:,:) & ! ice evap +!! & + zsprecip(:,:) * zsnw * zqprec_ice(:,:) * r1_rhos ! solid precip over ice + + ! --- total non solar flux (including evap/precip) --- ! + zqns_tot(:,:) = zqns_tot(:,:) + zqemp_ice(:,:) + zqemp_oce(:,:) + + ! --- in case both coupled/forced are active, we must mix values --- ! + IF( ln_mixcpl ) THEN + qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) + zqns_tot(:,:)* zmsk(:,:) + qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:) + DO jl=1,jpl + qns_ice (:,:,jl) = qns_ice (:,:,jl) * xcplmask(:,:,0) + zqns_ice (:,:,jl)* zmsk(:,:) + qevap_ice(:,:,jl) = qevap_ice(:,:,jl) * xcplmask(:,:,0) + zqevap_ice(:,:,jl)* zmsk(:,:) + ENDDO + qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:) + qemp_oce (:,:) = qemp_oce(:,:) * xcplmask(:,:,0) + zqemp_oce(:,:)* zmsk(:,:) + qemp_ice (:,:) = qemp_ice(:,:) * xcplmask(:,:,0) + zqemp_ice(:,:)* zmsk(:,:) + ELSE + qns_tot (:,: ) = zqns_tot (:,: ) + qns_oce (:,: ) = zqns_oce (:,: ) + qns_ice (:,:,:) = zqns_ice (:,:,:) + qevap_ice(:,:,:) = zqevap_ice(:,:,:) + qprec_ice(:,: ) = zqprec_ice(:,: ) + qemp_oce (:,: ) = zqemp_oce (:,: ) + qemp_ice (:,: ) = zqemp_ice (:,: ) + ENDIF + +!! for CICE ?? +!!$ ! --- non solar flux over ocean --- ! +!!$ zcptsnw (:,:) = zcptn(:,:) +!!$ zcptrain(:,:) = zcptn(:,:) +!!$ +!!$ ! clem: this formulation is certainly wrong... but better than it was... +!!$ zqns_tot(:,:) = zqns_tot(:,:) & ! zqns_tot update over free ocean with: +!!$ & - ( ziceld(:,:) * zsprecip(:,:) * rLfus ) & ! remove the latent heat flux of solid precip. melting +!!$ & - ( zemp_tot(:,:) & ! remove the heat content of mass flux (assumed to be at SST) +!!$ & - zemp_ice(:,:) ) * zcptn(:,:) +!!$ +!!$ IF( ln_mixcpl ) THEN +!!$ qns_tot(:,:) = qns(:,:) * ziceld(:,:) + SUM( qns_ice(:,:,:) * a_i(:,:,:), dim=3 ) ! total flux from blk +!!$ qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) + zqns_tot(:,:)* zmsk(:,:) +!!$ DO jl=1,jpl +!!$ qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) + zqns_ice(:,:,jl)* zmsk(:,:) +!!$ ENDDO +!!$ ELSE +!!$ qns_tot(:,: ) = zqns_tot(:,: ) +!!$ qns_ice(:,:,:) = zqns_ice(:,:,:) +!!$ ENDIF + + ! outputs + IF ( srcv(jpr_cal)%laction ) CALL iom_put('hflx_cal_cea' , - frcv(jpr_cal)%z3(:,:,1) * rLfus ) ! latent heat from calving + IF ( srcv(jpr_icb)%laction ) CALL iom_put('hflx_icb_cea' , - frcv(jpr_icb)%z3(:,:,1) * rLfus ) ! latent heat from icebergs melting + IF ( iom_use('hflx_rain_cea') ) & ! heat flux from rain (cell average) + & CALL iom_put('hflx_rain_cea' , ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) + IF ( iom_use('hflx_evap_cea') ) & ! heat flux from evap (cell average) + & CALL iom_put('hflx_evap_cea' , ( frcv(jpr_tevp)%z3(:,:,1) - zevap_ice_total(:,:) * picefr(:,:) ) & + & * zcptn(:,:) * tmask(:,:,1) ) + IF ( iom_use('hflx_prec_cea') ) & ! heat flux from all precip (cell avg) + & CALL iom_put('hflx_prec_cea' , sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) & + & + ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) + IF ( iom_use('hflx_snow_cea') ) & ! heat flux from snow (cell average) + & CALL iom_put('hflx_snow_cea' , sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) ) + IF ( iom_use('hflx_snow_ao_cea') ) & ! heat flux from snow (over ocean) + & CALL iom_put('hflx_snow_ao_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) * ( 1._wp - zsnw(:,:) ) ) + IF ( iom_use('hflx_snow_ai_cea') ) & ! heat flux from snow (over ice) + & CALL iom_put('hflx_snow_ai_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) * zsnw(:,:) ) + IF( iom_use('hflx_subl_cea') ) & ! heat flux from sublimation + & CALL iom_put('hflx_subl_cea' , SUM( qevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) * tmask(:,:,1) ) + ! note: hflx for runoff and iceshelf are done in sbcrnf and sbcisf resp. + ! + ! ! ========================= ! + SELECT CASE( TRIM( sn_rcv_dqnsdt%cldes ) ) ! d(qns)/dt ! + ! ! ========================= ! + CASE ('coupled') + IF( TRIM(sn_rcv_dqnsdt%clcat) == 'yes' ) THEN + zdqns_ice(:,:,1:jpl) = frcv(jpr_dqnsdt)%z3(:,:,1:jpl) + ELSE + ! Set all category values equal for the moment + DO jl=1,jpl + zdqns_ice(:,:,jl) = frcv(jpr_dqnsdt)%z3(:,:,1) + ENDDO + ENDIF + CASE( 'none' ) + zdqns_ice(:,:,:) = 0._wp + END SELECT + + IF( ln_mixcpl ) THEN + DO jl=1,jpl + dqns_ice(:,:,jl) = dqns_ice(:,:,jl) * xcplmask(:,:,0) + zdqns_ice(:,:,jl) * zmsk(:,:) + ENDDO + ELSE + dqns_ice(:,:,:) = zdqns_ice(:,:,:) + ENDIF + ! ! ========================= ! + SELECT CASE( TRIM( sn_rcv_qsr%cldes ) ) ! solar heat fluxes ! (qsr) + ! ! ========================= ! + CASE( 'oce only' ) + zqsr_tot(:,: ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) ) + ! For the Met Office the only sea ice solar flux is the transmitted qsr which is added onto zqsr_ice + ! further down. Therefore start zqsr_ice off at zero. + zqsr_ice(:,:,:) = 0._wp + CASE( 'conservative' ) + zqsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1) + IF( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN + zqsr_ice(:,:,1:jpl) = frcv(jpr_qsrice)%z3(:,:,1:jpl) + ELSE + ! Set all category values equal for the moment + DO jl = 1, jpl + zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) + END DO + ENDIF + CASE( 'oce and ice' ) + zqsr_tot(:,: ) = ziceld(:,:) * frcv(jpr_qsroce)%z3(:,:,1) + IF( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN + DO jl = 1, jpl + zqsr_tot(:,: ) = zqsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl) + zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl) + END DO + ELSE + zqsr_tot(:,:) = zqsr_tot(:,:) + picefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) + DO jl = 1, jpl + zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) + END DO + ENDIF + CASE( 'mixed oce-ice' ) + zqsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1) +! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** +! Create solar heat flux over ice using incoming solar heat flux and albedos +! ( see OASIS3 user guide, 5th edition, p39 ) + IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN + DO jl = 1, jpl + zqsr_ice(:,:,jl) = frcv(jpr_qsrmix)%z3(:,:,jl) * ( 1.- palbi(:,:,jl) ) & + & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) & + & + palbi (:,:,jl) * picefr(:,:) ) ) + END DO + ELSE + DO jl = 1, jpl + zqsr_ice(:,:,jl) = frcv(jpr_qsrmix)%z3(:,:, 1) * ( 1.- palbi(:,:,jl) ) & + & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) & + & + palbi (:,:,jl) * picefr(:,:) ) ) + END DO + ENDIF + CASE( 'none' ) ! Not available as for now: needs additional coding + ! ! since fields received, here zqsr_tot, are not defined with none option + CALL ctl_stop('STOP', 'sbccpl/sbc_cpl_ice_flx: some fields are not defined. Change sn_rcv_qsr value in namelist namsbc_cpl') + END SELECT + IF( ln_dm2dc .AND. ln_cpl ) THEN ! modify qsr to include the diurnal cycle + zqsr_tot(:,: ) = sbc_dcy( zqsr_tot(:,: ) ) + DO jl = 1, jpl + zqsr_ice(:,:,jl) = sbc_dcy( zqsr_ice(:,:,jl) ) + END DO + ENDIF + ! ! ========================= ! + ! ! Transmitted Qsr ! [W/m2] + ! ! ========================= ! + IF( .NOT.ln_cndflx ) THEN !== No conduction flux as surface forcing ==! + ! + IF( nn_qtrice == 0 ) THEN + ! formulation derived from Grenfell and Maykut (1977), where transmission rate + ! 1) depends on cloudiness + ! ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81) + ! ! should be real cloud fraction instead (as in the bulk) but needs to be read from atm. + ! 2) is 0 when there is any snow + ! 3) tends to 1 for thin ice + ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm + DO jl = 1, jpl + WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm + zqtr_ice_top(:,:,jl) = zqsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) ) + ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm + zqtr_ice_top(:,:,jl) = zqsr_ice(:,:,jl) * ztri(:,:) + ELSEWHERE ! zero when hs>0 + zqtr_ice_top(:,:,jl) = 0._wp + END WHERE + ENDDO + ELSEIF( nn_qtrice == 1 ) THEN + ! formulation is derived from the thesis of M. Lebrun (2019). + ! It represents the best fit using several sets of observations + ! It comes with snow conductivities adapted to freezing/melting conditions (see icethd_zdf_bl99.F90) + zqtr_ice_top(:,:,:) = 0.3_wp * zqsr_ice(:,:,:) + ENDIF + ! + ELSEIF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN !== conduction flux as surface forcing ==! + ! +!! SELECT CASE( TRIM( sn_rcv_qtrice%cldes ) ) +!! ! +!! ! ! ===> here we receive the qtr_ice_top array from the coupler +!! CASE ('coupled') +!! IF (ln_scale_ice_flux) THEN +!! WHERE( a_i(:,:,:) > 1.e-10_wp ) +!! zqtr_ice_top(:,:,:) = frcv(jpr_qtrice)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) +!! ELSEWHERE +!! zqtr_ice_top(:,:,:) = 0.0_wp +!! ENDWHERE +!! ELSE +!! zqtr_ice_top(:,:,:) = frcv(jpr_qtrice)%z3(:,:,:) +!! ENDIF +!! +!! ! Add retrieved transmitted solar radiation onto the ice and total solar radiation +!! zqsr_ice(:,:,:) = zqsr_ice(:,:,:) + zqtr_ice_top(:,:,:) +!! zqsr_tot(:,:) = zqsr_tot(:,:) + SUM( zqtr_ice_top(:,:,:) * a_i(:,:,:), dim=3 ) +!! +!! ! if we are not getting this data from the coupler then assume zero (fully opaque ice) +!! CASE ('none') + zqtr_ice_top(:,:,:) = 0._wp +!! END SELECT + ! + ENDIF + + IF( ln_mixcpl ) THEN + qsr_tot(:,:) = qsr(:,:) * ziceld(:,:) + SUM( qsr_ice(:,:,:) * a_i(:,:,:), dim=3 ) ! total flux from blk + qsr_tot(:,:) = qsr_tot(:,:) * xcplmask(:,:,0) + zqsr_tot(:,:) * zmsk(:,:) + DO jl = 1, jpl + qsr_ice (:,:,jl) = qsr_ice (:,:,jl) * xcplmask(:,:,0) + zqsr_ice (:,:,jl) * zmsk(:,:) + qtr_ice_top(:,:,jl) = qtr_ice_top(:,:,jl) * xcplmask(:,:,0) + zqtr_ice_top(:,:,jl) * zmsk(:,:) + END DO + ELSE + qsr_tot (:,: ) = zqsr_tot (:,: ) + qsr_ice (:,:,:) = zqsr_ice (:,:,:) + qtr_ice_top(:,:,:) = zqtr_ice_top(:,:,:) + ENDIF + + ! --- solar flux over ocean --- ! + ! note: ziceld cannot be = 0 since we limit the ice concentration to amax + zqsr_oce = 0._wp + WHERE( ziceld /= 0._wp ) zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i * zqsr_ice, dim=3 ) ) / ziceld(:,:) + + IF( ln_mixcpl ) THEN ; qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) + zqsr_oce(:,:)* zmsk(:,:) + ELSE ; qsr_oce(:,:) = zqsr_oce(:,:) ; ENDIF + + ! ! ================== ! + ! ! ice skin temp. ! + ! ! ================== ! + ! needed by Met Office + IF( srcv(jpr_ts_ice)%laction ) THEN + WHERE ( frcv(jpr_ts_ice)%z3(:,:,:) > 0.0 ) ; ztsu(:,:,:) = 0. + rt0 + ELSEWHERE( frcv(jpr_ts_ice)%z3(:,:,:) < -60. ) ; ztsu(:,:,:) = -60. + rt0 + ELSEWHERE ; ztsu(:,:,:) = frcv(jpr_ts_ice)%z3(:,:,:) + rt0 + END WHERE + ! + IF( ln_mixcpl ) THEN + DO jl=1,jpl + pist(:,:,jl) = pist(:,:,jl) * xcplmask(:,:,0) + ztsu(:,:,jl) * zmsk(:,:) + ENDDO + ELSE + pist(:,:,:) = ztsu(:,:,:) + ENDIF + ! + ENDIF + ! +#endif + ! + END SUBROUTINE sbc_cpl_ice_flx + + + SUBROUTINE sbc_cpl_snd( kt, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_cpl_snd *** + !! + !! ** Purpose : provide the ocean-ice informations to the atmosphere + !! + !! ** Method : send to the atmosphere through a call to cpl_snd + !! all the needed fields (as defined in sbc_cpl_init) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean model time level index + ! + INTEGER :: ji, jj, jl ! dummy loop indices + INTEGER :: isec, info ! local integer + REAL(wp) :: zumax, zvmax + REAL(wp), DIMENSION(jpi,jpj) :: zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 + REAL(wp), DIMENSION(jpi,jpj,jpl) :: ztmp3, ztmp4 + !!---------------------------------------------------------------------- + ! + isec = ( kt - nit000 ) * NINT( rn_Dt ) ! date of exchanges + info = OASIS_idle + + zfr_l(:,:) = 1.- fr_i(:,:) + ! ! ------------------------- ! + ! ! Surface temperature ! in Kelvin + ! ! ------------------------- ! + IF( ssnd(jps_toce)%laction .OR. ssnd(jps_tice)%laction .OR. ssnd(jps_tmix)%laction ) THEN + + IF( nn_components == jp_iam_oce ) THEN + ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) ! send temperature as it is (potential or conservative) -> use of l_useCT on the received part + ELSE + ! we must send the surface potential temperature + IF( l_useCT ) THEN ; ztmp1(:,:) =eos_pt_from_ct( CASTSP(ts(:,:,1,jp_tem,Kmm)), CASTSP(ts(:,:,1,jp_sal,Kmm)) ) + ELSE ; ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) + ENDIF + ! + SELECT CASE( sn_snd_temp%cldes) + CASE( 'oce only' ) ; ztmp1(:,:) = ztmp1(:,:) + rt0 + CASE( 'oce and ice' ) ; ztmp1(:,:) = ztmp1(:,:) + rt0 + SELECT CASE( sn_snd_temp%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) + CASE( 'no' ) + WHERE( SUM( a_i, dim=3 ) /= 0. ) + ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 ) + ELSEWHERE + ztmp3(:,:,1) = rt0 + END WHERE + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) + END SELECT + CASE( 'weighted oce and ice' ) ; ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:) + SELECT CASE( sn_snd_temp%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + CASE( 'no' ) + ztmp3(:,:,:) = 0.0 + DO jl=1,jpl + ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) + ENDDO + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) + END SELECT + CASE( 'oce and weighted ice') ; ztmp1(:,:) = ts(:,:,1,jp_tem,Kmm) + rt0 + SELECT CASE( sn_snd_temp%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + CASE( 'no' ) + ztmp3(:,:,:) = 0.0 + DO jl=1,jpl + ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) + ENDDO + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) + END SELECT + CASE( 'mixed oce-ice' ) + ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:) + DO jl=1,jpl + ztmp1(:,:) = ztmp1(:,:) + tn_ice(:,:,jl) * a_i(:,:,jl) + ENDDO + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%cldes' ) + END SELECT + ENDIF + IF( ssnd(jps_toce)%laction ) CALL cpl_snd( jps_toce, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_tice)%laction ) CALL cpl_snd( jps_tice, isec, ztmp3, info ) + IF( ssnd(jps_tmix)%laction ) CALL cpl_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + ENDIF + ! + ! ! ------------------------- ! + ! ! 1st layer ice/snow temp. ! + ! ! ------------------------- ! +#if defined key_si3 + ! needed by Met Office + IF( ssnd(jps_ttilyr)%laction) THEN + SELECT CASE( sn_snd_ttilyr%cldes) + CASE ('weighted ice') + ztmp3(:,:,1:jpl) = t1_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ttilyr%cldes' ) + END SELECT + IF( ssnd(jps_ttilyr)%laction ) CALL cpl_snd( jps_ttilyr, isec, ztmp3, info ) + ENDIF +#endif + ! ! ------------------------- ! + ! ! Albedo ! + ! ! ------------------------- ! + IF( ssnd(jps_albice)%laction ) THEN ! ice + SELECT CASE( sn_snd_alb%cldes ) + CASE( 'ice' ) + SELECT CASE( sn_snd_alb%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) + CASE( 'no' ) + WHERE( SUM( a_i, dim=3 ) /= 0. ) + ztmp1(:,:) = SUM( alb_ice (:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) / SUM( a_i(:,:,1:jpl), dim=3 ) + ELSEWHERE + ztmp1(:,:) = alb_oce_mix(:,:) + END WHERE + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%clcat' ) + END SELECT + CASE( 'weighted ice' ) ; + SELECT CASE( sn_snd_alb%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + CASE( 'no' ) + WHERE( fr_i (:,:) > 0. ) + ztmp1(:,:) = SUM ( alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) + ELSEWHERE + ztmp1(:,:) = 0. + END WHERE + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ice%clcat' ) + END SELECT + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) + END SELECT + + SELECT CASE( sn_snd_alb%clcat ) + CASE( 'yes' ) + CALL cpl_snd( jps_albice, isec, ztmp3, info ) !-> MV this has never been checked in coupled mode + CASE( 'no' ) + CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + END SELECT + ENDIF + + IF( ssnd(jps_albmix)%laction ) THEN ! mixed ice-ocean + ztmp1(:,:) = alb_oce_mix(:,:) * zfr_l(:,:) + DO jl = 1, jpl + ztmp1(:,:) = ztmp1(:,:) + alb_ice(:,:,jl) * a_i(:,:,jl) + END DO + CALL cpl_snd( jps_albmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + ENDIF + ! ! ------------------------- ! + ! ! Ice fraction & Thickness ! + ! ! ------------------------- ! + ! Send ice fraction field to atmosphere + IF( ssnd(jps_fice)%laction ) THEN + SELECT CASE( sn_snd_thick%clcat ) + CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(:,:,1:jpl) + CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(:,: ) + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) + END SELECT + CALL cpl_snd( jps_fice, isec, ztmp3, info ) + ENDIF + +#if defined key_si3 || defined key_cice + ! If this coupling was successful then save ice fraction for use between coupling points. + ! This is needed for some calculations where the ice fraction at the last coupling point + ! is needed. + IF( info == OASIS_Sent .OR. info == OASIS_ToRest .OR. & + & info == OASIS_SentOut .OR. info == OASIS_ToRestOut ) THEN + IF ( sn_snd_thick%clcat == 'yes' ) THEN + a_i_last_couple(:,:,1:jpl) = a_i(:,:,1:jpl) + ENDIF + ENDIF +#endif + + IF( ssnd(jps_fice1)%laction ) THEN + SELECT CASE( sn_snd_thick1%clcat ) + CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(:,:,1:jpl) + CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(:,: ) + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick1%clcat' ) + END SELECT + CALL cpl_snd( jps_fice1, isec, ztmp3, info ) + ENDIF + + ! Send ice fraction field to OCE (sent by SAS in SAS-OCE coupling) + IF( ssnd(jps_fice2)%laction ) THEN + ztmp3(:,:,1) = fr_i(:,:) + IF( ssnd(jps_fice2)%laction ) CALL cpl_snd( jps_fice2, isec, ztmp3, info ) + ENDIF + + ! Send ice and snow thickness field + IF( ssnd(jps_hice)%laction .OR. ssnd(jps_hsnw)%laction ) THEN + SELECT CASE( sn_snd_thick%cldes) + CASE( 'none' ) ! nothing to do + CASE( 'weighted ice and snow' ) + SELECT CASE( sn_snd_thick%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = h_i(:,:,1:jpl) * a_i(:,:,1:jpl) + ztmp4(:,:,1:jpl) = h_s(:,:,1:jpl) * a_i(:,:,1:jpl) + CASE( 'no' ) + ztmp3(:,:,:) = 0.0 ; ztmp4(:,:,:) = 0.0 + DO jl=1,jpl + ztmp3(:,:,1) = ztmp3(:,:,1) + h_i(:,:,jl) * a_i(:,:,jl) + ztmp4(:,:,1) = ztmp4(:,:,1) + h_s(:,:,jl) * a_i(:,:,jl) + ENDDO + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) + END SELECT + CASE( 'ice and snow' ) + SELECT CASE( sn_snd_thick%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = h_i(:,:,1:jpl) + ztmp4(:,:,1:jpl) = h_s(:,:,1:jpl) + CASE( 'no' ) + WHERE( SUM( a_i, dim=3 ) /= 0. ) + ztmp3(:,:,1) = SUM( h_i * a_i, dim=3 ) / SUM( a_i, dim=3 ) + ztmp4(:,:,1) = SUM( h_s * a_i, dim=3 ) / SUM( a_i, dim=3 ) + ELSEWHERE + ztmp3(:,:,1) = 0. + ztmp4(:,:,1) = 0. + END WHERE + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) + END SELECT + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%cldes' ) + END SELECT + IF( ssnd(jps_hice)%laction ) CALL cpl_snd( jps_hice, isec, ztmp3, info ) + IF( ssnd(jps_hsnw)%laction ) CALL cpl_snd( jps_hsnw, isec, ztmp4, info ) + ENDIF + +#if defined key_si3 + ! ! ------------------------- ! + ! ! Ice melt ponds ! + ! ! ------------------------- ! + ! needed by Met Office: 1) fraction of ponded ice 2) local/actual pond depth + IF( ssnd(jps_a_p)%laction .OR. ssnd(jps_ht_p)%laction ) THEN + SELECT CASE( sn_snd_mpnd%cldes) + CASE( 'ice only' ) + SELECT CASE( sn_snd_mpnd%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = a_ip_eff(:,:,1:jpl) + ztmp4(:,:,1:jpl) = h_ip(:,:,1:jpl) + CASE( 'no' ) + ztmp3(:,:,:) = 0.0 + ztmp4(:,:,:) = 0.0 + DO jl=1,jpl + ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip_frac(:,:,jpl) + ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(:,:,jpl) + ENDDO + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%clcat' ) + END SELECT + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%cldes' ) + END SELECT + IF( ssnd(jps_a_p)%laction ) CALL cpl_snd( jps_a_p , isec, ztmp3, info ) + IF( ssnd(jps_ht_p)%laction ) CALL cpl_snd( jps_ht_p, isec, ztmp4, info ) + ENDIF + ! + ! ! ------------------------- ! + ! ! Ice conductivity ! + ! ! ------------------------- ! + ! needed by Met Office + IF( ssnd(jps_kice)%laction ) THEN + SELECT CASE( sn_snd_cond%cldes) + CASE( 'weighted ice' ) + SELECT CASE( sn_snd_cond%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + CASE( 'no' ) + ztmp3(:,:,:) = 0.0 + DO jl=1,jpl + ztmp3(:,:,1) = ztmp3(:,:,1) + cnd_ice(:,:,jl) * a_i(:,:,jl) + ENDDO + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_cond%clcat' ) + END SELECT + CASE( 'ice only' ) + ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_cond%cldes' ) + END SELECT + IF( ssnd(jps_kice)%laction ) CALL cpl_snd( jps_kice, isec, ztmp3, info ) + ENDIF +#endif + + ! ! ------------------------- ! + ! ! CO2 flux from PISCES ! + ! ! ------------------------- ! + IF( ssnd(jps_co2)%laction .AND. l_co2cpl ) THEN + ztmp1(:,:) = oce_co2(:,:) * 1000. ! conversion in molC/m2/s + CALL cpl_snd( jps_co2, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ) , info ) + ENDIF + ! + ! ! ------------------------- ! + IF( ssnd(jps_ocx1)%laction ) THEN ! Surface current ! + ! ! ------------------------- ! + ! + ! j+1 j -----V---F + ! surface velocity always sent from T point ! | + ! j | T U + ! | | + ! j j-1 -I-------| + ! (for I) | | + ! i-1 i i + ! i i+1 (for I) + IF( nn_components == jp_iam_oce ) THEN + zotx1(:,:) = uu(:,:,1,Kmm) + zoty1(:,:) = vv(:,:,1,Kmm) + ELSE + SELECT CASE( TRIM( sn_snd_crt%cldes ) ) + CASE( 'oce only' ) ! C-grid ==> T + DO_2D( 0, 0, 0, 0 ) + zotx1(ji,jj) = 0.5 * ( uu(ji,jj,1,Kmm) + uu(ji-1,jj ,1,Kmm) ) + zoty1(ji,jj) = 0.5 * ( vv(ji,jj,1,Kmm) + vv(ji ,jj-1,1,Kmm) ) + END_2D + CASE( 'weighted oce and ice' ) ! Ocean and Ice on C-grid ==> T + DO_2D( 0, 0, 0, 0 ) + zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) + zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) + zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) + zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) + END_2D + CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) + CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T + DO_2D( 0, 0, 0, 0 ) + zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) & + & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) + zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) & + & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) + END_2D + END SELECT + CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp ) + ! + ENDIF + ! + ! + IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components + ! ! Ocean component + CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component + CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component + zotx1(:,:) = ztmp1(:,:) ! overwrite the components + zoty1(:,:) = ztmp2(:,:) + IF( ssnd(jps_ivx1)%laction ) THEN ! Ice component + CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component + CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component + zitx1(:,:) = ztmp1(:,:) ! overwrite the components + zity1(:,:) = ztmp2(:,:) + ENDIF + ENDIF + ! + ! spherical coordinates to cartesian -> 2 components to 3 components + IF( TRIM( sn_snd_crt%clvref ) == 'cartesian' ) THEN + ztmp1(:,:) = zotx1(:,:) ! ocean currents + ztmp2(:,:) = zoty1(:,:) + CALL oce2geo ( ztmp1, ztmp2, 'T', zotx1, zoty1, zotz1 ) + ! + IF( ssnd(jps_ivx1)%laction ) THEN ! ice velocities + ztmp1(:,:) = zitx1(:,:) + ztmp1(:,:) = zity1(:,:) + CALL oce2geo ( ztmp1, ztmp2, 'T', zitx1, zity1, zitz1 ) + ENDIF + ENDIF + ! + IF( ssnd(jps_ocx1)%laction ) CALL cpl_snd( jps_ocx1, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid + IF( ssnd(jps_ocy1)%laction ) CALL cpl_snd( jps_ocy1, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid + IF( ssnd(jps_ocz1)%laction ) CALL cpl_snd( jps_ocz1, isec, RESHAPE ( zotz1, (/jpi,jpj,1/) ), info ) ! ocean z current 1st grid + ! + IF( ssnd(jps_ivx1)%laction ) CALL cpl_snd( jps_ivx1, isec, RESHAPE ( zitx1, (/jpi,jpj,1/) ), info ) ! ice x current 1st grid + IF( ssnd(jps_ivy1)%laction ) CALL cpl_snd( jps_ivy1, isec, RESHAPE ( zity1, (/jpi,jpj,1/) ), info ) ! ice y current 1st grid + IF( ssnd(jps_ivz1)%laction ) CALL cpl_snd( jps_ivz1, isec, RESHAPE ( zitz1, (/jpi,jpj,1/) ), info ) ! ice z current 1st grid + ! + ENDIF + ! + ! ! ------------------------- ! + ! ! Surface current to waves ! + ! ! ------------------------- ! + IF( ssnd(jps_ocxw)%laction .OR. ssnd(jps_ocyw)%laction ) THEN + ! + ! j+1 j -----V---F + ! surface velocity always sent from T point ! | + ! j | T U + ! | | + ! j j-1 -I-------| + ! (for I) | | + ! i-1 i i + ! i i+1 (for I) + SELECT CASE( TRIM( sn_snd_crtw%cldes ) ) + CASE( 'oce only' ) ! C-grid ==> T + DO_2D( 0, 0, 0, 0 ) + zotx1(ji,jj) = 0.5 * ( uu(ji,jj,1,Kmm) + uu(ji-1,jj ,1,Kmm) ) + zoty1(ji,jj) = 0.5 * ( vv(ji,jj,1,Kmm) + vv(ji , jj-1,1,Kmm) ) + END_2D + CASE( 'weighted oce and ice' ) ! Ocean and Ice on C-grid ==> T + DO_2D( 0, 0, 0, 0 ) + zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) + zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) + zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) + zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) + END_2D + CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) + CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T + DO_2D( 0, 0, 0, 0 ) + zotx1(ji,jj) = 0.5 * ( uu (ji,jj,1,Kmm) + uu (ji-1,jj ,1,Kmm) ) * zfr_l(ji,jj) & + & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) + zoty1(ji,jj) = 0.5 * ( vv (ji,jj,1,Kmm) + vv (ji ,jj-1,1,Kmm) ) * zfr_l(ji,jj) & + & + 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) + END_2D + END SELECT + CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp ) + ! + ! + IF( TRIM( sn_snd_crtw%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components + ! ! Ocean component + CALL rot_rep( zotx1, zoty1, ssnd(jps_ocxw)%clgrid, 'ij->e', ztmp1 ) ! 1st component + CALL rot_rep( zotx1, zoty1, ssnd(jps_ocxw)%clgrid, 'ij->n', ztmp2 ) ! 2nd component + zotx1(:,:) = ztmp1(:,:) ! overwrite the components + zoty1(:,:) = ztmp2(:,:) + IF( ssnd(jps_ivx1)%laction ) THEN ! Ice component + CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component + CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component + zitx1(:,:) = ztmp1(:,:) ! overwrite the components + zity1(:,:) = ztmp2(:,:) + ENDIF + ENDIF + ! +! ! spherical coordinates to cartesian -> 2 components to 3 components +! IF( TRIM( sn_snd_crtw%clvref ) == 'cartesian' ) THEN +! ztmp1(:,:) = zotx1(:,:) ! ocean currents +! ztmp2(:,:) = zoty1(:,:) +! CALL oce2geo ( ztmp1, ztmp2, 'T', zotx1, zoty1, zotz1 ) +! ! +! IF( ssnd(jps_ivx1)%laction ) THEN ! ice velocities +! ztmp1(:,:) = zitx1(:,:) +! ztmp1(:,:) = zity1(:,:) +! CALL oce2geo ( ztmp1, ztmp2, 'T', zitx1, zity1, zitz1 ) +! ENDIF +! ENDIF + ! + IF( ssnd(jps_ocxw)%laction ) CALL cpl_snd( jps_ocxw, isec, RESHAPE ( zotx1, (/jpi,jpj,1/) ), info ) ! ocean x current 1st grid + IF( ssnd(jps_ocyw)%laction ) CALL cpl_snd( jps_ocyw, isec, RESHAPE ( zoty1, (/jpi,jpj,1/) ), info ) ! ocean y current 1st grid + ! + ENDIF + ! + IF( ssnd(jps_ficet)%laction ) THEN + CALL cpl_snd( jps_ficet, isec, RESHAPE ( fr_i, (/jpi,jpj,1/) ), info ) + ENDIF + ! ! ------------------------- ! + ! ! Water levels to waves ! + ! ! ------------------------- ! + IF( ssnd(jps_wlev)%laction ) THEN + IF( ln_apr_dyn ) THEN + IF( kt /= nit000 ) THEN + ztmp1(:,:) = ssh(:,:,Kbb) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) + ELSE + ztmp1(:,:) = ssh(:,:,Kbb) + ENDIF + ELSE + ztmp1(:,:) = ssh(:,:,Kmm) + ENDIF + CALL cpl_snd( jps_wlev , isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + ENDIF + ! + ! Fields sent by OCE to SAS when doing OCE<->SAS coupling + ! ! SSH + IF( ssnd(jps_ssh )%laction ) THEN + ! ! removed inverse barometer ssh when Patm + ! forcing is used (for sea-ice dynamics) + IF( ln_apr_dyn ) THEN ; ztmp1(:,:) = ssh(:,:,Kbb) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) + ELSE ; ztmp1(:,:) = ssh(:,:,Kmm) + ENDIF + CALL cpl_snd( jps_ssh , isec, RESHAPE ( ztmp1 , (/jpi,jpj,1/) ), info ) + + ENDIF + ! ! SSS + IF( ssnd(jps_soce )%laction ) THEN + CALL cpl_snd( jps_soce , isec, CASTSP(RESHAPE ( ts(:,:,1,jp_sal,Kmm), (/jpi,jpj,1/) )), info ) + ENDIF + ! ! first T level thickness + IF( ssnd(jps_e3t1st )%laction ) THEN + CALL cpl_snd( jps_e3t1st, isec, CASTSP(RESHAPE ( e3t(:,:,1,Kmm) , (/jpi,jpj,1/) )), info ) + ENDIF + ! ! Qsr fraction + IF( ssnd(jps_fraqsr)%laction ) THEN + CALL cpl_snd( jps_fraqsr, isec, RESHAPE ( fraqsr_1lev(:,:) , (/jpi,jpj,1/) ), info ) + ENDIF + ! + ! Fields sent by SAS to OCE when OASIS coupling + ! ! Solar heat flux + IF( ssnd(jps_qsroce)%laction ) CALL cpl_snd( jps_qsroce, isec, RESHAPE ( qsr , (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_qnsoce)%laction ) CALL cpl_snd( jps_qnsoce, isec, RESHAPE ( qns , (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_oemp )%laction ) CALL cpl_snd( jps_oemp , isec, RESHAPE ( emp , (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_sflx )%laction ) CALL cpl_snd( jps_sflx , isec, RESHAPE ( sfx , (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_otx1 )%laction ) CALL cpl_snd( jps_otx1 , isec, RESHAPE ( utau, (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_oty1 )%laction ) CALL cpl_snd( jps_oty1 , isec, RESHAPE ( vtau, (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_rnf )%laction ) CALL cpl_snd( jps_rnf , isec, RESHAPE ( rnf , (/jpi,jpj,1/) ), info ) + IF( ssnd(jps_taum )%laction ) CALL cpl_snd( jps_taum , isec, RESHAPE ( taum, (/jpi,jpj,1/) ), info ) + +#if defined key_si3 + ! ! ------------------------- ! + ! ! Sea surface freezing temp ! + ! ! ------------------------- ! + ! needed by Met Office + CALL eos_fzp(ts(:,:,1,jp_sal,Kmm), sstfrz) + ztmp1(:,:) = sstfrz(:,:) + rt0 + IF( ssnd(jps_sstfrz)%laction ) CALL cpl_snd( jps_sstfrz, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info) +#endif + ! + END SUBROUTINE sbc_cpl_snd + + !!====================================================================== +END MODULE sbccpl \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcdcy.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcdcy.F90 new file mode 100644 index 0000000..0372d38 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcdcy.F90 @@ -0,0 +1,269 @@ +MODULE sbcdcy + !!====================================================================== + !! *** MODULE sbcdcy *** + !! Ocean forcing: compute the diurnal cycle + !!====================================================================== + !! History : OPA ! 2005-02 (D. Bernie) Original code + !! NEMO 2.0 ! 2006-02 (S. Masson, G. Madec) adaptation to NEMO + !! 3.1 ! 2009-07 (J.M. Molines) adaptation to v3.1 + !! 4.* ! 2019-10 (L. Brodeau) nothing really new, but the routine + !! ! "sbc_dcy_param" has been extracted from old function "sbc_dcy" + !! ! => this allows the warm-layer param of COARE3* to know the time + !! ! of dawn and dusk even if "ln_dm2dc=.false." (rdawn_dcy & rdusk_dcy + !! ! are now public) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_dcy : solar flux at kt from daily mean, taking diurnal cycle into account + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE phycst ! ocean physics + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + INTEGER, PUBLIC :: nday_qsr !: day when parameters were computed + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: raa , rbb , rcc , rab ! diurnal cycle parameters + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: rtmd, rscal ! - - - + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: rdawn_dcy, rdusk_dcy ! - - - + + PUBLIC sbc_dcy ! routine called by sbc + PUBLIC sbc_dcy_param ! routine used here and called by warm-layer parameterization (sbcblk_skin_coare*) + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcdcy.F90 13483 2020-09-17 08:24:00Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_dcy_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_dcy_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( raa (jpi,jpj) , rbb (jpi,jpj) , rcc (jpi,jpj) , rab (jpi,jpj) , & + & rtmd(jpi,jpj) , rdawn_dcy(jpi,jpj) , rdusk_dcy(jpi,jpj) , rscal(jpi,jpj) , STAT=sbc_dcy_alloc ) + ! + CALL mpp_sum ( 'sbcdcy', sbc_dcy_alloc ) + IF( sbc_dcy_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_dcy_alloc: failed to allocate arrays' ) + END FUNCTION sbc_dcy_alloc + + + FUNCTION sbc_dcy( pqsrin, l_mask ) RESULT( zqsrout ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_dcy *** + !! + !! ** Purpose : introduce a diurnal cycle of qsr from daily values + !! + !! ** Method : see Appendix A of Bernie et al. 2007. + !! + !! ** Action : redistribute daily QSR on each time step following the diurnal cycle + !! + !! reference : Bernie, DJ, E Guilyardi, G Madec, JM Slingo, and SJ Woolnough, 2007 + !! Impact of resolving the diurnal cycle in an ocean--atmosphere GCM. + !! Part 1: a diurnally forced OGCM. Climate Dynamics 29:6, 575-590. + !!---------------------------------------------------------------------- + LOGICAL , OPTIONAL , INTENT(in) :: l_mask ! use the routine for night mask computation + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqsrin ! input daily QSR flux + REAL(wp), DIMENSION(jpi,jpj) :: zqsrout ! output QSR flux with diurnal cycle + !! + INTEGER :: ji, jj ! dummy loop indices + INTEGER, DIMENSION(jpi,jpj) :: imask_night ! night mask + REAL(wp) :: zlo, zup, zlousd, zupusd + REAL(wp) :: ztmp, ztmp1, ztmp2 + REAL(wp) :: ztmpm, ztmpm1, ztmpm2 + !!--------------------------------------------------------------------- + ! + ! Initialization + ! -------------- + ! When are we during the day (from 0 to 1) + zlo = ( REAL(nsec_day, wp) - 0.5_wp * rn_Dt ) / rday + zup = zlo + ( REAL(nn_fsbc, wp) * rn_Dt ) / rday + ! + IF( nday_qsr == -1 ) THEN ! first time step only + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_dcy : introduce diurnal cycle from daily mean qsr' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,*) + ENDIF + ENDIF + + ! Setting parameters for each new day: + CALL sbc_dcy_param() + + !CALL iom_put( "rdusk_dcy", rdusk_dcy(:,:)*tmask(:,:,1) ) !LB + !CALL iom_put( "rdawn_dcy", rdawn_dcy(:,:)*tmask(:,:,1) ) !LB + !CALL iom_put( "rscal_dcy", rscal(:,:)*tmask(:,:,1) ) !LB + + + ! 3. update qsr with the diurnal cycle + ! ------------------------------------ + + imask_night(:,:) = 0 + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ztmpm = 0._wp + IF( ABS(rab(ji,jj)) < 1. ) THEN ! day duration is less than 24h + ! + IF( rdawn_dcy(ji,jj) < rdusk_dcy(ji,jj) ) THEN ! day time in one part + zlousd = MAX(zlo, rdawn_dcy(ji,jj)) + zlousd = MIN(zlousd, zup) + zupusd = MIN(zup, rdusk_dcy(ji,jj)) + zupusd = MAX(zupusd, zlo) + ztmp = fintegral(zlousd, zupusd, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + zqsrout(ji,jj) = pqsrin(ji,jj) * ztmp * rscal(ji,jj) + ztmpm = zupusd - zlousd + IF( ztmpm .EQ. 0 ) imask_night(ji,jj) = 1 + ! + ELSE ! day time in two parts + zlousd = MIN(zlo, rdusk_dcy(ji,jj)) + zupusd = MIN(zup, rdusk_dcy(ji,jj)) + ztmp1 = fintegral(zlousd, zupusd, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + ztmpm1=zupusd-zlousd + zlousd = MAX(zlo, rdawn_dcy(ji,jj)) + zupusd = MAX(zup, rdawn_dcy(ji,jj)) + ztmp2 = fintegral(zlousd, zupusd, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + ztmpm2 =zupusd-zlousd + ztmp = ztmp1 + ztmp2 + ztmpm = ztmpm1 + ztmpm2 + zqsrout(ji,jj) = pqsrin(ji,jj) * ztmp * rscal(ji,jj) + IF(ztmpm .EQ. 0.) imask_night(ji,jj) = 1 + ENDIF + ELSE ! 24h light or 24h night + ! + IF( raa(ji,jj) > rbb(ji,jj) ) THEN ! 24h day + ztmp = fintegral(zlo, zup, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + zqsrout(ji,jj) = pqsrin(ji,jj) * ztmp * rscal(ji,jj) + imask_night(ji,jj) = 0 + ! + ELSE ! No day + zqsrout(ji,jj) = 0.0_wp + imask_night(ji,jj) = 1 + ENDIF + ENDIF + END_2D + ! + IF( PRESENT(l_mask) .AND. l_mask ) THEN + zqsrout(:,:) = float(imask_night(:,:)) + ENDIF + ! + END FUNCTION sbc_dcy + + + SUBROUTINE sbc_dcy_param( ) + !! + INTEGER :: ji, jj ! dummy loop indices + !INTEGER, DIMENSION(jpi,jpj) :: imask_night ! night mask + REAL(wp) :: zdsws, zdecrad, ztx, zsin, zcos + REAL(wp) :: ztmp, ztest + !---------------------------statement functions------------------------ + ! + IF( nday_qsr == -1 ) THEN ! first time step only + ! allocate sbcdcy arrays + IF( sbc_dcy_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_dcy_alloc : unable to allocate arrays' ) + ! Compute rcc needed to compute the time integral of the diurnal cycle + rcc(:,:) = rad * glamt(:,:) - rpi + ! time of midday + rtmd(:,:) = 0.5_wp - glamt(:,:) / 360._wp + rtmd(:,:) = MOD( (rtmd(:,:) + 1._wp) , 1._wp) + ENDIF + + ! If this is a new day, we have to update the dawn, dusk and scaling function + !---------------------- + + ! 2.1 dawn and dusk + + ! nday is the number of days since the beginning of the current month + IF( nday_qsr /= nday ) THEN + ! save the day of the year and the daily mean of qsr + nday_qsr = nday + ! number of days since the previous winter solstice (supposed to be always 21 December) + zdsws = REAL(11 + nday_year, wp) + ! declination of the earths orbit + zdecrad = (-23.5_wp * rad) * COS( zdsws * 2._wp*rpi / REAL(nyear_len(1),wp) ) + ! Compute A and B needed to compute the time integral of the diurnal cycle + + zsin = SIN( zdecrad ) ; zcos = COS( zdecrad ) + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ztmp = rad * gphit(ji,jj) + raa(ji,jj) = SIN( ztmp ) * zsin + rbb(ji,jj) = COS( ztmp ) * zcos + END_2D + ! Compute the time of dawn and dusk + + ! rab to test if the day time is equal to 0, less than 24h of full day + rab(:,:) = -raa(:,:) / rbb(:,:) + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + IF( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h + ! When is it night? + ztx = 1._wp/(2._wp*rpi) * (ACOS(rab(ji,jj)) - rcc(ji,jj)) + ztest = -rbb(ji,jj) * SIN( rcc(ji,jj) + 2._wp*rpi * ztx ) + ! is it dawn or dusk? + IF( ztest > 0._wp ) THEN + rdawn_dcy(ji,jj) = ztx + rdusk_dcy(ji,jj) = rtmd(ji,jj) + ( rtmd(ji,jj) - rdawn_dcy(ji,jj) ) + ELSE + rdusk_dcy(ji,jj) = ztx + rdawn_dcy(ji,jj) = rtmd(ji,jj) - ( rdusk_dcy(ji,jj) - rtmd(ji,jj) ) + ENDIF + ELSE + rdawn_dcy(ji,jj) = rtmd(ji,jj) + 0.5_wp + rdusk_dcy(ji,jj) = rdawn_dcy(ji,jj) + ENDIF + END_2D + rdawn_dcy(:,:) = MOD( (rdawn_dcy(:,:) + 1._wp), 1._wp ) + rdusk_dcy(:,:) = MOD( (rdusk_dcy(:,:) + 1._wp), 1._wp ) + ! 2.2 Compute the scaling function: + ! S* = the inverse of the time integral of the diurnal cycle from dawn to dusk + ! Avoid possible infinite scaling factor, associated with very short daylight + ! periods, by ignoring periods less than 1/1000th of a day (ticket #1040) + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + IF( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h + rscal(ji,jj) = 0.0_wp + IF( rdawn_dcy(ji,jj) < rdusk_dcy(ji,jj) ) THEN ! day time in one part + IF( (rdusk_dcy(ji,jj) - rdawn_dcy(ji,jj) ) .ge. 0.001_wp ) THEN + rscal(ji,jj) = fintegral(rdawn_dcy(ji,jj), rdusk_dcy(ji,jj), raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + rscal(ji,jj) = 1._wp / rscal(ji,jj) + ENDIF + ELSE ! day time in two parts + IF( (rdusk_dcy(ji,jj) + (1._wp - rdawn_dcy(ji,jj)) ) .ge. 0.001_wp ) THEN + rscal(ji,jj) = fintegral(0._wp, rdusk_dcy(ji,jj), raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) & + & + fintegral(rdawn_dcy(ji,jj), 1._wp, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + rscal(ji,jj) = 1. / rscal(ji,jj) + ENDIF + ENDIF + ELSE + IF( raa(ji,jj) > rbb(ji,jj) ) THEN ! 24h day + rscal(ji,jj) = fintegral(0._wp, 1._wp, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + rscal(ji,jj) = 1._wp / rscal(ji,jj) + ELSE ! No day + rscal(ji,jj) = 0.0_wp + ENDIF + ENDIF + END_2D + ! + ztmp = rday / ( rn_Dt * REAL(nn_fsbc, wp) ) + rscal(:,:) = rscal(:,:) * ztmp + ! + ENDIF !IF( nday_qsr /= nday ) + ! + END SUBROUTINE sbc_dcy_param + + + FUNCTION fintegral( pt1, pt2, paaa, pbbb, pccc ) + REAL(wp), INTENT(in) :: pt1, pt2, paaa, pbbb, pccc + REAL(wp) :: fintegral + fintegral = paaa * pt2 + 1._wp/(2._wp*rpi) * pbbb * SIN(pccc + 2._wp*rpi*pt2) & + & - paaa * pt1 - 1._wp/(2._wp*rpi) * pbbb * SIN(pccc + 2._wp*rpi*pt1) + END FUNCTION fintegral + + !!====================================================================== +END MODULE sbcdcy \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcflx.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcflx.F90 new file mode 100644 index 0000000..503e1e5 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcflx.F90 @@ -0,0 +1,189 @@ +MODULE sbcflx + !!====================================================================== + !! *** MODULE sbcflx *** + !! Ocean forcing: momentum, heat and freshwater flux formulation + !!===================================================================== + !! History : 1.0 ! 2006-06 (G. Madec) Original code + !! 3.3 ! 2010-10 (S. Masson) add diurnal cycle + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! namflx : flux formulation namlist + !! sbc_flx : flux formulation as ocean surface boundary condition (forced mode, fluxes read in NetCDF files) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface boundary condition: ocean fields + USE trc_oce ! share SMS/Ocean variables + USE sbcdcy ! surface boundary condition: diurnal cycle on qsr + USE phycst ! physical constants + ! + USE fldread ! read input fields + USE iom ! IOM library + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_flx ! routine called by step.F90 + + INTEGER , PARAMETER :: jp_utau = 1 ! index of wind stress (i-component) file + INTEGER , PARAMETER :: jp_vtau = 2 ! index of wind stress (j-component) file + INTEGER , PARAMETER :: jp_qtot = 3 ! index of total (non solar+solar) heat file + INTEGER , PARAMETER :: jp_qsr = 4 ! index of solar heat file + INTEGER , PARAMETER :: jp_emp = 5 ! index of evaporation-precipation file + !!INTEGER , PARAMETER :: jp_sfx = 6 ! index of salt flux flux + INTEGER , PARAMETER :: jpfld = 5 !! 6 ! maximum number of files to read + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read) + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcflx.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_flx( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_flx *** + !! + !! ** Purpose : provide at each time step the surface ocean fluxes + !! (momentum, heat, freshwater and runoff) + !! + !! ** Method : - READ each fluxes in NetCDF files: + !! i-component of the stress utau (N/m2) + !! j-component of the stress vtau (N/m2) + !! net downward heat flux qtot (watt/m2) + !! net downward radiative flux qsr (watt/m2) + !! net upward freshwater (evapo - precip) emp (kg/m2/s) + !! salt flux sfx (pss*dh*rho/dt => g/m2/s) + !! + !! CAUTION : - never mask the surface stress fields + !! - the stress is assumed to be in the (i,j) mesh referential + !! + !! ** Action : update at each time-step + !! - utau, vtau i- and j-component of the wind stress + !! - taum wind stress module at T-point + !! - wndm 10m wind module at T-point + !! - qns non solar heat flux including heat flux due to emp + !! - qsr solar heat flux + !! - emp upward mass flux (evap. - precip.) + !! - sfx salt flux; set to zero at nit000 but possibly non-zero + !! if ice + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + !! + INTEGER :: ji, jj, jf ! dummy indices + INTEGER :: ierror ! return error code + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp) :: zfact ! temporary scalar + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: ztx, zty, zmod, zcoef ! temporary variables + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of flx files + TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist information structures + TYPE(FLD_N) :: sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp !!, sn_sfx ! informations about the fields to be read + NAMELIST/namsbc_flx/ cn_dir, sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp !!, sn_sfx + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN ! First call kt=nit000 + ! set file information + READ ( numnam_ref, namsbc_flx, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_flx in reference namelist' ) + + READ ( numnam_cfg, namsbc_flx, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_flx in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_flx ) + ! + ! ! check: do we plan to use ln_dm2dc with non-daily forcing? + IF( ln_dm2dc .AND. sn_qsr%freqh /= 24. ) & + & CALL ctl_stop( 'sbc_blk_core: ln_dm2dc can be activated only with daily short-wave forcing' ) + ! + ! ! store namelist information in an array + slf_i(jp_utau) = sn_utau ; slf_i(jp_vtau) = sn_vtau + slf_i(jp_qtot) = sn_qtot ; slf_i(jp_qsr ) = sn_qsr + slf_i(jp_emp ) = sn_emp !! ; slf_i(jp_sfx ) = sn_sfx + ! + ALLOCATE( sf(jpfld), STAT=ierror ) ! set sf structure + IF( ierror > 0 ) THEN + CALL ctl_stop( 'sbc_flx: unable to allocate sf structure' ) ; RETURN + ENDIF + DO ji= 1, jpfld + ALLOCATE( sf(ji)%fnow(jpi,jpj,1) ) + IF( slf_i(ji)%ln_tint ) ALLOCATE( sf(ji)%fdta(jpi,jpj,1,2) ) + END DO + ! ! fill sf with slf_i and control print + CALL fld_fill( sf, slf_i, cn_dir, 'sbc_flx', 'flux formulation for ocean surface boundary condition', 'namsbc_flx' ) + sf(jp_utau)%cltype = 'U' ; sf(jp_utau)%zsgn = -1._wp ! vector field at U point: overwrite default definition of cltype and zsgn + sf(jp_vtau)%cltype = 'V' ; sf(jp_vtau)%zsgn = -1._wp ! vector field at V point: overwrite default definition of cltype and zsgn + ! + ENDIF + + CALL fld_read( kt, nn_fsbc, sf ) ! input fields provided at the current time-step + + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! update ocean fluxes at each SBC frequency + + IF( ln_dm2dc ) THEN ! modify now Qsr to include the diurnal cycle + qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1) + ELSE + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + qsr(ji,jj) = sf(jp_qsr)%fnow(ji,jj,1) * tmask(ji,jj,1) + END_2D + ENDIF +#if defined key_top + IF( ln_trcdc2dm ) THEN ! diurnal cycle in TOP + IF( ln_dm2dc ) THEN + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + qsr_mean(ji,jj) = sf(jp_qsr)%fnow(ji,jj,1) * tmask(ji,jj,1) + END_2D + ELSE + ncpl_qsr_freq = sf(jp_qsr)%freqh * 3600 ! qsr_mean will be computed in TOP + ENDIF + ENDIF +#endif + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! set the ocean fluxes from read fields + utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1) * umask(ji,jj,1) + vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1) * vmask(ji,jj,1) + qns (ji,jj) = ( sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1) ) * tmask(ji,jj,1) + emp (ji,jj) = sf(jp_emp )%fnow(ji,jj,1) * tmask(ji,jj,1) + !!sfx (ji,jj) = sf(jp_sfx )%fnow(ji,jj,1) * tmask(ji,jj,1) + END_2D + ! ! add to qns the heat due to e-p + !!clem: I do not think it is needed + !!qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp ! mass flux is at SST + ! + IF( nitend-nit000 <= 100 .AND. lwp ) THEN ! control print (if less than 100 time-step asked) + WRITE(numout,*) + WRITE(numout,*) ' read daily momentum, heat and freshwater fluxes OK' + DO jf = 1, jpfld + IF( jf == jp_utau .OR. jf == jp_vtau ) zfact = 1. + IF( jf == jp_qtot .OR. jf == jp_qsr ) zfact = 0.1 + IF( jf == jp_emp ) zfact = 86400. + WRITE(numout,*) + WRITE(numout,*) ' day: ', ndastp , TRIM(sf(jf)%clvar), ' * ', zfact + END DO + ENDIF + ! + ENDIF + ! ! module of wind stress and wind speed at T-point + ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines + zcoef = 1. / ( zrhoa * zcdrag ) + DO_2D( 0, 0, 0, 0 ) + ztx = ( utau(ji-1,jj ) + utau(ji,jj) ) * 0.5_wp * ( 2._wp - MIN( umask(ji-1,jj ,1), umask(ji,jj,1) ) ) + zty = ( vtau(ji ,jj-1) + vtau(ji,jj) ) * 0.5_wp * ( 2._wp - MIN( vmask(ji ,jj-1,1), vmask(ji,jj,1) ) ) + zmod = SQRT( ztx * ztx + zty * zty ) * tmask(ji,jj,1) + taum(ji,jj) = zmod + wndm(ji,jj) = SQRT( zmod * zcoef ) !!clem: not used? + END_2D + ! + CALL lbc_lnk( 'sbcflx', taum, 'T', 1._wp, wndm, 'T', 1._wp ) + ! + END SUBROUTINE sbc_flx + + !!====================================================================== +END MODULE sbcflx \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcfwb.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcfwb.F90 new file mode 100644 index 0000000..3bb8cf9 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcfwb.F90 @@ -0,0 +1,256 @@ +MODULE sbcfwb + !!====================================================================== + !! *** MODULE sbcfwb *** + !! Ocean fluxes : domain averaged freshwater budget + !!====================================================================== + !! History : OPA ! 2001-02 (E. Durand) Original code + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.0 ! 2006-08 (G. Madec) Surface module + !! 3.2 ! 2009-07 (C. Talandier) emp mean s spread over erp area + !! 3.6 ! 2014-11 (P. Mathiot ) add ice shelf melting + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_fwb : freshwater budget for global ocean configurations (free surface & forced mode) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface ocean boundary condition + USE isf_oce , ONLY : fwfisf_cav, fwfisf_par ! ice shelf melting contribution + USE sbc_ice , ONLY : snwice_mass, snwice_mass_b, snwice_fmass + USE phycst ! physical constants + USE sbcrnf ! ocean runoffs + USE sbcssr ! Sea-Surface damping terms + ! + USE in_out_manager ! I/O manager + USE iom ! IOM + USE lib_mpp ! distribued memory computing library + USE timing ! Timing + USE lbclnk ! ocean lateral boundary conditions + USE lib_fortran ! + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_fwb ! routine called by step + + REAL(wp) :: rn_fwb0 ! initial freshwater adjustment flux [kg/m2/s] (nn_fwb = 2 only) + REAL(wp) :: a_fwb ! annual domain averaged freshwater budget from the previous year + REAL(wp) :: a_fwb_b ! annual domain averaged freshwater budget from the year before or at initial state + REAL(wp) :: a_fwb_ini ! initial domain averaged freshwater budget + REAL(wp) :: area ! global mean ocean surface (interior domain) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcfwb.F90 15439 2021-10-22 17:53:09Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_fwb( kt, kn_fwb, kn_fsbc, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_fwb *** + !! + !! ** Purpose : Control the mean sea surface drift + !! + !! ** Method : several ways depending on kn_fwb + !! =0 no control + !! =1 global mean of emp set to zero at each nn_fsbc time step + !! =2 annual global mean corrected from previous year + !! =3 global mean of emp set to zero at each nn_fsbc time step + !! & spread out over erp area depending its sign + !! Note: if sea ice is embedded it is taken into account when computing the budget + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + INTEGER, INTENT( in ) :: kn_fsbc ! + INTEGER, INTENT( in ) :: kn_fwb ! ocean time-step index + INTEGER, INTENT( in ) :: Kmm ! ocean time level index + ! + INTEGER :: ios, inum, ikty ! local integers + REAL(wp) :: z_fwf, z_fwf_nsrf, zsum_fwf, zsum_erp ! local scalars + REAL(wp) :: zsurf_neg, zsurf_pos, zsurf_tospread, zcoef ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmsk_neg, ztmsk_pos, z_wgt ! 2D workspaces + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmsk_tospread, zerp_cor ! - - + REAL(wp) ,DIMENSION(1) :: z_fwfprv + COMPLEX(dp),DIMENSION(1) :: y_fwfnow + ! + NAMELIST/namsbc_fwb/rn_fwb0 + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + READ( numnam_ref, namsbc_fwb, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam( ios, 'namsbc_fwb in reference namelist' ) + READ( numnam_cfg, namsbc_fwb, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam( ios, 'namsbc_fwb in configuration namelist' ) + IF(lwm) WRITE( numond, namsbc_fwb ) + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_fwb : FreshWater Budget correction' + WRITE(numout,*) '~~~~~~~' + IF( kn_fwb == 1 ) WRITE(numout,*) ' instantaneously set to zero' + IF( kn_fwb == 3 ) WRITE(numout,*) ' fwf set to zero and spread out over erp area' + IF( kn_fwb == 2 ) THEN + WRITE(numout,*) ' adjusted from previous year budget' + WRITE(numout,*) + WRITE(numout,*) ' Namelist namsbc_fwb' + WRITE(numout,*) ' Initial freshwater adjustment flux [kg/m2/s] = ', rn_fwb0 + END IF + ENDIF + ! + IF( kn_fwb == 3 .AND. nn_sssr /= 2 ) CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 requires nn_sssr = 2, we stop ' ) + IF( kn_fwb == 3 .AND. ln_isfcav ) CALL ctl_stop( 'sbc_fwb: nn_fwb = 3 with ln_isfcav = .TRUE. not working, we stop ' ) + ! + area = glob_sum( 'sbcfwb', e1e2t(:,:) * tmask(:,:,1)) ! interior global domain surface + ! isf cavities are excluded because it can feedback to the melting with generation of inhibition of plumes + ! and in case of no melt, it can generate HSSW. + ! +#if ! defined key_si3 && ! defined key_cice + snwice_mass_b(:,:) = 0.e0 ! no sea-ice model is being used : no snow+ice mass + snwice_mass (:,:) = 0.e0 + snwice_fmass (:,:) = 0.e0 +#endif + ! + ENDIF + + SELECT CASE ( kn_fwb ) + ! + CASE ( 1 ) !== global mean fwf set to zero ==! + ! + IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN + y_fwfnow(1) = local_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) - snwice_fmass(:,:) ) ) + CALL mpp_delay_sum( 'sbcfwb', 'fwb', y_fwfnow(:), z_fwfprv(:), kt == nitend - nn_fsbc + 1 ) + z_fwfprv(1) = z_fwfprv(1) / area + zcoef = z_fwfprv(1) * rcp + emp(:,:) = emp(:,:) - z_fwfprv(1) * tmask(:,:,1) + qns(:,:) = qns(:,:) + zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction + ! outputs + IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', zcoef * sst_m(:,:) * tmask(:,:,1) ) + IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', z_fwfprv(1) * tmask(:,:,1) ) + ENDIF + ! + CASE ( 2 ) !== fw adjustment based on fw budget at the end of the previous year ==! + ! simulation is supposed to start 1st of January + IF( kt == nit000 ) THEN ! initialisation + ! ! set the fw adjustment (a_fwb) + IF ( ln_rstart .AND. iom_varid( numror, 'a_fwb_b', ldstop = .FALSE. ) > 0 & ! as read from restart file + & .AND. iom_varid( numror, 'a_fwb', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) 'sbc_fwb : reading freshwater-budget from restart file' + CALL iom_get( numror, 'a_fwb_b', a_fwb_b ) + CALL iom_get( numror, 'a_fwb' , a_fwb ) + ! + a_fwb_ini = a_fwb_b + ELSE ! as specified in namelist + IF(lwp) WRITE(numout,*) 'sbc_fwb : setting freshwater-budget from namelist rn_fwb0' + a_fwb = rn_fwb0 + a_fwb_b = 0._wp ! used only the first year then it is replaced by a_fwb_ini + ! + a_fwb_ini = glob_sum( 'sbcfwb', e1e2t(:,:) * ( ssh(:,:,Kmm) + snwice_mass(:,:) * r1_rho0 ) ) & + & * rho0 / ( area * rday * REAL(nyear_len(1), wp) ) + END IF + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)'sbc_fwb : freshwater-budget at the end of previous year = ', a_fwb , 'kg/m2/s' + IF(lwp) WRITE(numout,*)' freshwater-budget at initial state = ', a_fwb_ini, 'kg/m2/s' + ! + ELSE + ! at the end of year n: + ikty = nyear_len(1) * 86400 / NINT(rn_Dt) + IF( MOD( kt, ikty ) == 0 ) THEN ! Update a_fwb at the last time step of a year + ! It should be the first time step of a year MOD(kt-1,ikty) but then the restart would be wrong + ! Hence, we make a small error here but the code is restartable + a_fwb_b = a_fwb_ini + ! mean sea level taking into account ice+snow + a_fwb = glob_sum( 'sbcfwb', e1e2t(:,:) * ( ssh(:,:,Kmm) + snwice_mass(:,:) * r1_rho0 ) ) + a_fwb = a_fwb * rho0 / ( area * rday * REAL(nyear_len(1), wp) ) ! convert in kg/m2/s + ENDIF + ! + ENDIF + ! + IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN ! correct the freshwater fluxes using previous year budget minus initial state + zcoef = ( a_fwb - a_fwb_b ) + emp(:,:) = emp(:,:) + zcoef * tmask(:,:,1) + qns(:,:) = qns(:,:) - zcoef * rcp * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction + ! outputs + IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -zcoef * rcp * sst_m(:,:) * tmask(:,:,1) ) + IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -zcoef * tmask(:,:,1) ) + ENDIF + ! Output restart information + IF( lrst_oce ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc_fwb : writing FW-budget adjustment to ocean restart file at it = ', kt + IF(lwp) WRITE(numout,*) '~~~~' + CALL iom_rstput( kt, nitrst, numrow, 'a_fwb_b', a_fwb_b ) + CALL iom_rstput( kt, nitrst, numrow, 'a_fwb', a_fwb ) + END IF + ! + IF( kt == nitend .AND. lwp ) THEN + WRITE(numout,*) 'sbc_fwb : freshwater-budget at the end of simulation (year now) = ', a_fwb , 'kg/m2/s' + WRITE(numout,*) ' freshwater-budget at initial state = ', a_fwb_b, 'kg/m2/s' + ENDIF + ! + CASE ( 3 ) !== global fwf set to zero and spread out over erp area ==! + ! + ALLOCATE( ztmsk_neg(jpi,jpj) , ztmsk_pos(jpi,jpj) , ztmsk_tospread(jpi,jpj) , z_wgt(jpi,jpj) , zerp_cor(jpi,jpj) ) + ! + IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN + ztmsk_pos(:,:) = tmask_i(:,:) ! Select <0 and >0 area of erp + WHERE( erp < 0._wp ) ztmsk_pos = 0._wp + ztmsk_neg(:,:) = tmask_i(:,:) - ztmsk_pos(:,:) + ! ! fwf global mean (excluding ocean to ice/snow exchanges) + z_fwf = glob_sum( 'sbcfwb', e1e2t(:,:) * ( emp(:,:) - rnf(:,:) - fwfisf_cav(:,:) - fwfisf_par(:,:) - snwice_fmass(:,:) ) ) / area + ! + IF( z_fwf < 0._wp ) THEN ! spread out over >0 erp area to increase evaporation + zsurf_pos = glob_sum( 'sbcfwb', e1e2t(:,:)*ztmsk_pos(:,:) ) + zsurf_tospread = zsurf_pos + ztmsk_tospread(:,:) = ztmsk_pos(:,:) + ELSE ! spread out over <0 erp area to increase precipitation + zsurf_neg = glob_sum( 'sbcfwb', e1e2t(:,:)*ztmsk_neg(:,:) ) ! Area filled by <0 and >0 erp + zsurf_tospread = zsurf_neg + ztmsk_tospread(:,:) = ztmsk_neg(:,:) + ENDIF + ! + zsum_fwf = glob_sum( 'sbcfwb', e1e2t(:,:) * z_fwf ) ! fwf global mean over <0 or >0 erp area +!!gm : zsum_fwf = z_fwf * area ??? it is right? I think so.... + z_fwf_nsrf = zsum_fwf / ( zsurf_tospread + rsmall ) + ! ! weight to respect erp field 2D structure + zsum_erp = glob_sum( 'sbcfwb', ztmsk_tospread(:,:) * erp(:,:) * e1e2t(:,:) ) + z_wgt(:,:) = ztmsk_tospread(:,:) * erp(:,:) / ( zsum_erp + rsmall ) + ! ! final correction term to apply + zerp_cor(:,:) = -1. * z_fwf_nsrf * zsurf_tospread * z_wgt(:,:) + ! +!!gm ===>>>> lbc_lnk should be useless as all the computation is done over the whole domain ! + CALL lbc_lnk( 'sbcfwb', zerp_cor, 'T', 1.0_wp ) + ! + emp(:,:) = emp(:,:) + zerp_cor(:,:) + qns(:,:) = qns(:,:) - zerp_cor(:,:) * rcp * sst_m(:,:) ! account for change to the heat budget due to fw correction + erp(:,:) = erp(:,:) + zerp_cor(:,:) + ! outputs + IF( iom_use('hflx_fwb_cea') ) CALL iom_put( 'hflx_fwb_cea', -zerp_cor(:,:) * rcp * sst_m(:,:) ) + IF( iom_use('vflx_fwb_cea') ) CALL iom_put( 'vflx_fwb_cea', -zerp_cor(:,:) ) + ! + IF( lwp ) THEN ! control print + IF( z_fwf < 0._wp ) THEN + WRITE(numout,*)' z_fwf < 0' + WRITE(numout,*)' SUM(erp+) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv' + ELSE + WRITE(numout,*)' z_fwf >= 0' + WRITE(numout,*)' SUM(erp-) = ', SUM( ztmsk_tospread(:,:)*erp(:,:)*e1e2t(:,:) )*1.e-9,' Sv' + ENDIF + WRITE(numout,*)' SUM(empG) = ', SUM( z_fwf*e1e2t(:,:) )*1.e-9,' Sv' + WRITE(numout,*)' z_fwf = ', z_fwf ,' Kg/m2/s' + WRITE(numout,*)' z_fwf_nsrf = ', z_fwf_nsrf ,' Kg/m2/s' + WRITE(numout,*)' MIN(zerp_cor) = ', MINVAL(zerp_cor) + WRITE(numout,*)' MAX(zerp_cor) = ', MAXVAL(zerp_cor) + ENDIF + ENDIF + DEALLOCATE( ztmsk_neg , ztmsk_pos , ztmsk_tospread , z_wgt , zerp_cor ) + ! + CASE DEFAULT !== you should never be there ==! + CALL ctl_stop( 'sbc_fwb : wrong nn_fwb value for the FreshWater Budget correction, choose either 1, 2 or 3' ) + ! + END SELECT + ! + END SUBROUTINE sbc_fwb + + !!====================================================================== +END MODULE sbcfwb \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcice_cice.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcice_cice.F90 new file mode 100644 index 0000000..d13ab21 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcice_cice.F90 @@ -0,0 +1,1056 @@ +MODULE sbcice_cice + !!====================================================================== + !! *** MODULE sbcice_cice *** + !! To couple with sea ice model CICE (LANL) + !!===================================================================== +#if defined key_cice + !!---------------------------------------------------------------------- + !! 'key_cice' : CICE sea-ice model + !!---------------------------------------------------------------------- + !! sbc_ice_cice : sea-ice model time-stepping and update ocean sbc over ice-covered area + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain +# if defined key_qco + USE domqco ! Variable volume +# else + USE domvvl ! Variable volume +# endif + USE phycst, only : rcp, rho0, r1_rho0, rhos, rhoi + USE in_out_manager ! I/O manager + USE iom, ONLY : iom_put,iom_use ! I/O manager library !!Joakim edit + USE lib_mpp ! distributed memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE daymod ! calendar + USE fldread ! read input fields + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbc_ice ! Surface boundary condition: ice fields + USE sbcblk ! Surface boundary condition: bulk + USE sbccpl + + USE ice_kinds_mod + USE ice_blocks + USE ice_domain + USE ice_domain_size + USE ice_boundary + USE ice_constants + USE ice_gather_scatter + USE ice_calendar, only: dt + USE ice_state, only: aice,aicen,uvel,vvel,vsno,vsnon,vice,vicen +# if defined key_cice4 + USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow, & + strocnxT,strocnyT, & + sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_gbm, & + fresh_gbm,fhocn_gbm,fswthru_gbm,frzmlt, & + flatn_f,fsurfn_f,fcondtopn_f, & + uatm,vatm,wind,fsw,flw,Tair,potT,Qa,rhoa,zlvl, & + swvdr,swvdf,swidr,swidf + USE ice_therm_vertical, only: calc_Tsfc +#else + USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow, & + strocnxT,strocnyT, & + sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_ai, & + fresh_ai,fhocn_ai,fswthru_ai,frzmlt, & + flatn_f,fsurfn_f,fcondtopn_f, & + uatm,vatm,wind,fsw,flw,Tair,potT,Qa,rhoa,zlvl, & + swvdr,swvdf,swidr,swidf + USE ice_therm_shared, only: calc_Tsfc +#endif + USE ice_forcing, only: frcvdr,frcvdf,frcidr,frcidf + USE ice_atmo, only: calc_strair + + USE CICE_InitMod + USE CICE_RunMod + USE CICE_FinalMod + + IMPLICIT NONE + PRIVATE + + PUBLIC cice_sbc_init ! routine called by sbc_init + PUBLIC cice_sbc_final ! routine called by sbc_final + PUBLIC sbc_ice_cice ! routine called by sbc + + INTEGER :: ji_off + INTEGER :: jj_off + + INTEGER , PARAMETER :: jpfld = 13 ! maximum number of files to read + INTEGER , PARAMETER :: jp_snow = 1 ! index of snow file + INTEGER , PARAMETER :: jp_rain = 2 ! index of rain file + INTEGER , PARAMETER :: jp_sblm = 3 ! index of sublimation file + INTEGER , PARAMETER :: jp_top1 = 4 ! index of category 1 topmelt file + INTEGER , PARAMETER :: jp_top2 = 5 ! index of category 2 topmelt file + INTEGER , PARAMETER :: jp_top3 = 6 ! index of category 3 topmelt file + INTEGER , PARAMETER :: jp_top4 = 7 ! index of category 4 topmelt file + INTEGER , PARAMETER :: jp_top5 = 8 ! index of category 5 topmelt file + INTEGER , PARAMETER :: jp_bot1 = 9 ! index of category 1 botmelt file + INTEGER , PARAMETER :: jp_bot2 = 10 ! index of category 2 botmelt file + INTEGER , PARAMETER :: jp_bot3 = 11 ! index of category 3 botmelt file + INTEGER , PARAMETER :: jp_bot4 = 12 ! index of category 4 botmelt file + INTEGER , PARAMETER :: jp_bot5 = 13 ! index of category 5 botmelt file + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read) + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), PRIVATE :: png ! local array used in sbc_cice_ice + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcice_cice.F90 14595 2021-03-05 22:36:50Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_ice_cice_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_ice_cice_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( png(jpi,jpj,jpnij), STAT=sbc_ice_cice_alloc ) + CALL mpp_sum ( 'sbcice_cice', sbc_ice_cice_alloc ) + IF( sbc_ice_cice_alloc > 0 ) CALL ctl_warn('sbc_ice_cice_alloc: allocation of arrays failed.') + END FUNCTION sbc_ice_cice_alloc + + SUBROUTINE sbc_ice_cice( kt, ksbc ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_ice_cice *** + !! + !! ** Purpose : update the ocean surface boundary condition via the + !! CICE Sea Ice Model time stepping + !! + !! ** Method : - Get any extra forcing fields for CICE + !! - Prepare forcing fields + !! - CICE model time stepping + !! - call the routine that computes mass and + !! heat fluxes at the ice/ocean interface + !! + !! ** Action : - time evolution of the CICE sea-ice model + !! - update all sbc variables below sea-ice: + !! utau, vtau, qns , qsr, emp , sfx + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: ksbc ! surface forcing type + !!---------------------------------------------------------------------- + ! + ! !----------------------! + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! Ice time-step only ! + ! !----------------------! + + ! Make sure any fluxes required for CICE are set + IF ( ksbc == jp_flx ) THEN + CALL cice_sbc_force(kt) + ELSE IF( ksbc == jp_purecpl ) THEN + CALL sbc_cpl_ice_flx( kt, fr_i ) + ENDIF + + CALL cice_sbc_in ( kt, ksbc ) + CALL CICE_Run + CALL cice_sbc_out ( kt, ksbc ) + + IF( ksbc == jp_purecpl ) CALL cice_sbc_hadgam(kt+1) + + ENDIF ! End sea-ice time step only + ! + END SUBROUTINE sbc_ice_cice + + + SUBROUTINE cice_sbc_init( ksbc, Kbb, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cice_sbc_init *** + !! ** Purpose: Initialise ice related fields for NEMO and coupling + !! + !!--------------------------------------------------------------------- + INTEGER, INTENT( in ) :: ksbc ! surface forcing type + INTEGER, INTENT( in ) :: Kbb, Kmm ! time level indices + REAL(wp), DIMENSION(jpi,jpj) :: ztmp1, ztmp2 + REAL(wp) :: zcoefu, zcoefv, zcoeff ! local scalar + INTEGER :: ji, jj, jl, jk ! dummy loop indices + !!--------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*)'cice_sbc_init' + + ji_off = INT ( (jpiglo - nx_global) / 2 ) + jj_off = INT ( (jpjglo - ny_global) / 2 ) + +#if defined key_nemocice_decomp + ! Pass initial SST from NEMO to CICE so ice is initialised correctly if + ! there is no restart file. + ! Values from a CICE restart file would overwrite this + IF( .NOT. ln_rstart ) THEN + CALL nemo2cice( ts(:,:,1,jp_tem,Kmm) , sst , 'T' , 1.) + ENDIF +#endif + +! Initialize CICE + CALL CICE_Initialize + +! Do some CICE consistency checks + IF( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN + IF( calc_strair .OR. calc_Tsfc ) THEN + CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=F and calc_Tsfc=F in ice_in' ) + ENDIF + ELSEIF(ksbc == jp_blk) THEN + IF( .NOT. (calc_strair .AND. calc_Tsfc) ) THEN + CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=T and calc_Tsfc=T in ice_in' ) + ENDIF + ENDIF + + +! allocate sbc_ice and sbc_cice arrays + IF( sbc_ice_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_ice_cice_alloc : unable to allocate arrays' ) + IF( sbc_ice_cice_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_ice_cice_alloc : unable to allocate cice arrays' ) + +! Ensure ocean temperatures are nowhere below freezing if not a NEMO restart + IF( .NOT. ln_rstart ) THEN + ts(:,:,:,jp_tem,Kmm) = MAX (ts(:,:,:,jp_tem,Kmm),Tocnfrz) + ts(:,:,:,jp_tem,Kbb) = ts(:,:,:,jp_tem,Kmm) + ENDIF + + fr_iu(:,:)=0.0 + fr_iv(:,:)=0.0 + + CALL cice2nemo(aice,fr_i, 'T', 1. ) + IF( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN + DO jl=1,ncat + CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. ) + ENDDO + ENDIF + +! T point to U point +! T point to V point + DO_2D( 1, 0, 1, 0 ) + fr_iu(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji+1,jj))*umask(ji,jj,1) + fr_iv(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji,jj+1))*vmask(ji,jj,1) + END_2D + + CALL lbc_lnk( 'sbcice_cice', fr_iu , 'U', 1.0_wp, fr_iv , 'V', 1.0_wp ) + + ! set the snow+ice mass + CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. ) + CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. ) + snwice_mass (:,:) = ( rhos * ztmp1(:,:) + rhoi * ztmp2(:,:) ) + snwice_mass_b(:,:) = snwice_mass(:,:) + + IF( .NOT.ln_rstart ) THEN + IF( ln_ice_embd ) THEN ! embedded sea-ice: deplete the initial ssh below sea-ice area + ssh(:,:,Kmm) = ssh(:,:,Kmm) - snwice_mass(:,:) * r1_rho0 + ssh(:,:,Kbb) = ssh(:,:,Kbb) - snwice_mass(:,:) * r1_rho0 + +!!gm This should be put elsewhere.... (same remark for limsbc) +!!gm especially here it is assumed zstar coordinate, but it can be ztilde.... +#if defined key_qco + IF( .NOT.ln_linssh ) CALL dom_qco_zgr( Kbb, Kmm ) ! interpolation scale factor, depth and water column +#else + IF( .NOT.ln_linssh ) THEN + ! + DO jk = 1,jpkm1 ! adjust initial vertical scale factors + e3t(:,:,jk,Kmm) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kmm)*r1_ht_0(:,:)*tmask(:,:,jk) ) + e3t(:,:,jk,Kbb) = e3t_0(:,:,jk)*( 1._wp + ssh(:,:,Kbb)*r1_ht_0(:,:)*tmask(:,:,jk) ) + ENDDO + e3t(:,:,:,Krhs) = e3t(:,:,:,Kbb) + ! Reconstruction of all vertical scale factors at now and before time-steps + ! ============================================================================= + ! Horizontal scale factor interpolations + ! -------------------------------------- + CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) + CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) + CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) + CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) + CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) + ! Vertical scale factor interpolations + ! ------------------------------------ + CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) + CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) + CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) + CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) + CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) + ! t- and w- points depth + ! ---------------------- + gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm) + gdepw(:,:,1,Kmm) = 0.0_wp + gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm) + DO jk = 2, jpk + gdept(:,:,jk,Kmm) = gdept(:,:,jk-1,Kmm) + e3w(:,:,jk,Kmm) + gdepw(:,:,jk,Kmm) = gdepw(:,:,jk-1,Kmm) + e3t(:,:,jk-1,Kmm) + gde3w(:,:,jk) = gdept(:,:,jk ,Kmm) - sshn (:,:) + END DO + ENDIF +#endif + ENDIF + ENDIF + ! + END SUBROUTINE cice_sbc_init + + + SUBROUTINE cice_sbc_in( kt, ksbc ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cice_sbc_in *** + !! ** Purpose: Set coupling fields and pass to CICE + !!--------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time step + INTEGER, INTENT(in ) :: ksbc ! surface forcing type + ! + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: ztmp, zpice + REAL(wp), DIMENSION(jpi,jpj,ncat) :: ztmpn + REAL(wp) :: zintb, zintn ! dummy argument + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*)'cice_sbc_in' + ENDIF + + ztmp(:,:)=0.0 + +! Aggregate ice concentration already set in cice_sbc_out (or cice_sbc_init on +! the first time-step) + +! forced and coupled case + + IF( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN + + ztmpn(:,:,:)=0.0 + +! x comp of wind stress (CI_1) +! U point to F point + DO_2D( 1, 1, 1, 0 ) + ztmp(ji,jj) = 0.5 * ( fr_iu(ji,jj) * utau(ji,jj) & + + fr_iu(ji,jj+1) * utau(ji,jj+1) ) * fmask(ji,jj,1) + END_2D + CALL nemo2cice(ztmp,strax,'F', -1. ) + +! y comp of wind stress (CI_2) +! V point to F point + DO_2D( 1, 0, 1, 1 ) + ztmp(ji,jj) = 0.5 * ( fr_iv(ji,jj) * vtau(ji,jj) & + + fr_iv(ji+1,jj) * vtau(ji+1,jj) ) * fmask(ji,jj,1) + END_2D + CALL nemo2cice(ztmp,stray,'F', -1. ) + +! Surface downward latent heat flux (CI_5) + IF(ksbc == jp_flx) THEN + DO jl=1,ncat + ztmpn(:,:,jl)=qla_ice(:,:,1)*a_i(:,:,jl) + ENDDO + ELSE +! emp_ice is set in sbc_cpl_ice_flx as sublimation-snow + qla_ice(:,:,1)= - ( emp_ice(:,:)+sprecip(:,:) ) * rLsub +! End of temporary code + DO_2D( 1, 1, 1, 1 ) + IF(fr_i(ji,jj).eq.0.0) THEN + DO jl=1,ncat + ztmpn(ji,jj,jl)=0.0 + ENDDO + ! This will then be conserved in CICE + ztmpn(ji,jj,1)=qla_ice(ji,jj,1) + ELSE + DO jl=1,ncat + ztmpn(ji,jj,jl)=qla_ice(ji,jj,1)*a_i(ji,jj,jl)/fr_i(ji,jj) + ENDDO + ENDIF + END_2D + ENDIF + DO jl=1,ncat + CALL nemo2cice(ztmpn(:,:,jl),flatn_f(:,:,jl,:),'T', 1. ) + +! GBM conductive flux through ice (CI_6) +! Convert to GBM + IF(ksbc == jp_flx) THEN + ztmp(:,:) = botmelt(:,:,jl)*a_i(:,:,jl) + ELSE + ztmp(:,:) = botmelt(:,:,jl) + ENDIF + CALL nemo2cice(ztmp,fcondtopn_f(:,:,jl,:),'T', 1. ) + +! GBM surface heat flux (CI_7) +! Convert to GBM + IF(ksbc == jp_flx) THEN + ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl))*a_i(:,:,jl) + ELSE + ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl)) + ENDIF + CALL nemo2cice(ztmp,fsurfn_f(:,:,jl,:),'T', 1. ) + ENDDO + + ELSE IF(ksbc == jp_blk) THEN + +! Pass bulk forcing fields to CICE (which will calculate heat fluxes etc itself) +! x comp and y comp of atmosphere surface wind (CICE expects on T points) + ztmp(:,:) = wndi_ice(:,:) + CALL nemo2cice(ztmp,uatm,'T', -1. ) + ztmp(:,:) = wndj_ice(:,:) + CALL nemo2cice(ztmp,vatm,'T', -1. ) + ztmp(:,:) = SQRT ( wndi_ice(:,:)**2 + wndj_ice(:,:)**2 ) + CALL nemo2cice(ztmp,wind,'T', 1. ) ! Wind speed (m/s) + ztmp(:,:) = qsr_ice(:,:,1) + CALL nemo2cice(ztmp,fsw,'T', 1. ) ! Incoming short-wave (W/m^2) + ztmp(:,:) = qlw_ice(:,:,1) + CALL nemo2cice(ztmp,flw,'T', 1. ) ! Incoming long-wave (W/m^2) + ztmp(:,:) = tatm_ice(:,:) + CALL nemo2cice(ztmp,Tair,'T', 1. ) ! Air temperature (K) + CALL nemo2cice(ztmp,potT,'T', 1. ) ! Potential temp (K) +! Following line uses MAX(....) to avoid problems if tatm_ice has unset halo rows + ztmp(:,:) = 101000. / ( 287.04 * MAX(1.0,tatm_ice(:,:)) ) + ! Constant (101000.) atm pressure assumed + CALL nemo2cice(ztmp,rhoa,'T', 1. ) ! Air density (kg/m^3) + ztmp(:,:) = qatm_ice(:,:) + CALL nemo2cice(ztmp,Qa,'T', 1. ) ! Specific humidity (kg/kg) + ztmp(:,:)=10.0 + CALL nemo2cice(ztmp,zlvl,'T', 1. ) ! Atmos level height (m) + +! May want to check all values are physically realistic (as in CICE routine +! prepare_forcing)? + +! Divide shortwave into spectral bands (as in prepare_forcing) + ztmp(:,:)=qsr_ice(:,:,1)*frcvdr ! visible direct + CALL nemo2cice(ztmp,swvdr,'T', 1. ) + ztmp(:,:)=qsr_ice(:,:,1)*frcvdf ! visible diffuse + CALL nemo2cice(ztmp,swvdf,'T', 1. ) + ztmp(:,:)=qsr_ice(:,:,1)*frcidr ! near IR direct + CALL nemo2cice(ztmp,swidr,'T', 1. ) + ztmp(:,:)=qsr_ice(:,:,1)*frcidf ! near IR diffuse + CALL nemo2cice(ztmp,swidf,'T', 1. ) + + ENDIF + +! Snowfall +! Ensure fsnow is positive (as in CICE routine prepare_forcing) + IF( iom_use('snowpre') ) CALL iom_put('snowpre',MAX( (1.0-fr_i(:,:))*sprecip(:,:) ,0.0)) !!Joakim edit + ztmp(:,:)=MAX(fr_i(:,:)*sprecip(:,:),0.0) + CALL nemo2cice(ztmp,fsnow,'T', 1. ) + +! Rainfall + IF( iom_use('precip') ) CALL iom_put('precip', (1.0-fr_i(:,:))*(tprecip(:,:)-sprecip(:,:)) ) !!Joakim edit + ztmp(:,:)=fr_i(:,:)*(tprecip(:,:)-sprecip(:,:)) + CALL nemo2cice(ztmp,frain,'T', 1. ) + +! Freezing/melting potential +! Calculated over NEMO leapfrog timestep (hence 2*dt) + nfrzmlt(:,:) = rho0 * rcp * e3t_m(:,:) * ( Tocnfrz-sst_m(:,:) ) / ( 2.0*dt ) + + ztmp(:,:) = nfrzmlt(:,:) + CALL nemo2cice(ztmp,frzmlt,'T', 1. ) + +! SST and SSS + + CALL nemo2cice(sst_m,sst,'T', 1. ) + CALL nemo2cice(sss_m,sss,'T', 1. ) + +! x comp and y comp of surface ocean current +! U point to F point + DO_2D( 1, 1, 1, 0 ) + ztmp(ji,jj)=0.5*(ssu_m(ji,jj)+ssu_m(ji,jj+1))*fmask(ji,jj,1) + END_2D + CALL nemo2cice(ztmp,uocn,'F', -1. ) + +! V point to F point + DO_2D( 1, 0, 1, 1 ) + ztmp(ji,jj)=0.5*(ssv_m(ji,jj)+ssv_m(ji+1,jj))*fmask(ji,jj,1) + END_2D + CALL nemo2cice(ztmp,vocn,'F', -1. ) + + IF( ln_ice_embd ) THEN !== embedded sea ice: compute representative ice top surface ==! + ! + ! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[n/nn_fsbc], n=0,nn_fsbc-1} + ! = (1/nn_fsbc)^2 * {SUM[n], n=0,nn_fsbc-1} + zintn = REAL( nn_fsbc - 1 ) / REAL( nn_fsbc ) * 0.5_wp + ! + ! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[1-n/nn_fsbc], n=0,nn_fsbc-1} + ! = (1/nn_fsbc)^2 * (nn_fsbc^2 - {SUM[n], n=0,nn_fsbc-1}) + zintb = REAL( nn_fsbc + 1 ) / REAL( nn_fsbc ) * 0.5_wp + ! + zpice(:,:) = ssh_m(:,:) + ( zintn * snwice_mass(:,:) + zintb * snwice_mass_b(:,:) ) * r1_rho0 + ! + ! + ELSE !== non-embedded sea ice: use ocean surface for slope calculation ==! + zpice(:,:) = ssh_m(:,:) + ENDIF + +! x comp and y comp of sea surface slope (on F points) +! T point to F point + DO_2D( 1, 0, 1, 0 ) + ztmp(ji,jj)=0.5 * ( (zpice(ji+1,jj )-zpice(ji,jj )) * r1_e1u(ji,jj ) & + & + (zpice(ji+1,jj+1)-zpice(ji,jj+1)) * r1_e1u(ji,jj+1) ) * fmask(ji,jj,1) + END_2D + CALL nemo2cice( ztmp,ss_tltx,'F', -1. ) + +! T point to F point + DO_2D( 1, 0, 1, 0 ) + ztmp(ji,jj)=0.5 * ( (zpice(ji ,jj+1)-zpice(ji ,jj)) * r1_e2v(ji ,jj) & + & + (zpice(ji+1,jj+1)-zpice(ji+1,jj)) * r1_e2v(ji+1,jj) ) * fmask(ji,jj,1) + END_2D + CALL nemo2cice(ztmp,ss_tlty,'F', -1. ) + ! + END SUBROUTINE cice_sbc_in + + + SUBROUTINE cice_sbc_out( kt, ksbc ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cice_sbc_out *** + !! ** Purpose: Get fields from CICE and set surface fields for NEMO + !!--------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time step + INTEGER, INTENT( in ) :: ksbc ! surface forcing type + + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: ztmp1, ztmp2 + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*)'cice_sbc_out' + ENDIF + +! x comp of ocean-ice stress + CALL cice2nemo(strocnx,ztmp1,'F', -1. ) + ss_iou(:,:)=0.0 +! F point to U point + DO_2D( 0, 0, 0, 0 ) + ss_iou(ji,jj) = 0.5 * ( ztmp1(ji,jj-1) + ztmp1(ji,jj) ) * umask(ji,jj,1) + END_2D + CALL lbc_lnk( 'sbcice_cice', ss_iou , 'U', -1.0_wp ) + +! y comp of ocean-ice stress + CALL cice2nemo(strocny,ztmp1,'F', -1. ) + ss_iov(:,:)=0.0 +! F point to V point + + DO_2D( 0, 0, 1, 0 ) + ss_iov(ji,jj) = 0.5 * ( ztmp1(ji-1,jj) + ztmp1(ji,jj) ) * vmask(ji,jj,1) + END_2D + CALL lbc_lnk( 'sbcice_cice', ss_iov , 'V', -1.0_wp ) + +! x and y comps of surface stress +! Combine wind stress and ocean-ice stress +! [Note that fr_iu hasn't yet been updated, so still from start of CICE timestep] +! strocnx and strocny already weighted by ice fraction in CICE so not done here + + utau(:,:)=(1.0-fr_iu(:,:))*utau(:,:)-ss_iou(:,:) + vtau(:,:)=(1.0-fr_iv(:,:))*vtau(:,:)-ss_iov(:,:) + +! Also need ice/ocean stress on T points so that taum can be updated +! This interpolation is already done in CICE so best to use those values + CALL cice2nemo(strocnxT,ztmp1,'T',-1.) + CALL cice2nemo(strocnyT,ztmp2,'T',-1.) + +! Update taum with modulus of ice-ocean stress +! strocnxT and strocnyT are not weighted by ice fraction in CICE so must be done here +taum(:,:)=(1.0-fr_i(:,:))*taum(:,:)+fr_i(:,:)*SQRT(ztmp1*ztmp1 + ztmp2*ztmp2) + +! Freshwater fluxes + + IF(ksbc == jp_flx) THEN +! Note that emp from the forcing files is evap*(1-aice)-(tprecip-aice*sprecip) +! What we want here is evap*(1-aice)-tprecip*(1-aice) hence manipulation below +! Not ideal since aice won't be the same as in the atmosphere. +! Better to use evap and tprecip? (but for now don't read in evap in this case) + emp(:,:) = emp(:,:)+fr_i(:,:)*(tprecip(:,:)-sprecip(:,:)) + ELSE IF(ksbc == jp_blk) THEN + emp(:,:) = (1.0-fr_i(:,:))*emp(:,:) + ELSE IF(ksbc == jp_purecpl) THEN +! emp_tot is set in sbc_cpl_ice_flx (called from cice_sbc_in above) +! This is currently as required with the coupling fields from the UM atmosphere + emp(:,:) = emp_tot(:,:)+tprecip(:,:)*fr_i(:,:) + ENDIF + +#if defined key_cice4 + CALL cice2nemo(fresh_gbm,ztmp1,'T', 1. ) + CALL cice2nemo(fsalt_gbm,ztmp2,'T', 1. ) +#else + CALL cice2nemo(fresh_ai,ztmp1,'T', 1. ) + CALL cice2nemo(fsalt_ai,ztmp2,'T', 1. ) +#endif + +! Check to avoid unphysical expression when ice is forming (ztmp1 negative) +! Otherwise we are effectively allowing ice of higher salinity than the ocean to form +! which has to be compensated for by the ocean salinity potentially going negative +! This check breaks conservation but seems reasonable until we have prognostic ice salinity +! Note the 1000.0 below is to convert from kg salt to g salt (needed for PSU) + WHERE (ztmp1(:,:).lt.0.0) ztmp2(:,:)=MAX(ztmp2(:,:),ztmp1(:,:)*sss_m(:,:)/1000.0) + sfx(:,:)=ztmp2(:,:)*1000.0 + emp(:,:)=emp(:,:)-ztmp1(:,:) + fmmflx(:,:) = ztmp1(:,:) !!Joakim edit + + CALL lbc_lnk( 'sbcice_cice', emp , 'T', 1.0_wp, sfx , 'T', 1.0_wp ) + +! Solar penetrative radiation and non solar surface heat flux + +! Scale qsr and qns according to ice fraction (bulk formulae only) + + IF(ksbc == jp_blk) THEN + qsr(:,:)=qsr(:,:)*(1.0-fr_i(:,:)) + qns(:,:)=qns(:,:)*(1.0-fr_i(:,:)) + ENDIF +! Take into account snow melting except for fully coupled when already in qns_tot + IF(ksbc == jp_purecpl) THEN + qsr(:,:)= qsr_tot(:,:) + qns(:,:)= qns_tot(:,:) + ELSE + qns(:,:)= qns(:,:)-sprecip(:,:)*Lfresh*(1.0-fr_i(:,:)) + ENDIF + +! Now add in ice / snow related terms +! [fswthru will be zero unless running with calc_Tsfc=T in CICE] +#if defined key_cice4 + CALL cice2nemo(fswthru_gbm,ztmp1,'T', 1. ) +#else + CALL cice2nemo(fswthru_ai,ztmp1,'T', 1. ) +#endif + qsr(:,:)=qsr(:,:)+ztmp1(:,:) + CALL lbc_lnk( 'sbcice_cice', qsr , 'T', 1.0_wp ) + + DO_2D( 1, 1, 1, 1 ) + nfrzmlt(ji,jj)=MAX(nfrzmlt(ji,jj),0.0) + END_2D + +#if defined key_cice4 + CALL cice2nemo(fhocn_gbm,ztmp1,'T', 1. ) +#else + CALL cice2nemo(fhocn_ai,ztmp1,'T', 1. ) +#endif + qns(:,:)=qns(:,:)+nfrzmlt(:,:)+ztmp1(:,:) + + CALL lbc_lnk( 'sbcice_cice', qns , 'T', 1.0_wp ) + +! Prepare for the following CICE time-step + + CALL cice2nemo(aice,fr_i,'T', 1. ) + IF( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN + DO jl=1,ncat + CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. ) + ENDDO + ENDIF + +! T point to U point +! T point to V point + DO_2D( 1, 0, 1, 0 ) + fr_iu(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji+1,jj))*umask(ji,jj,1) + fr_iv(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji,jj+1))*vmask(ji,jj,1) + END_2D + + CALL lbc_lnk( 'sbcice_cice', fr_iu , 'U', 1.0_wp, fr_iv , 'V', 1.0_wp ) + + ! set the snow+ice mass + CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. ) + CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. ) + snwice_mass (:,:) = ( rhos * ztmp1(:,:) + rhoi * ztmp2(:,:) ) + snwice_mass_b(:,:) = snwice_mass(:,:) + snwice_fmass (:,:) = ( snwice_mass(:,:) - snwice_mass_b(:,:) ) / dt + ! + END SUBROUTINE cice_sbc_out + + + SUBROUTINE cice_sbc_hadgam( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cice_sbc_hadgam *** + !! ** Purpose: Prepare fields needed to pass to HadGAM3 atmosphere + !! + !! + !!--------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time step + !! + INTEGER :: jl ! dummy loop index + INTEGER :: ierror + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*)'cice_sbc_hadgam' + IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' ) + ENDIF + + ! ! =========================== ! + ! ! Prepare Coupling fields ! + ! ! =========================== ! + ! + ! x and y comp of ice velocity + ! + CALL cice2nemo(uvel,u_ice,'F', -1. ) + CALL cice2nemo(vvel,v_ice,'F', -1. ) + ! + ! Ice concentration (CO_1) = a_i calculated at end of cice_sbc_out + ! + ! Snow and ice thicknesses (CO_2 and CO_3) + ! + DO jl = 1, ncat + CALL cice2nemo( vsnon(:,:,jl,:), h_s(:,:,jl),'T', 1. ) + CALL cice2nemo( vicen(:,:,jl,:), h_i(:,:,jl),'T', 1. ) + END DO + ! + END SUBROUTINE cice_sbc_hadgam + + + SUBROUTINE cice_sbc_final + !!--------------------------------------------------------------------- + !! *** ROUTINE cice_sbc_final *** + !! ** Purpose: Finalize CICE + !!--------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*)'cice_sbc_final' + ! + CALL CICE_Finalize + ! + END SUBROUTINE cice_sbc_final + + + SUBROUTINE cice_sbc_force (kt) + !!--------------------------------------------------------------------- + !! *** ROUTINE cice_sbc_force *** + !! ** Purpose : Provide CICE forcing from files + !! + !!--------------------------------------------------------------------- + !! ** Method : READ monthly flux file in NetCDF files + !! + !! snowfall + !! rainfall + !! sublimation rate + !! topmelt (category) + !! botmelt (category) + !! + !! History : + !!---------------------------------------------------------------------- + USE iom + !! + INTEGER, INTENT( in ) :: kt ! ocean time step + !! + INTEGER :: ierror ! return error code + INTEGER :: ifpr ! dummy loop index + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of CICE forcing files + TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist informations on the fields to read + TYPE(FLD_N) :: sn_snow, sn_rain, sn_sblm ! informations about the fields to be read + TYPE(FLD_N) :: sn_top1, sn_top2, sn_top3, sn_top4, sn_top5 + TYPE(FLD_N) :: sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5 + !! + NAMELIST/namsbc_cice/ cn_dir, sn_snow, sn_rain, sn_sblm, & + & sn_top1, sn_top2, sn_top3, sn_top4, sn_top5, & + & sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5 + INTEGER :: ios + !!--------------------------------------------------------------------- + + ! ! ====================== ! + IF( kt == nit000 ) THEN ! First call kt=nit000 ! + ! ! ====================== ! + ! namsbc_cice is not yet in the reference namelist + ! set file information (default values) + cn_dir = './' ! directory in which the model is executed + + ! (NB: frequency positive => hours, negative => months) + ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! landmask + ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! file + sn_snow = FLD_N( 'snowfall_1m' , -1. , 'snowfall' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_rain = FLD_N( 'rainfall_1m' , -1. , 'rainfall' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_sblm = FLD_N( 'sublim_1m' , -1. , 'sublim' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_top1 = FLD_N( 'topmeltn1_1m' , -1. , 'topmeltn1' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_top2 = FLD_N( 'topmeltn2_1m' , -1. , 'topmeltn2' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_top3 = FLD_N( 'topmeltn3_1m' , -1. , 'topmeltn3' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_top4 = FLD_N( 'topmeltn4_1m' , -1. , 'topmeltn4' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_top5 = FLD_N( 'topmeltn5_1m' , -1. , 'topmeltn5' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_bot1 = FLD_N( 'botmeltn1_1m' , -1. , 'botmeltn1' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_bot2 = FLD_N( 'botmeltn2_1m' , -1. , 'botmeltn2' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_bot3 = FLD_N( 'botmeltn3_1m' , -1. , 'botmeltn3' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_bot4 = FLD_N( 'botmeltn4_1m' , -1. , 'botmeltn4' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_bot5 = FLD_N( 'botmeltn5_1m' , -1. , 'botmeltn5' , .true. , .true. , ' yearly' , '' , '' , '' ) + + READ ( numnam_ref, namsbc_cice, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cice in reference namelist' ) + + READ ( numnam_cfg, namsbc_cice, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_cice ) + + ! store namelist information in an array + slf_i(jp_snow) = sn_snow ; slf_i(jp_rain) = sn_rain ; slf_i(jp_sblm) = sn_sblm + slf_i(jp_top1) = sn_top1 ; slf_i(jp_top2) = sn_top2 ; slf_i(jp_top3) = sn_top3 + slf_i(jp_top4) = sn_top4 ; slf_i(jp_top5) = sn_top5 ; slf_i(jp_bot1) = sn_bot1 + slf_i(jp_bot2) = sn_bot2 ; slf_i(jp_bot3) = sn_bot3 ; slf_i(jp_bot4) = sn_bot4 + slf_i(jp_bot5) = sn_bot5 + + ! set sf structure + ALLOCATE( sf(jpfld), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'cice_sbc_force: unable to allocate sf structure' ) ; RETURN + ENDIF + + DO ifpr= 1, jpfld + ALLOCATE( sf(ifpr)%fnow(jpi,jpj,1) ) + ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) ) + END DO + + ! fill sf with slf_i and control print + CALL fld_fill( sf, slf_i, cn_dir, 'cice_sbc_force', 'flux formulation for CICE', 'namsbc_cice' ) + ! + ENDIF + + CALL fld_read( kt, nn_fsbc, sf ) ! Read input fields and provides the + ! ! input fields at the current time-step + + ! set the fluxes from read fields + sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) + tprecip(:,:) = sf(jp_snow)%fnow(:,:,1)+sf(jp_rain)%fnow(:,:,1) +! May be better to do this conversion somewhere else + qla_ice(:,:,1) = -rLsub*sf(jp_sblm)%fnow(:,:,1) + topmelt(:,:,1) = sf(jp_top1)%fnow(:,:,1) + topmelt(:,:,2) = sf(jp_top2)%fnow(:,:,1) + topmelt(:,:,3) = sf(jp_top3)%fnow(:,:,1) + topmelt(:,:,4) = sf(jp_top4)%fnow(:,:,1) + topmelt(:,:,5) = sf(jp_top5)%fnow(:,:,1) + botmelt(:,:,1) = sf(jp_bot1)%fnow(:,:,1) + botmelt(:,:,2) = sf(jp_bot2)%fnow(:,:,1) + botmelt(:,:,3) = sf(jp_bot3)%fnow(:,:,1) + botmelt(:,:,4) = sf(jp_bot4)%fnow(:,:,1) + botmelt(:,:,5) = sf(jp_bot5)%fnow(:,:,1) + + ! control print (if less than 100 time-step asked) + IF( nitend-nit000 <= 100 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) ' read forcing fluxes for CICE OK' + CALL FLUSH(numout) + ENDIF + + END SUBROUTINE cice_sbc_force + + SUBROUTINE nemo2cice( pn, pc, cd_type, psgn) + !!--------------------------------------------------------------------- + !! *** ROUTINE nemo2cice *** + !! ** Purpose : Transfer field in NEMO array to field in CICE array. +#if defined key_nemocice_decomp + !! + !! NEMO and CICE PE sub domains are identical, hence + !! there is no need to gather or scatter data from + !! one PE configuration to another. +#else + !! Automatically gather/scatter between + !! different processors and blocks + !! ** Method : A. Ensure all haloes are filled in NEMO field (pn) + !! B. Gather pn into global array (png) + !! C. Map png into CICE global array (pcg) + !! D. Scatter pcg to CICE blocks (pc) + update haloes +#endif + !!--------------------------------------------------------------------- + CHARACTER(len=1), INTENT( in ) :: & + cd_type ! nature of pn grid-point + ! ! = T or F gridpoints + REAL(wp), INTENT( in ) :: & + psgn ! control of the sign change + ! ! =-1 , the sign is modified following the type of b.c. used + ! ! = 1 , no sign change + REAL(wp), DIMENSION(jpi,jpj) :: pn +#if !defined key_nemocice_decomp + REAL(wp), DIMENSION(jpiglo,jpjglo) :: png2 + REAL (kind=dbl_kind), dimension(nx_global,ny_global) :: pcg +#endif + REAL (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: pc + INTEGER (int_kind) :: & + field_type, &! id for type of field (scalar, vector, angle) + grid_loc ! id for location on horizontal grid + ! (center, NEcorner, Nface, Eface) + + INTEGER :: ji, jj, jn ! dummy loop indices + !!--------------------------------------------------------------------- + +! A. Ensure all haloes are filled in NEMO field (pn) + + CALL lbc_lnk( 'sbcice_cice', pn , cd_type, psgn ) + +#if defined key_nemocice_decomp + + ! Copy local domain data from NEMO to CICE field + pc(:,:,1)=0.0 + DO jj=2,ny_block-1 + DO ji=2,nx_block-1 + pc(ji,jj,1)=pn(ji-1+ji_off,jj-1+jj_off) + ENDDO + ENDDO + +#else + +! B. Gather pn into global array (png) + + IF( jpnij > 1) THEN + CALL mppsync + CALL mppgather (pn,0,png) + CALL mppsync + ELSE + png(:,:,1)=pn(:,:) + ENDIF + +! C. Map png into CICE global array (pcg) + +! Need to make sure this is robust to changes in NEMO halo rows.... +! (may be OK but not 100% sure) + + IF(narea==1) THEN +! pcg(:,:)=0.0 + DO jn=1,jpnij + DO jj=njs0all(jn),nje0all(jn) + DO ji=nis0all(jn),nie0all(jn) + png2(ji+nimppt(jn)-1,jj+njmppt(jn)-1)=png(ji,jj,jn) + ENDDO + ENDDO + ENDDO + DO jj=1,ny_global + DO ji=1,nx_global + pcg(ji,jj)=png2(ji+ji_off,jj+jj_off) + ENDDO + ENDDO + ENDIF + +#endif + + SELECT CASE ( cd_type ) + CASE ( 'T' ) + grid_loc=field_loc_center + CASE ( 'F' ) + grid_loc=field_loc_NEcorner + END SELECT + + SELECT CASE ( NINT(psgn) ) + CASE ( -1 ) + field_type=field_type_vector + CASE ( 1 ) + field_type=field_type_scalar + END SELECT + +#if defined key_nemocice_decomp + ! Ensure CICE halos are up to date + CALL ice_HaloUpdate (pc, halo_info, grid_loc, field_type) +#else +! D. Scatter pcg to CICE blocks (pc) + update halos + CALL scatter_global(pc, pcg, 0, distrb_info, grid_loc, field_type) +#endif + + END SUBROUTINE nemo2cice + + SUBROUTINE cice2nemo ( pc, pn, cd_type, psgn ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cice2nemo *** + !! ** Purpose : Transfer field in CICE array to field in NEMO array. +#if defined key_nemocice_decomp + !! + !! NEMO and CICE PE sub domains are identical, hence + !! there is no need to gather or scatter data from + !! one PE configuration to another. +#else + !! Automatically deal with scatter/gather between + !! different processors and blocks + !! ** Method : A. Gather CICE blocks (pc) into global array (pcg) + !! B. Map pcg into NEMO global array (png) + !! C. Scatter png into NEMO field (pn) for each processor + !! D. Ensure all haloes are filled in pn +#endif + !!--------------------------------------------------------------------- + + CHARACTER(len=1), INTENT( in ) :: & + cd_type ! nature of pn grid-point + ! ! = T or F gridpoints + REAL(wp), INTENT( in ) :: & + psgn ! control of the sign change + ! ! =-1 , the sign is modified following the type of b.c. used + ! ! = 1 , no sign change + REAL(wp), DIMENSION(jpi,jpj) :: pn + +#if defined key_nemocice_decomp + INTEGER (int_kind) :: & + field_type, & ! id for type of field (scalar, vector, angle) + grid_loc ! id for location on horizontal grid + ! (center, NEcorner, Nface, Eface) +#else + REAL (kind=dbl_kind), dimension(nx_global,ny_global) :: pcg +#endif + + REAL (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: pc + + INTEGER :: ji, jj, jn ! dummy loop indices + + +#if defined key_nemocice_decomp + + SELECT CASE ( cd_type ) + CASE ( 'T' ) + grid_loc=field_loc_center + CASE ( 'F' ) + grid_loc=field_loc_NEcorner + END SELECT + + SELECT CASE ( NINT(psgn) ) + CASE ( -1 ) + field_type=field_type_vector + CASE ( 1 ) + field_type=field_type_scalar + END SELECT + + CALL ice_HaloUpdate (pc, halo_info, grid_loc, field_type) + + + pn(:,:)=0.0 + DO_2D( 1, 0, 1, 0 ) + pn(ji,jj)=pc(ji+1-ji_off,jj+1-jj_off,1) + END_2D + +#else + +! A. Gather CICE blocks (pc) into global array (pcg) + + CALL gather_global(pcg, pc, 0, distrb_info) + +! B. Map pcg into NEMO global array (png) + +! Need to make sure this is robust to changes in NEMO halo rows.... +! (may be OK but not spent much time thinking about it) +! Note that non-existent pcg elements may be used below, but +! the lbclnk call on pn will replace these with sensible values + + IF(narea==1) THEN + png(:,:,:)=0.0 + DO jn=1,jpnij + DO jj=njs0all(jn),nje0all(jn) + DO ji=nis0all(jn),nie0all(jn) + png(ji,jj,jn)=pcg(ji+nimppt(jn)-1-ji_off,jj+njmppt(jn)-1-jj_off) + ENDDO + ENDDO + ENDDO + ENDIF + +! C. Scatter png into NEMO field (pn) for each processor + + IF( jpnij > 1) THEN + CALL mppsync + CALL mppscatter (png,0,pn) + CALL mppsync + ELSE + pn(:,:)=png(:,:,1) + ENDIF + +#endif + +! D. Ensure all haloes are filled in pn + + CALL lbc_lnk( 'sbcice_cice', pn , cd_type, psgn ) + + END SUBROUTINE cice2nemo + +#else + !!---------------------------------------------------------------------- + !! Default option Dummy module NO CICE sea-ice model + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_ice_cice ( kt, ksbc ) ! Dummy routine + IMPLICIT NONE + INTEGER, INTENT( in ) :: kt, ksbc + WRITE(*,*) 'sbc_ice_cice: You should not have seen this print! error?', kt + END SUBROUTINE sbc_ice_cice + + SUBROUTINE cice_sbc_init (ksbc, Kbb, Kmm) ! Dummy routine + IMPLICIT NONE + INTEGER, INTENT( in ) :: ksbc + INTEGER, INTENT( in ) :: Kbb, Kmm + WRITE(*,*) 'cice_sbc_init: You should not have seen this print! error?', ksbc + END SUBROUTINE cice_sbc_init + + SUBROUTINE cice_sbc_final ! Dummy routine + IMPLICIT NONE + WRITE(*,*) 'cice_sbc_final: You should not have seen this print! error?' + END SUBROUTINE cice_sbc_final + +#endif + + !!====================================================================== +END MODULE sbcice_cice \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcice_if.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcice_if.F90 new file mode 100644 index 0000000..ef66e89 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcice_if.F90 @@ -0,0 +1,148 @@ +MODULE sbcice_if + !!====================================================================== + !! *** MODULE sbcice *** + !! Surface module : update surface ocean boundary condition over ice + !! covered area using ice-if model + !!====================================================================== + !! History : 3.0 ! 2006-06 (G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_ice_if : update sbc in ice-covered area + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE eosbn2 ! equation of state + USE sbc_oce ! surface boundary condition: ocean fields +#if defined key_si3 + USE ice , ONLY : a_i +#else + USE sbc_ice , ONLY : a_i +#endif + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE fldread ! read input field + USE lib_mpp ! MPP library + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_ice_if ! routine called in sbcmod + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_ice ! structure of input ice-cover (file informations, fields read) + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcice_if.F90 13295 2020-07-10 18:24:21Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_ice_if( kt, Kbb, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_ice_if *** + !! + !! ** Purpose : handle surface boundary condition over ice cover area + !! when sea-ice model are not used + !! + !! ** Method : - read sea-ice cover climatology + !! - blah blah blah, ... + !! + !! ** Action : utau, vtau : remain unchanged + !! taum, wndm : remain unchanged + !! qns, qsr : update heat flux below sea-ice + !! emp, sfx : update freshwater flux below sea-ice + !! fr_i : update the ice fraction + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + ! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ierror ! return error code + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp) :: ztrp, zsice, zt_fzp, zfr_obs + REAL(wp) :: zqri, zqrj, zqrp, zqi + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ice-if files + TYPE(FLD_N) :: sn_ice ! informations about the fields to be read + NAMELIST/namsbc_iif/ cn_dir, sn_ice + !!--------------------------------------------------------------------- + ! ! ====================== ! + IF( kt == nit000 ) THEN ! First call kt=nit000 ! + ! ! ====================== ! + ! set file information + READ ( numnam_ref, namsbc_iif, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_iif in reference namelist' ) + + READ ( numnam_cfg, namsbc_iif, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_iif in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_iif ) + + ALLOCATE( sf_ice(1), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ice_if: unable to allocate sf_ice structure' ) + ALLOCATE( sf_ice(1)%fnow(jpi,jpj,1) ) + IF( sn_ice%ln_tint ) ALLOCATE( sf_ice(1)%fdta(jpi,jpj,1,2) ) + + ! fill sf_ice with sn_ice and control print + CALL fld_fill( sf_ice, (/ sn_ice /), cn_dir, 'sbc_ice_if', 'ice-if sea-ice model', 'namsbc_iif' ) + ! + ENDIF + + CALL fld_read( kt, nn_fsbc, sf_ice ) ! Read input fields and provides the + ! ! input fields at the current time-step + + IF( MOD( kt-1, nn_fsbc) == 0 ) THEN + ! + ztrp = -40. ! restoring terme for temperature (w/m2/k) + zsice = - 0.04 / 0.8 ! ratio of isohaline compressibility over isotherme compressibility + ! ( d rho / dt ) / ( d rho / ds ) ( s = 34, t = -1.8 ) + + CALL eos_fzp( sss_m(:,:), fr_i(:,:) ) ! sea surface freezing temperature [Celsius] + fr_i(:,:) = fr_i(:,:) * tmask(:,:,1) + + IF( ln_cpl ) a_i(:,:,1) = fr_i(:,:) + + ! Flux and ice fraction computation + DO_2D( 1, 1, 1, 1 ) + ! + zt_fzp = fr_i(ji,jj) ! freezing point temperature + zfr_obs = sf_ice(1)%fnow(ji,jj,1) ! observed ice cover + ! ! ocean ice fraction (0/1) from the freezing point temperature + IF( sst_m(ji,jj) <= zt_fzp ) THEN ; fr_i(ji,jj) = 1.e0 + ELSE ; fr_i(ji,jj) = 0.e0 + ENDIF + + ts(ji,jj,1,jp_tem,Kmm) = MAX( ts(ji,jj,1,jp_tem,Kmm), zt_fzp ) ! avoid over-freezing point temperature + + qsr(ji,jj) = ( 1. - zfr_obs ) * qsr(ji,jj) ! solar heat flux : zero below observed ice cover + + ! ! non solar heat flux : add a damping term + ! # ztrp*(t-(tgel-1.)) if observed ice and no opa ice (zfr_obs=1 fr_i=0) + ! # ztrp*min(0,t-tgel) if observed ice and opa ice (zfr_obs=1 fr_i=1) + zqri = ztrp * ( ts(ji,jj,1,jp_tem,Kbb) - ( zt_fzp - 1.) ) + zqrj = ztrp * MIN( 0., ts(ji,jj,1,jp_tem,Kbb) - zt_fzp ) + zqrp = ( zfr_obs * ( (1. - fr_i(ji,jj) ) * zqri & + & + fr_i(ji,jj) * zqrj ) ) * tmask(ji,jj,1) + + ! ! non-solar heat flux + ! # qns unchanged if no climatological ice (zfr_obs=0) + ! # qns = zqrp if climatological ice and no opa ice (zfr_obs=1, fr_i=0) + ! # qns = zqrp -2(-4) watt/m2 if climatological ice and opa ice (zfr_obs=1, fr_i=1) + ! (-2=arctic, -4=antarctic) + zqi = -3. + SIGN( 1._wp, ff_f(ji,jj) ) + qns(ji,jj) = ( ( 1.- zfr_obs ) * qns(ji,jj) & + & + zfr_obs * fr_i(ji,jj) * zqi ) * tmask(ji,jj,1) & + & + zqrp + END_2D + ! + ENDIF + ! + END SUBROUTINE sbc_ice_if + + !!====================================================================== +END MODULE sbcice_if \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcmod.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcmod.F90 new file mode 100644 index 0000000..cd2b9e8 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcmod.F90 @@ -0,0 +1,635 @@ +MODULE sbcmod + !!====================================================================== + !! *** MODULE sbcmod *** + !! Surface module : provide to the ocean its surface boundary condition + !!====================================================================== + !! History : 3.0 ! 2006-07 (G. Madec) Original code + !! 3.1 ! 2008-08 (S. Masson, A. Caubel, E. Maisonnave, G. Madec) coupled interface + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) Forcing averaged over 2 time steps + !! 3.3 ! 2010-10 (S. Masson) add diurnal cycle + !! 3.3 ! 2010-09 (D. Storkey) add ice boundary conditions (BDY) + !! - ! 2010-11 (G. Madec) ice-ocean stress always computed at each ocean time-step + !! - ! 2010-10 (J. Chanut, C. Bricaud, G. Madec) add the surface pressure forcing + !! 3.4 ! 2011-11 (C. Harris) CICE added as an option + !! 3.5 ! 2012-11 (A. Coward, G. Madec) Rethink of heat, mass and salt surface fluxes + !! 3.6 ! 2014-11 (P. Mathiot, C. Harris) add ice shelves melting + !! 4.0 ! 2016-06 (L. Brodeau) new general bulk formulation + !! 4.0 ! 2019-03 (F. Lemarié & G. Samson) add ABL compatibility (ln_abl=TRUE) + !! 4.2 ! 2020-12 (G. Madec, E. Clementi) modified wave forcing and coupling + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_init : read namsbc namelist + !! sbc : surface ocean momentum, heat and freshwater boundary conditions + !! sbc_final : Finalize CICE ice model (if used) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE closea ! closed seas + USE phycst ! physical constants + USE sbc_phy, ONLY : pp_cldf + USE sbc_oce ! Surface boundary condition: ocean fields + USE trc_oce ! shared ocean-passive tracers variables + USE sbc_ice ! Surface boundary condition: ice fields + USE sbcdcy ! surface boundary condition: diurnal cycle + USE sbcssm ! surface boundary condition: sea-surface mean variables + USE sbcflx ! surface boundary condition: flux formulation + USE sbcblk ! surface boundary condition: bulk formulation + USE sbcabl ! atmospheric boundary layer + USE sbcice_if ! surface boundary condition: ice-if sea-ice model +#if defined key_si3 + USE icestp ! surface boundary condition: SI3 sea-ice model +#endif + USE sbcice_cice ! surface boundary condition: CICE sea-ice model + USE sbccpl ! surface boundary condition: coupled formulation + USE cpl_oasis3 ! OASIS routines for coupling + USE sbcclo ! surface boundary condition: closed sea correction + USE sbcssr ! surface boundary condition: sea surface restoring + USE sbcrnf ! surface boundary condition: runoffs + USE sbcapr ! surface boundary condition: atmo pressure + USE sbcfwb ! surface boundary condition: freshwater budget + USE icbstp ! Icebergs + USE icb_oce , ONLY : ln_passive_mode ! iceberg interaction mode + USE traqsr ! active tracers: light penetration + USE sbcwave ! Wave module + USE bdy_oce , ONLY: ln_bdy + USE usrdef_sbc ! user defined: surface boundary condition + USE closea ! closed sea + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + ! + USE prtctl ! Print control (prt_ctl routine) + USE iom ! IOM library + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! Timing + USE wet_dry + USE diu_bulk, ONLY: ln_diurnal_only ! diurnal SST diagnostic + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc ! routine called by step.F90 + PUBLIC sbc_init ! routine called by opa.F90 + + INTEGER :: nsbc ! type of surface boundary condition (deduced from namsbc informations) + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcmod.F90 15372 2021-10-14 15:47:24Z davestorkey $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_init( Kbb, Kmm, Kaa ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_init *** + !! + !! ** Purpose : Initialisation of the ocean surface boundary computation + !! + !! ** Method : Read the namsbc namelist and set derived parameters + !! Call init routines for all other SBC modules that have one + !! + !! ** Action : - read namsbc parameters + !! - nsbc: type of sbc + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices + INTEGER :: ios, icpt ! local integer + LOGICAL :: ll_purecpl, ll_opa, ll_not_nemo ! local logical + !! + NAMELIST/namsbc/ nn_fsbc , & + & ln_usr , ln_flx , ln_blk , ln_abl, & + & ln_cpl , ln_mixcpl, nn_components, & + & nn_ice , ln_ice_embd, & + & ln_traqsr, ln_dm2dc , & + & ln_rnf , nn_fwb , ln_ssr , ln_apr_dyn, & + & ln_wave , nn_lsm + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_init : surface boundary condition setting' + WRITE(numout,*) '~~~~~~~~ ' + ENDIF + ! + ! !** read Surface Module namelist + READ ( numnam_ref, namsbc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc in reference namelist' ) + READ ( numnam_cfg, namsbc, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc in configuration namelist' ) + IF(lwm) WRITE( numond, namsbc ) + ! +#if ! defined key_mpi_off + ncom_fsbc = nn_fsbc ! make nn_fsbc available for lib_mpp +#endif +#if ! defined key_si3 + IF( nn_ice == 2 ) nn_ice = 0 ! without key key_si3 you cannot use si3... +#endif + ! + ! + IF(lwp) THEN !* Control print + WRITE(numout,*) ' Namelist namsbc (partly overwritten with CPP key setting)' + WRITE(numout,*) ' frequency update of sbc (and ice) nn_fsbc = ', nn_fsbc + WRITE(numout,*) ' Type of air-sea fluxes : ' + WRITE(numout,*) ' user defined formulation ln_usr = ', ln_usr + WRITE(numout,*) ' flux formulation ln_flx = ', ln_flx + WRITE(numout,*) ' bulk formulation ln_blk = ', ln_blk + WRITE(numout,*) ' ABL formulation ln_abl = ', ln_abl + WRITE(numout,*) ' Surface wave (forced or coupled) ln_wave = ', ln_wave + WRITE(numout,*) ' Type of coupling (Ocean/Ice/Atmosphere) : ' + WRITE(numout,*) ' ocean-atmosphere coupled formulation ln_cpl = ', ln_cpl + WRITE(numout,*) ' mixed forced-coupled formulation ln_mixcpl = ', ln_mixcpl +!!gm lk_oasis is controlled by key_oasis3 ===>>> It shoud be removed from the namelist + WRITE(numout,*) ' OASIS coupling (with atm or sas) lk_oasis = ', lk_oasis + WRITE(numout,*) ' components of your executable nn_components = ', nn_components + WRITE(numout,*) ' Sea-ice : ' + WRITE(numout,*) ' ice management in the sbc (=0/1/2/3) nn_ice = ', nn_ice + WRITE(numout,*) ' ice embedded into ocean ln_ice_embd = ', ln_ice_embd + WRITE(numout,*) ' Misc. options of sbc : ' + WRITE(numout,*) ' Light penetration in temperature Eq. ln_traqsr = ', ln_traqsr + WRITE(numout,*) ' daily mean to diurnal cycle qsr ln_dm2dc = ', ln_dm2dc + WRITE(numout,*) ' Sea Surface Restoring on SST and/or SSS ln_ssr = ', ln_ssr + WRITE(numout,*) ' FreshWater Budget control (=0/1/2) nn_fwb = ', nn_fwb + WRITE(numout,*) ' Patm gradient added in ocean & ice Eqs. ln_apr_dyn = ', ln_apr_dyn + WRITE(numout,*) ' runoff / runoff mouths ln_rnf = ', ln_rnf + WRITE(numout,*) ' nb of iterations if land-sea-mask applied nn_lsm = ', nn_lsm + ENDIF + ! + IF( .NOT.ln_usr ) THEN ! the model calendar needs some specificities (except in user defined case) + IF( MOD( rday , rn_Dt ) /= 0. ) CALL ctl_stop( 'the time step must devide the number of second of in a day' ) + IF( MOD( rday , 2. ) /= 0. ) CALL ctl_stop( 'the number of second of in a day must be an even number' ) + IF( MOD( rn_Dt , 2. ) /= 0. ) CALL ctl_stop( 'the time step (in second) must be an even number' ) + ENDIF + ! !** check option consistency + ! + IF(lwp) WRITE(numout,*) !* Single / Multi - executable (NEMO / OCE+SAS) + SELECT CASE( nn_components ) + CASE( jp_iam_nemo ) + IF(lwp) WRITE(numout,*) ' ==>>> NEMO configured as a single executable (i.e. including both OCE and Surface module)' + CASE( jp_iam_oce ) + IF(lwp) WRITE(numout,*) ' ==>>> Multi executable configuration. Here, OCE component' + IF( .NOT.lk_oasis ) CALL ctl_stop( 'sbc_init : OCE-SAS coupled via OASIS, but key_oasis3 disabled' ) + IF( ln_cpl ) CALL ctl_stop( 'sbc_init : OCE-SAS coupled via OASIS, but ln_cpl = T in OCE' ) + IF( ln_mixcpl ) CALL ctl_stop( 'sbc_init : OCE-SAS coupled via OASIS, but ln_mixcpl = T in OCE' ) + CASE( jp_iam_sas ) + IF(lwp) WRITE(numout,*) ' ==>>> Multi executable configuration. Here, SAS component' + IF( .NOT.lk_oasis ) CALL ctl_stop( 'sbc_init : OCE-SAS coupled via OASIS, but key_oasis3 disabled' ) + IF( ln_mixcpl ) CALL ctl_stop( 'sbc_init : OCE-SAS coupled via OASIS, but ln_mixcpl = T in OCE' ) + CASE DEFAULT + CALL ctl_stop( 'sbc_init : unsupported value for nn_components' ) + END SELECT + ! !* coupled options + IF( ln_cpl ) THEN + IF( .NOT. lk_oasis ) CALL ctl_stop( 'sbc_init : coupled mode with an atmosphere model (ln_cpl=T)', & + & ' required to defined key_oasis3' ) + ENDIF + IF( ln_mixcpl ) THEN + IF( .NOT. lk_oasis ) CALL ctl_stop( 'sbc_init : mixed forced-coupled mode (ln_mixcpl=T) ', & + & ' required to defined key_oasis3' ) + IF( .NOT.ln_cpl ) CALL ctl_stop( 'sbc_init : mixed forced-coupled mode (ln_mixcpl=T) requires ln_cpl = T' ) + IF( nn_components /= jp_iam_nemo ) & + & CALL ctl_stop( 'sbc_init : the mixed forced-coupled mode (ln_mixcpl=T) ', & + & ' not yet working with sas-opa coupling via oasis' ) + ENDIF + ! !* sea-ice + SELECT CASE( nn_ice ) + CASE( 0 ) !- no ice in the domain + CASE( 1 ) !- Ice-cover climatology ("Ice-if" model) + CASE( 2 ) !- SI3 ice model + IF( .NOT.( ln_blk .OR. ln_cpl .OR. ln_abl .OR. ln_usr ) ) & + & CALL ctl_stop( 'sbc_init : SI3 sea-ice model requires ln_blk or ln_cpl or ln_abl or ln_usr = T' ) + CASE( 3 ) !- CICE ice model + IF( .NOT.( ln_blk .OR. ln_cpl .OR. ln_abl .OR. ln_usr ) ) & + & CALL ctl_stop( 'sbc_init : CICE sea-ice model requires ln_blk or ln_cpl or ln_abl or ln_usr = T' ) + IF( lk_agrif ) & + & CALL ctl_stop( 'sbc_init : CICE sea-ice model not currently available with AGRIF' ) + CASE DEFAULT !- not supported + END SELECT + IF( ln_diurnal .AND. .NOT. (ln_blk.OR.ln_abl) ) CALL ctl_stop( "sbc_init: diurnal flux processing only implemented for bulk forcing" ) + ! + ! !** allocate and set required variables + ! + ! !* allocate sbc arrays + IF( sbc_oce_alloc() /= 0 ) CALL ctl_stop( 'sbc_init : unable to allocate sbc_oce arrays' ) +#if ! defined key_si3 && ! defined key_cice + IF( sbc_ice_alloc() /= 0 ) CALL ctl_stop( 'sbc_init : unable to allocate sbc_ice arrays' ) +#endif + ! + ! + IF( sbc_ssr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_ssr arrays' ) + IF( .NOT.ln_ssr ) THEN !* Initialize qrp and erp if no restoring + qrp(:,:) = 0._wp + erp(:,:) = 0._wp + ENDIF + ! + IF( nn_ice == 0 ) THEN !* No sea-ice in the domain : ice fraction is always zero + IF( nn_components /= jp_iam_oce ) fr_i(:,:) = 0._wp ! except for OCE in SAS-OCE coupled case + ENDIF + ! + sfx (:,:) = 0._wp !* salt flux due to freezing/melting + fmmflx(:,:) = 0._wp !* freezing minus melting flux + cloud_fra(:,:) = pp_cldf !* cloud fraction over sea ice (used in si3) + + taum(:,:) = 0._wp !* wind stress module (needed in GLS in case of reduced restart) + + ! ! Choice of the Surface Boudary Condition (set nsbc) + nday_qsr = -1 ! allow initialization at the 1st call !LB: now warm-layer of COARE* calls "sbc_dcy_param" of sbcdcy.F90! + IF( ln_dm2dc ) THEN !* daily mean to diurnal cycle + !LB:nday_qsr = -1 ! allow initialization at the 1st call + IF( .NOT.( ln_flx .OR. ln_blk .OR. ln_abl ) .AND. nn_components /= jp_iam_oce ) & + & CALL ctl_stop( 'qsr diurnal cycle from daily values requires flux, bulk or abl formulation' ) + ENDIF + ! !* Choice of the Surface Boudary Condition + ! (set nsbc) + ! + ll_purecpl = ln_cpl .AND. .NOT.ln_mixcpl + ll_opa = nn_components == jp_iam_oce + ll_not_nemo = nn_components /= jp_iam_nemo + icpt = 0 + ! + IF( ln_usr ) THEN ; nsbc = jp_usr ; icpt = icpt + 1 ; ENDIF ! user defined formulation + IF( ln_flx ) THEN ; nsbc = jp_flx ; icpt = icpt + 1 ; ENDIF ! flux formulation + IF( ln_blk ) THEN ; nsbc = jp_blk ; icpt = icpt + 1 ; ENDIF ! bulk formulation + IF( ln_abl ) THEN ; nsbc = jp_abl ; icpt = icpt + 1 ; ENDIF ! ABL formulation + IF( ll_purecpl ) THEN ; nsbc = jp_purecpl ; icpt = icpt + 1 ; ENDIF ! Pure Coupled formulation + IF( ll_opa ) THEN ; nsbc = jp_none ; icpt = icpt + 1 ; ENDIF ! opa coupling via SAS module + ! + IF( icpt /= 1 ) CALL ctl_stop( 'sbc_init : choose ONE and only ONE sbc option' ) + ! + IF(lwp) THEN !- print the choice of surface flux formulation + WRITE(numout,*) + SELECT CASE( nsbc ) + CASE( jp_usr ) ; WRITE(numout,*) ' ==>>> user defined forcing formulation' + CASE( jp_flx ) ; WRITE(numout,*) ' ==>>> flux formulation' + CASE( jp_blk ) ; WRITE(numout,*) ' ==>>> bulk formulation' + CASE( jp_abl ) ; WRITE(numout,*) ' ==>>> ABL formulation' + CASE( jp_purecpl ) ; WRITE(numout,*) ' ==>>> pure coupled formulation' +!!gm abusive use of jp_none ?? ===>>> need to be check and changed by adding a jp_sas parameter + CASE( jp_none ) ; WRITE(numout,*) ' ==>>> OCE coupled to SAS via oasis' + IF( ln_mixcpl ) WRITE(numout,*) ' + forced-coupled mixed formulation' + END SELECT + IF( ll_not_nemo ) WRITE(numout,*) ' + OASIS coupled SAS' + ENDIF + ! + ! !* OASIS initialization + ! + IF( lk_oasis ) CALL sbc_cpl_init( nn_ice ) ! Must be done before: (1) first time step + ! ! (2) the use of nn_fsbc + ! nn_fsbc initialization if OCE-SAS coupling via OASIS + ! SAS time-step has to be declared in OASIS (mandatory) -> nn_fsbc has to be modified accordingly + IF( nn_components /= jp_iam_nemo ) THEN + IF( nn_components == jp_iam_oce ) nn_fsbc = cpl_freq('O_SFLX') / NINT(rn_Dt) + IF( nn_components == jp_iam_sas ) nn_fsbc = cpl_freq('I_SFLX') / NINT(rn_Dt) + ! + IF(lwp)THEN + WRITE(numout,*) + WRITE(numout,*)" OCE-SAS coupled via OASIS : nn_fsbc re-defined from OASIS namcouple ", nn_fsbc + WRITE(numout,*) + ENDIF + ENDIF + ! + ! !* check consistency between model timeline and nn_fsbc + IF( ln_rst_list .OR. nn_stock /= -1 ) THEN ! we will do restart files + IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 ) THEN + WRITE(ctmp1,*) 'sbc_init : experiment length (', nitend - nit000 + 1, ') is NOT a multiple of nn_fsbc (', nn_fsbc, ')' + CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) + ENDIF + IF( .NOT. ln_rst_list .AND. MOD( nn_stock, nn_fsbc) /= 0 ) THEN ! we don't use nn_stock if ln_rst_list + WRITE(ctmp1,*) 'sbc_init : nn_stock (', nn_stock, ') is NOT a multiple of nn_fsbc (', nn_fsbc, ')' + CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) + ENDIF + ENDIF + ! + IF( MOD( rday, REAL(nn_fsbc, wp) * rn_Dt ) /= 0 ) & + & CALL ctl_warn( 'sbc_init : nn_fsbc is NOT a multiple of the number of time steps in a day' ) + ! + IF( ln_dm2dc .AND. NINT(rday) / ( nn_fsbc * NINT(rn_Dt) ) < 8 ) & + & CALL ctl_warn( 'sbc_init : diurnal cycle for qsr: the sampling of the diurnal cycle is too small...' ) + ! + + ! !** associated modules : initialization + ! + CALL sbc_ssm_init ( Kbb, Kmm ) ! Sea-surface mean fields initialization + ! + IF( l_sbc_clo ) CALL sbc_clo_init ! closed sea surface initialisation + ! + IF( ln_blk ) CALL sbc_blk_init ! bulk formulae initialization + + IF( ln_abl ) CALL sbc_abl_init ! Atmospheric Boundary Layer (ABL) + + IF( ln_ssr ) CALL sbc_ssr_init ! Sea-Surface Restoring initialization + ! + ! + CALL sbc_rnf_init( Kmm ) ! Runof initialization + ! + IF( ln_apr_dyn ) CALL sbc_apr_init ! Atmo Pressure Forcing initialization + ! +#if defined key_si3 + IF( lk_agrif .AND. nn_ice == 0 ) THEN ! allocate ice arrays in case agrif + ice-model + no-ice in child grid + IF( sbc_ice_alloc() /= 0 ) CALL ctl_stop('STOP', 'sbc_ice_alloc : unable to allocate arrays' ) + ELSEIF( nn_ice == 2 ) THEN + CALL ice_init( Kbb, Kmm, Kaa ) ! ICE initialization + ENDIF +#endif + IF( nn_ice == 3 ) CALL cice_sbc_init( nsbc, Kbb, Kmm ) ! CICE initialization + ! + IF( ln_wave ) THEN + CALL sbc_wave_init ! surface wave initialisation + ELSE + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' No surface waves : all wave related logical set to false' + ln_sdw = .false. + ln_stcor = .false. + ln_cdgw = .false. + ln_tauoc = .false. + ln_wave_test = .false. + ln_charn = .false. + ln_taw = .false. + ln_phioc = .false. + ln_bern_srfc = .false. + ln_breivikFV_2016 = .false. + ln_vortex_force = .false. + ln_stshear = .false. + ENDIF + ! + END SUBROUTINE sbc_init + + + SUBROUTINE sbc( kt, Kbb, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc *** + !! + !! ** Purpose : provide at each time-step the ocean surface boundary + !! condition (momentum, heat and freshwater fluxes) + !! + !! ** Method : blah blah to be written ????????? + !! CAUTION : never mask the surface stress field (tke sbc) + !! + !! ** Action : - set the ocean surface boundary condition at before and now + !! time step, i.e. + !! utau_b, vtau_b, qns_b, qsr_b, emp_n, sfx_b, qrp_b, erp_b + !! utau , vtau , qns , qsr , emp , sfx , qrp , erp + !! - updte the ice fraction : fr_i + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + INTEGER :: jj, ji ! dummy loop argument + ! + LOGICAL :: ll_sas, ll_opa ! local logical + ! + REAL(wp) :: zthscl ! wd tanh scale + REAL(wp), DIMENSION(jpi,jpj) :: zwdht, zwght ! wd dep over wd limit, wgt + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! temporary array used for iom_put + + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('sbc') + ! + ! ! ---------------------------------------- ! + IF( kt /= nit000 ) THEN ! Swap of forcing fields ! + ! ! ---------------------------------------- ! + utau_b(:,:) = utau(:,:) ! Swap the ocean forcing fields + vtau_b(:,:) = vtau(:,:) ! (except at nit000 where before fields + qns_b (:,:) = qns (:,:) ! are set at the end of the routine) + emp_b (:,:) = emp (:,:) + sfx_b (:,:) = sfx (:,:) + IF( ln_rnf ) THEN + rnf_b (:,: ) = rnf (:,: ) + rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) + ENDIF + ! + ENDIF + ! ! ---------------------------------------- ! + ! ! forcing field computation ! + ! ! ---------------------------------------- ! + ! + ll_sas = nn_components == jp_iam_sas ! component flags + ll_opa = nn_components == jp_iam_oce + ! + IF( .NOT.ll_sas ) CALL sbc_ssm ( kt, Kbb, Kmm ) ! mean ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m) + ! + ! !== sbc formulation ==! + ! + ! + SELECT CASE( nsbc ) ! Compute ocean surface boundary condition + ! ! (i.e. utau,vtau, qns, qsr, emp, sfx) + CASE( jp_usr ) ; CALL usrdef_sbc_oce( kt, Kbb ) ! user defined formulation + CASE( jp_flx ) ; CALL sbc_flx ( kt ) ! flux formulation + CASE( jp_blk ) + IF( ll_sas ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! OCE-SAS coupling: SAS receiving fields from OCE +!!!!!!!!!!! ATTENTION:ln_wave is not only used for oasis coupling !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF( ln_wave ) THEN + IF ( lk_oasis ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! OCE-wave coupling + CALL sbc_wave ( kt, Kmm ) + ENDIF + CALL sbc_blk ( kt ) ! bulk formulation for the ocean + ! + CASE( jp_abl ) + IF( ll_sas ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! OCE-SAS coupling: SAS receiving fields from OCE + CALL sbc_abl ( kt ) ! ABL formulation for the ocean + ! + CASE( jp_purecpl ) ; CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! pure coupled formulation + CASE( jp_none ) + IF( ll_opa ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! OCE-SAS coupling: OCE receiving fields from SAS + END SELECT + ! + IF( ln_mixcpl ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! forced-coupled mixed formulation after forcing + ! + IF( ln_wave .AND. ln_tauoc ) THEN ! Wave stress reduction + DO_2D( 0, 0, 0, 0) + utau(ji,jj) = utau(ji,jj) * ( tauoc_wave(ji,jj) + tauoc_wave(ji-1,jj) ) * 0.5_wp + vtau(ji,jj) = vtau(ji,jj) * ( tauoc_wave(ji,jj) + tauoc_wave(ji,jj-1) ) * 0.5_wp + END_2D + ! + CALL lbc_lnk( 'sbcwave', utau, 'U', -1._wp ) + CALL lbc_lnk( 'sbcwave', vtau, 'V', -1._wp ) + ! + taum(:,:) = taum(:,:)*tauoc_wave(:,:) + ! + IF( kt == nit000 ) CALL ctl_warn( 'sbc: You are subtracting the wave stress to the ocean.', & + & 'If not requested select ln_tauoc=.false.' ) + ! + ELSEIF( ln_wave .AND. ln_taw ) THEN ! Wave stress reduction + utau(:,:) = utau(:,:) - tawx(:,:) + twox(:,:) + vtau(:,:) = vtau(:,:) - tawy(:,:) + twoy(:,:) + CALL lbc_lnk( 'sbcwave', utau, 'U', -1._wp ) + CALL lbc_lnk( 'sbcwave', vtau, 'V', -1._wp ) + ! + DO_2D( 0, 0, 0, 0) + taum(ji,jj) = sqrt((.5*(utau(ji-1,jj)+utau(ji,jj)))**2 + (.5*(vtau(ji,jj-1)+vtau(ji,jj)))**2) + END_2D + ! + IF( kt == nit000 ) CALL ctl_warn( 'sbc: You are subtracting the wave stress to the ocean.', & + & 'If not requested select ln_taw=.false.' ) + ! + ENDIF + CALL lbc_lnk( 'sbcmod', taum(:,:), 'T', 1._wp ) + ! + IF( ln_icebergs ) THEN ! save pure stresses (with no ice-ocean stress) for use by icebergs + utau_icb(:,:) = utau(:,:) ; vtau_icb(:,:) = vtau(:,:) + ENDIF + ! + ! !== Misc. Options ==! + ! + SELECT CASE( nn_ice ) ! Update heat and freshwater fluxes over sea-ice areas + CASE( 1 ) ; CALL sbc_ice_if ( kt, Kbb, Kmm ) ! Ice-cover climatology ("Ice-if" model) +#if defined key_si3 + CASE( 2 ) ; CALL ice_stp ( kt, Kbb, Kmm, nsbc ) ! SI3 ice model +#endif + CASE( 3 ) ; CALL sbc_ice_cice ( kt, nsbc ) ! CICE ice model + END SELECT + + IF( ln_icebergs ) CALL icb_stp( kt, Kmm ) ! compute icebergs + + ! Icebergs do not melt over the haloes. + ! So emp values over the haloes are no more consistent with the inner domain values. + ! A lbc_lnk is therefore needed to ensure reproducibility and restartability. + ! see ticket #2113 for discussion about this lbc_lnk. + ! The lbc_lnk is also needed for SI3 with nn_hls > 1 as emp is not yet defined for these points in iceupdate.F90 + IF( (ln_icebergs .AND. .NOT. ln_passive_mode) .OR. (nn_ice == 2 .AND. nn_hls == 2) ) THEN + CALL lbc_lnk( 'sbcmod', emp, 'T', 1.0_wp ) + ENDIF + + IF( ln_rnf ) CALL sbc_rnf( kt ) ! add runoffs to fresh water fluxes + + IF( ln_ssr ) CALL sbc_ssr( kt ) ! add SST/SSS damping term + + IF( nn_fwb /= 0 ) CALL sbc_fwb( kt, nn_fwb, nn_fsbc, Kmm ) ! control the freshwater budget + + ! Special treatment of freshwater fluxes over closed seas in the model domain + ! Should not be run if ln_diurnal_only + IF( l_sbc_clo ) CALL sbc_clo( kt ) + +!!$!RBbug do not understand why see ticket 667 +!!$!clem: it looks like it is necessary for the north fold (in certain circumstances). Don't know why. +!!$ CALL lbc_lnk( 'sbcmod', emp, 'T', 1.0_wp ) + IF( ll_wd ) THEN ! If near WAD point limit the flux for now + zthscl = atanh(rn_wd_sbcfra) ! taper frac default is .999 + zwdht(:,:) = ssh(:,:,Kmm) + ht_0(:,:) - rn_wdmin1 ! do this calc of water + ! depth above wd limit once + WHERE( zwdht(:,:) <= 0.0 ) + taum(:,:) = 0.0 + utau(:,:) = 0.0 + vtau(:,:) = 0.0 + qns (:,:) = 0.0 + qsr (:,:) = 0.0 + emp (:,:) = min(emp(:,:),0.0) !can allow puddles to grow but not shrink + sfx (:,:) = 0.0 + END WHERE + zwght(:,:) = tanh(zthscl*zwdht(:,:)) + WHERE( zwdht(:,:) > 0.0 .and. zwdht(:,:) < rn_wd_sbcdep ) ! 5 m hard limit here is arbitrary + qsr (:,:) = qsr(:,:) * zwght(:,:) + qns (:,:) = qns(:,:) * zwght(:,:) + taum (:,:) = taum(:,:) * zwght(:,:) + utau (:,:) = utau(:,:) * zwght(:,:) + vtau (:,:) = vtau(:,:) * zwght(:,:) + sfx (:,:) = sfx(:,:) * zwght(:,:) + emp (:,:) = emp(:,:) * zwght(:,:) + END WHERE + ENDIF + ! + IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! + ! ! ---------------------------------------- ! + IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN !* Restart: read in restart file + IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields read in the restart file' + CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b ) ! i-stress + CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b ) ! j-stress + CALL iom_get( numror, jpdom_auto, 'qns_b', qns_b ) ! non solar heat flux + CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b ) ! freshwater flux + ! NB: The 3D heat content due to qsr forcing (qsr_hc_b) is treated in traqsr + ! To ensure restart capability with 3.3x/3.4 restart files !! to be removed in v3.6 + IF( iom_varid( numror, 'sfx_b', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, jpdom_auto, 'sfx_b', sfx_b ) ! before salt flux (T-point) + ELSE + sfx_b (:,:) = sfx(:,:) + ENDIF + ELSE !* no restart: set from nit000 values + IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields set to nit000' + utau_b(:,:) = utau(:,:) + vtau_b(:,:) = vtau(:,:) + qns_b (:,:) = qns (:,:) + emp_b (:,:) = emp (:,:) + sfx_b (:,:) = sfx (:,:) + ENDIF + ENDIF + ! ! ---------------------------------------- ! + IF( lrst_oce ) THEN ! Write in the ocean restart file ! + ! ! ---------------------------------------- ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc : ocean surface forcing fields written in ocean restart file ', & + & 'at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~' + CALL iom_rstput( kt, nitrst, numrow, 'utau_b' , utau ) + CALL iom_rstput( kt, nitrst, numrow, 'vtau_b' , vtau ) + CALL iom_rstput( kt, nitrst, numrow, 'qns_b' , qns ) + ! The 3D heat content due to qsr forcing is treated in traqsr + ! CALL iom_rstput( kt, nitrst, numrow, 'qsr_b' , qsr ) + CALL iom_rstput( kt, nitrst, numrow, 'emp_b' , emp ) + CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx ) + ENDIF + ! ! ---------------------------------------- ! + ! ! Outputs and control print ! + ! ! ---------------------------------------- ! + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN + IF( iom_use("empmr") ) THEN + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = emp(ji,jj) - rnf(ji,jj) + END_2D + CALL iom_put( "empmr" , z2d ) ! upward water flux + ENDIF + IF( iom_use("empbmr") ) THEN + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = emp_b(ji,jj) - rnf(ji,jj) + END_2D + CALL iom_put( "empbmr" , z2d ) ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) + ENDIF + CALL iom_put( "saltflx", sfx ) ! downward salt flux (includes virtual salt flux beneath ice in linear free surface case) + CALL iom_put( "fmmflx" , fmmflx ) ! Freezing-melting water flux + IF( iom_use("qt") ) THEN + DO_2D( 0, 0, 0, 0 ) + z2d(ji,jj) = qns(ji,jj) + qsr(ji,jj) + END_2D + CALL iom_put( "qt" , z2d ) ! total heat flux + ENDIF + CALL iom_put( "qns" , qns ) ! solar heat flux + CALL iom_put( "qsr" , qsr ) ! solar heat flux + IF( nn_ice > 0 .OR. ll_opa ) CALL iom_put( "ice_cover", fr_i ) ! ice fraction + CALL iom_put( "taum" , taum ) ! wind stress module + CALL iom_put( "wspd" , wndm ) ! wind speed module over free ocean or leads in presence of sea-ice + CALL iom_put( "qrp" , qrp ) ! heat flux damping + CALL iom_put( "erp" , erp ) ! freshwater flux damping + ENDIF + ! + IF(sn_cfctl%l_prtctl) THEN ! print mean trends (used for debugging) + CALL prt_ctl(tab2d_1=REAL(fr_i,dp) , clinfo1=' fr_i - : ', mask1=tmask ) + CALL prt_ctl(tab2d_1=REAL((emp-rnf),dp) , clinfo1=' emp-rnf - : ', mask1=tmask ) + CALL prt_ctl(tab2d_1=REAL((sfx-rnf),dp) , clinfo1=' sfx-rnf - : ', mask1=tmask ) + CALL prt_ctl(tab2d_1=REAL(qns,dp) , clinfo1=' qns - : ', mask1=tmask ) + CALL prt_ctl(tab2d_1=REAL(qsr ,dp) , clinfo1=' qsr - : ', mask1=tmask ) + CALL prt_ctl(tab3d_1=REAL(tmask ,dp) , clinfo1=' tmask - : ', mask1=tmask, kdim=jpk ) + CALL prt_ctl(tab3d_1=ts(:,:,:,jp_tem,Kmm), clinfo1=' sst - : ', mask1=tmask, kdim=1 ) + CALL prt_ctl(tab3d_1=ts(:,:,:,jp_sal,Kmm), clinfo1=' sss - : ', mask1=tmask, kdim=1 ) + CALL prt_ctl(tab2d_1=REAL(utau ,dp) , clinfo1=' utau - : ', mask1=umask, & + & tab2d_2=REAL(vtau ,dp) , clinfo2=' vtau - : ', mask2=vmask ) + ENDIF + + IF( kt == nitend ) CALL sbc_final ! Close down surface module if necessary + ! + IF( ln_timing ) CALL timing_stop('sbc') + ! + END SUBROUTINE sbc + + + SUBROUTINE sbc_final + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_final *** + !! + !! ** Purpose : Finalize CICE (if used) + !!--------------------------------------------------------------------- + ! + IF( nn_ice == 3 ) CALL cice_sbc_final + ! + END SUBROUTINE sbc_final + + !!====================================================================== +END MODULE sbcmod diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcrnf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcrnf.F90 new file mode 100644 index 0000000..a1bc747 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcrnf.F90 @@ -0,0 +1,542 @@ +MODULE sbcrnf + !!====================================================================== + !! *** MODULE sbcrnf *** + !! Ocean forcing: river runoff + !!===================================================================== + !! History : OPA ! 2000-11 (R. Hordoir, E. Durand) NetCDF FORMAT + !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module + !! 3.0 ! 2006-07 (G. Madec) Surface module + !! 3.2 ! 2009-04 (B. Lemaire) Introduce iom_put + !! 3.3 ! 2010-10 (R. Furner, G. Madec) runoff distributed over ocean levels + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_rnf : monthly runoffs read in a NetCDF file + !! sbc_rnf_init : runoffs initialisation + !! rnf_mouth : set river mouth mask + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbc_oce ! surface boundary condition variables + USE eosbn2 ! Equation Of State + USE closea, ONLY: l_clo_rnf, clo_rnf ! closed seas + ! + USE in_out_manager ! I/O manager + USE fldread ! read input field at current time step + USE iom ! I/O module + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_rnf ! called in sbcmod module + PUBLIC sbc_rnf_div ! called in divhor module + PUBLIC sbc_rnf_alloc ! called in sbcmod module + PUBLIC sbc_rnf_init ! called in sbcmod module + + ! !!* namsbc_rnf namelist * + CHARACTER(len=100) :: cn_dir !: Root directory for location of rnf files + LOGICAL , PUBLIC :: ln_rnf_depth !: depth river runoffs attribute specified in a file + LOGICAL :: ln_rnf_depth_ini !: depth river runoffs computed at the initialisation + REAL(wp) :: rn_rnf_max !: maximum value of the runoff climatologie (ln_rnf_depth_ini =T) + REAL(wp) :: rn_dep_max !: depth over which runoffs is spread (ln_rnf_depth_ini =T) + INTEGER :: nn_rnf_depth_file !: create (=1) a runoff depth file or not (=0) + LOGICAL , PUBLIC :: ln_rnf_icb !: iceberg flux is specified in a file + LOGICAL :: ln_rnf_tem !: temperature river runoffs attribute specified in a file + LOGICAL , PUBLIC :: ln_rnf_sal !: salinity river runoffs attribute specified in a file + TYPE(FLD_N) , PUBLIC :: sn_rnf !: information about the runoff file to be read + TYPE(FLD_N) :: sn_cnf !: information about the runoff mouth file to be read + TYPE(FLD_N) :: sn_i_rnf !: information about the iceberg flux file to be read + TYPE(FLD_N) :: sn_s_rnf !: information about the salinities of runoff file to be read + TYPE(FLD_N) :: sn_t_rnf !: information about the temperatures of runoff file to be read + TYPE(FLD_N) :: sn_dep_rnf !: information about the depth which river inflow affects + LOGICAL , PUBLIC :: ln_rnf_mouth !: specific treatment in mouths vicinity + REAL(wp) :: rn_hrnf !: runoffs, depth over which enhanced vertical mixing is used + REAL(wp) , PUBLIC :: rn_avt_rnf !: runoffs, value of the additional vertical mixing coef. [m2/s] + REAL(wp) , PUBLIC :: rn_rfact !: multiplicative factor for runoff + + LOGICAL , PUBLIC :: l_rnfcpl = .false. !: runoffs recieved from oasis + INTEGER , PUBLIC :: nkrnf = 0 !: nb of levels over which Kz is increased at river mouths + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rnfmsk !: river mouth mask (hori.) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: rnfmsk_z !: river mouth mask (vert.) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h_rnf !: depth of runoff in m + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nk_rnf !: depth of runoff in model levels + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rnf_tsc_b, rnf_tsc !: before and now T & S runoff contents [K.m/s & PSU.m/s] + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_rnf ! structure: river runoff (file information, fields read) + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_i_rnf ! structure: iceberg flux (file information, fields read) + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_s_rnf ! structure: river runoff salinity (file information, fields read) + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_t_rnf ! structure: river runoff temperature (file information, fields read) + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcrnf.F90 15190 2021-08-13 12:52:50Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_rnf_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_rnf_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( rnfmsk(jpi,jpj) , rnfmsk_z(jpk) , & + & h_rnf (jpi,jpj) , nk_rnf (jpi,jpj) , & + & rnf_tsc_b(jpi,jpj,jpts) , rnf_tsc (jpi,jpj,jpts) , STAT=sbc_rnf_alloc ) + ! + CALL mpp_sum ( 'sbcrnf', sbc_rnf_alloc ) + IF( sbc_rnf_alloc > 0 ) CALL ctl_warn('sbc_rnf_alloc: allocation of arrays failed') + END FUNCTION sbc_rnf_alloc + + + SUBROUTINE sbc_rnf( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_rnf *** + !! + !! ** Purpose : Introduce a climatological run off forcing + !! + !! ** Method : Set each river mouth with a monthly climatology + !! provided from different data. + !! CAUTION : upward water flux, runoff forced to be < 0 + !! + !! ** Action : runoff updated runoff field at time-step kt + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + ! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: z_err = 0 ! dummy integer for error handling + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: ztfrz ! freezing point used for temperature correction + ! + ! + ! !-------------------! + ! ! Update runoff ! + ! !-------------------! + ! + ! + IF( .NOT. l_rnfcpl ) THEN + CALL fld_read ( kt, nn_fsbc, sf_rnf ) ! Read Runoffs data and provide it at kt ( runoffs + iceberg ) + IF( ln_rnf_icb ) CALL fld_read ( kt, nn_fsbc, sf_i_rnf ) ! idem for iceberg flux if required + ENDIF + IF( ln_rnf_tem ) CALL fld_read ( kt, nn_fsbc, sf_t_rnf ) ! idem for runoffs temperature if required + IF( ln_rnf_sal ) CALL fld_read ( kt, nn_fsbc, sf_s_rnf ) ! idem for runoffs salinity if required + ! + IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN + ! + IF( .NOT. l_rnfcpl ) THEN + rnf(:,:) = rn_rfact * ( sf_rnf(1)%fnow(:,:,1) ) * tmask(:,:,1) ! updated runoff value at time step kt + IF( ln_rnf_icb ) THEN + fwficb(:,:) = rn_rfact * ( sf_i_rnf(1)%fnow(:,:,1) ) * tmask(:,:,1) ! updated runoff value at time step kt + rnf(:,:) = rnf(:,:) + fwficb(:,:) + qns(:,:) = qns(:,:) - fwficb(:,:) * rLfus + !!qns_tot(:,:) = qns_tot(:,:) - fwficb(:,:) * rLfus + !!qns_oce(:,:) = qns_oce(:,:) - fwficb(:,:) * rLfus + CALL iom_put( 'iceberg_cea' , fwficb(:,:) ) ! output iceberg flux + CALL iom_put( 'hflx_icb_cea' , -fwficb(:,:) * rLfus ) ! output Heat Flux into Sea Water due to Iceberg Thermodynamics --> + ENDIF + ENDIF + ! + ! ! set temperature & salinity content of runoffs + IF( ln_rnf_tem ) THEN ! use runoffs temperature data + rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rho0 + CALL eos_fzp( sss_m(:,:), ztfrz(:,:) ) + WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999._wp ) ! if missing data value use SST as runoffs temperature + rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rho0 + END WHERE + ELSE ! use SST as runoffs temperature + !CEOD River is fresh water so must at least be 0 unless we consider ice + rnf_tsc(:,:,jp_tem) = MAX( sst_m(:,:), 0.0_wp ) * rnf(:,:) * r1_rho0 + ENDIF + ! ! use runoffs salinity data + IF( ln_rnf_sal ) rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rho0 + ! ! else use S=0 for runoffs (done one for all in the init) + CALL iom_put( 'runoffs' , rnf(:,:) ) ! output runoff mass flux + IF( iom_use('hflx_rnf_cea') ) CALL iom_put( 'hflx_rnf_cea', rnf_tsc(:,:,jp_tem) * rho0 * rcp ) ! output runoff sensible heat (W/m2) + IF( iom_use('sflx_rnf_cea') ) CALL iom_put( 'sflx_rnf_cea', rnf_tsc(:,:,jp_sal) * rho0 ) ! output runoff salt flux (g/m2/s) + ENDIF + ! + ! ! ---------------------------------------- ! + IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! + ! ! ---------------------------------------- ! + IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN !* Restart: read in restart file + IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields red in the restart file', lrxios + CALL iom_get( numror, jpdom_auto, 'rnf_b' , rnf_b ) ! before runoff + CALL iom_get( numror, jpdom_auto, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem) ) ! before heat content of runoff + CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal) ) ! before salinity content of runoff + ELSE !* no restart: set from nit000 values + IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields set to nit000' + rnf_b (:,: ) = rnf (:,: ) + rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) + ENDIF + ENDIF + ! ! ---------------------------------------- ! + IF( lrst_oce ) THEN ! Write in the ocean restart file ! + ! ! ---------------------------------------- ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbcrnf : runoff forcing fields written in ocean restart file ', & + & 'at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~' + CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf ) + CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem) ) + CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal) ) + ENDIF + ! + END SUBROUTINE sbc_rnf + + + SUBROUTINE sbc_rnf_div( phdivn, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_rnf *** + !! + !! ** Purpose : update the horizontal divergence with the runoff inflow + !! + !! ** Method : + !! CAUTION : rnf is positive (inflow) decreasing the + !! divergence and expressed in m/s + !! + !! ** Action : phdivn decreased by the runoff inflow + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phdivn ! horizontal divergence + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zfact ! local scalar + !!---------------------------------------------------------------------- + ! + zfact = 0.5_wp + ! + IF( ln_rnf_depth .OR. ln_rnf_depth_ini ) THEN !== runoff distributed over several levels ==! + IF( ln_linssh ) THEN !* constant volume case : just apply the runoff input flow + DO_2D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls ) + DO jk = 1, nk_rnf(ji,jj) + phdivn(ji,jj,jk) = phdivn(ji,jj,jk) - ( rnf(ji,jj) + rnf_b(ji,jj) ) * zfact * r1_rho0 / h_rnf(ji,jj) + END DO + END_2D + ELSE !* variable volume case + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) ! update the depth over which runoffs are distributed + h_rnf(ji,jj) = 0._wp + DO jk = 1, nk_rnf(ji,jj) ! recalculates h_rnf to be the depth in metres + h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm) ! to the bottom of the relevant grid box + END DO + END_2D + DO_2D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls ) ! apply the runoff input flow + DO jk = 1, nk_rnf(ji,jj) + phdivn(ji,jj,jk) = phdivn(ji,jj,jk) - ( rnf(ji,jj) + rnf_b(ji,jj) ) * zfact * r1_rho0 / h_rnf(ji,jj) + END DO + END_2D + ENDIF + ELSE !== runoff put only at the surface ==! + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + h_rnf (ji,jj) = e3t(ji,jj,1,Kmm) ! update h_rnf to be depth of top box + END_2D + DO_2D_OVR( nn_hls-1, nn_hls, nn_hls-1, nn_hls ) + phdivn(ji,jj,1) = phdivn(ji,jj,1) - ( rnf(ji,jj) + rnf_b(ji,jj) ) * zfact * r1_rho0 / e3t(ji,jj,1,Kmm) + END_2D + ENDIF + ! + END SUBROUTINE sbc_rnf_div + + + SUBROUTINE sbc_rnf_init( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_rnf_init *** + !! + !! ** Purpose : Initialisation of the runoffs if (ln_rnf=T) + !! + !! ** Method : - read the runoff namsbc_rnf namelist + !! + !! ** Action : - read parameters + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + CHARACTER(len=32) :: rn_dep_file ! runoff file name + INTEGER :: ji, jj, jk, jm ! dummy loop indices + INTEGER :: ierror, inum ! temporary integer + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: nbrec ! temporary integer + REAL(wp) :: zacoef + REAL(wp), DIMENSION(jpi,jpj,2) :: zrnfcl + !! + NAMELIST/namsbc_rnf/ cn_dir , ln_rnf_depth, ln_rnf_tem, ln_rnf_sal, ln_rnf_icb, & + & sn_rnf, sn_cnf , sn_i_rnf, sn_s_rnf , sn_t_rnf , sn_dep_rnf, & + & ln_rnf_mouth , rn_hrnf , rn_avt_rnf, rn_rfact, & + & ln_rnf_depth_ini , rn_dep_max , rn_rnf_max, nn_rnf_depth_file + !!---------------------------------------------------------------------- + ! + ! !== allocate runoff arrays + IF( sbc_rnf_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_rnf_alloc : unable to allocate arrays' ) + ! + IF( .NOT. ln_rnf ) THEN ! no specific treatment in vicinity of river mouths + ln_rnf_mouth = .FALSE. ! default definition needed for example by sbc_ssr or by tra_adv_muscl + nkrnf = 0 + rnf (:,:) = 0.0_wp + rnf_b (:,:) = 0.0_wp + rnfmsk (:,:) = 0.0_wp + rnfmsk_z(:) = 0.0_wp + RETURN + ENDIF + ! + ! ! ============ + ! ! Namelist + ! ! ============ + ! + READ ( numnam_ref, namsbc_rnf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in reference namelist' ) + + READ ( numnam_cfg, namsbc_rnf, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_rnf ) + ! + ! ! Control print + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_rnf_init : runoff ' + WRITE(numout,*) '~~~~~~~~~~~~ ' + WRITE(numout,*) ' Namelist namsbc_rnf' + WRITE(numout,*) ' specific river mouths treatment ln_rnf_mouth = ', ln_rnf_mouth + WRITE(numout,*) ' river mouth additional Kz rn_avt_rnf = ', rn_avt_rnf + WRITE(numout,*) ' depth of river mouth additional mixing rn_hrnf = ', rn_hrnf + WRITE(numout,*) ' multiplicative factor for runoff rn_rfact = ', rn_rfact + ENDIF + ! ! ================== + ! ! Type of runoff + ! ! ================== + ! + IF( .NOT. l_rnfcpl ) THEN + ALLOCATE( sf_rnf(1), STAT=ierror ) ! Create sf_rnf structure (runoff inflow) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> runoffs inflow read in a file' + IF( ierror > 0 ) THEN + CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_rnf structure' ) ; RETURN + ENDIF + ALLOCATE( sf_rnf(1)%fnow(jpi,jpj,1) ) + IF( sn_rnf%ln_tint ) ALLOCATE( sf_rnf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_rnf, (/ sn_rnf /), cn_dir, 'sbc_rnf_init', 'read runoffs data', 'namsbc_rnf', no_print ) + ! + IF( ln_rnf_icb ) THEN ! Create (if required) sf_i_rnf structure + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' iceberg flux read in a file' + ALLOCATE( sf_i_rnf(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_i_rnf structure' ) ; RETURN + ENDIF + ALLOCATE( sf_i_rnf(1)%fnow(jpi,jpj,1) ) + IF( sn_i_rnf%ln_tint ) ALLOCATE( sf_i_rnf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill (sf_i_rnf, (/ sn_i_rnf /), cn_dir, 'sbc_rnf_init', 'read iceberg flux data', 'namsbc_rnf' ) + ELSE + fwficb(:,:) = 0._wp + ENDIF + + ENDIF + ! + IF( ln_rnf_tem ) THEN ! Create (if required) sf_t_rnf structure + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> runoffs temperatures read in a file' + ALLOCATE( sf_t_rnf(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_t_rnf structure' ) ; RETURN + ENDIF + ALLOCATE( sf_t_rnf(1)%fnow(jpi,jpj,1) ) + IF( sn_t_rnf%ln_tint ) ALLOCATE( sf_t_rnf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill (sf_t_rnf, (/ sn_t_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff temperature data', 'namsbc_rnf', no_print ) + ENDIF + ! + IF( ln_rnf_sal ) THEN ! Create (if required) sf_s_rnf and sf_t_rnf structures + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> runoffs salinities read in a file' + ALLOCATE( sf_s_rnf(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'sbc_rnf_init: unable to allocate sf_s_rnf structure' ) ; RETURN + ENDIF + ALLOCATE( sf_s_rnf(1)%fnow(jpi,jpj,1) ) + IF( sn_s_rnf%ln_tint ) ALLOCATE( sf_s_rnf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill (sf_s_rnf, (/ sn_s_rnf /), cn_dir, 'sbc_rnf_init', 'read runoff salinity data', 'namsbc_rnf', no_print ) + ENDIF + ! + IF( ln_rnf_depth ) THEN ! depth of runoffs set from a file + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> runoffs depth read in a file' + rn_dep_file = TRIM( cn_dir )//TRIM( sn_dep_rnf%clname ) + IF( .NOT. sn_dep_rnf%ln_clim ) THEN ; WRITE(rn_dep_file, '(a,"_y",i4)' ) TRIM( rn_dep_file ), nyear ! add year + IF( sn_dep_rnf%clftyp == 'monthly' ) WRITE(rn_dep_file, '(a,"m",i2)' ) TRIM( rn_dep_file ), nmonth ! add month + ENDIF + CALL iom_open ( rn_dep_file, inum ) ! open file + CALL iom_get ( inum, jpdom_global, sn_dep_rnf%clvar, h_rnf ) ! read the river mouth array + CALL iom_close( inum ) ! close file + ! + nk_rnf(:,:) = 0 ! set the number of level over which river runoffs are applied + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + IF( h_rnf(ji,jj) > 0._wp ) THEN + jk = 2 + DO WHILE ( jk < mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1 + END DO + nk_rnf(ji,jj) = jk + ELSEIF( h_rnf(ji,jj) == -1._wp ) THEN ; nk_rnf(ji,jj) = 1 + ELSEIF( h_rnf(ji,jj) == -999._wp ) THEN ; nk_rnf(ji,jj) = mbkt(ji,jj) + ELSE + CALL ctl_stop( 'sbc_rnf_init: runoff depth not positive, and not -999 or -1, rnf value in file fort.999' ) + WRITE(999,*) 'ji, jj, h_rnf(ji,jj) :', ji, jj, h_rnf(ji,jj) + ENDIF + END_2D + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! set the associated depth + h_rnf(ji,jj) = 0._wp + DO jk = 1, nk_rnf(ji,jj) + h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm) + END DO + END_2D + ! + ELSE IF( ln_rnf_depth_ini ) THEN ! runoffs applied at the surface + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> depth of runoff computed once from max value of runoff' + IF(lwp) WRITE(numout,*) ' max value of the runoff climatologie (over global domain) rn_rnf_max = ', rn_rnf_max + IF(lwp) WRITE(numout,*) ' depth over which runoffs is spread rn_dep_max = ', rn_dep_max + IF(lwp) WRITE(numout,*) ' create (=1) a runoff depth file or not (=0) nn_rnf_depth_file = ', nn_rnf_depth_file + + CALL iom_open( TRIM( sn_rnf%clname ), inum ) ! open runoff file + nbrec = iom_getszuld( inum ) + zrnfcl(:,:,1) = 0._wp ! init the max to 0. in 1 + DO jm = 1, nbrec + CALL iom_get( inum, jpdom_global, TRIM( sn_rnf%clvar ), zrnfcl(:,:,2), jm ) ! read the value in 2 + zrnfcl(:,:,1) = MAXVAL( zrnfcl(:,:,:), DIM=3 ) ! store the maximum value in time in 1 + END DO + CALL iom_close( inum ) + ! + h_rnf(:,:) = 1. + ! + zacoef = rn_dep_max / rn_rnf_max ! coef of linear relation between runoff and its depth (150m for max of runoff) + ! + WHERE( zrnfcl(:,:,1) > 0._wp ) h_rnf(:,:) = zacoef * zrnfcl(:,:,1) ! compute depth for all runoffs + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! take in account min depth of ocean rn_hmin + IF( zrnfcl(ji,jj,1) > 0._wp ) THEN + jk = mbkt(ji,jj) + h_rnf(ji,jj) = MIN( h_rnf(ji,jj), gdept_0(ji,jj,jk ) ) + ENDIF + END_2D + ! + nk_rnf(:,:) = 0 ! number of levels on which runoffs are distributed + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + IF( zrnfcl(ji,jj,1) > 0._wp ) THEN + jk = 2 + DO WHILE ( jk < mbkt(ji,jj) .AND. gdept_0(ji,jj,jk) < h_rnf(ji,jj) ) ; jk = jk + 1 + END DO + nk_rnf(ji,jj) = jk + ELSE + nk_rnf(ji,jj) = 1 + ENDIF + END_2D + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! set the associated depth + h_rnf(ji,jj) = 0._wp + DO jk = 1, nk_rnf(ji,jj) + h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm) + END DO + END_2D + ! + IF( nn_rnf_depth_file == 1 ) THEN ! save output nb levels for runoff + IF(lwp) WRITE(numout,*) ' ==>>> create runoff depht file' + CALL iom_open ( TRIM( sn_dep_rnf%clname ), inum, ldwrt = .TRUE. ) + CALL iom_rstput( 0, 0, inum, 'rodepth', h_rnf ) + CALL iom_close ( inum ) + ENDIF + ELSE ! runoffs applied at the surface + nk_rnf(:,:) = 1 + h_rnf (:,:) = e3t(:,:,1,Kmm) + ENDIF + ! + rnf(:,:) = 0._wp ! runoff initialisation + rnf_tsc(:,:,:) = 0._wp ! runoffs temperature & salinty contents initilisation + ! + ! ! ======================== + ! ! River mouth vicinity + ! ! ======================== + ! + IF( ln_rnf_mouth ) THEN ! Specific treatment in vicinity of river mouths : + ! ! - Increase Kz in surface layers ( rn_hrnf > 0 ) + ! ! - set to zero SSS damping (ln_ssr=T) + ! ! - mixed upstream-centered (ln_traadv_cen2=T) + ! + IF( ln_rnf_depth ) CALL ctl_warn( 'sbc_rnf_init: increased mixing turned on but effects may already', & + & 'be spread through depth by ln_rnf_depth' ) + ! + nkrnf = 0 ! Number of level over which Kz increase + IF( rn_hrnf > 0._wp ) THEN + nkrnf = 2 + DO WHILE( nkrnf /= jpkm1 .AND. gdepw_1d(nkrnf+1) < rn_hrnf ) ; nkrnf = nkrnf + 1 + END DO + IF( ln_sco ) CALL ctl_warn( 'sbc_rnf_init: number of levels over which Kz is increased is computed for zco...' ) + ENDIF + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> Specific treatment used in vicinity of river mouths :' + IF(lwp) WRITE(numout,*) ' - Increase Kz in surface layers (if rn_hrnf > 0 )' + IF(lwp) WRITE(numout,*) ' by ', rn_avt_rnf,' m2/s over ', nkrnf, ' w-levels' + IF(lwp) WRITE(numout,*) ' - set to zero SSS damping (if ln_ssr=T)' + IF(lwp) WRITE(numout,*) ' - mixed upstream-centered (if ln_traadv_cen2=T)' + ! + CALL rnf_mouth ! set river mouth mask + ! + ELSE ! No treatment at river mouths + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> No specific treatment at river mouths' + rnfmsk (:,:) = 0._wp + rnfmsk_z(:) = 0._wp + nkrnf = 0 + ENDIF + ! + END SUBROUTINE sbc_rnf_init + + + SUBROUTINE rnf_mouth + !!---------------------------------------------------------------------- + !! *** ROUTINE rnf_mouth *** + !! + !! ** Purpose : define the river mouths mask + !! + !! ** Method : read the river mouth mask (=0/1) in the river runoff + !! climatological file. Defined a given vertical structure. + !! CAUTION, the vertical structure is hard coded on the + !! first 5 levels. + !! This fields can be used to: + !! - set an upstream advection scheme + !! (ln_rnf_mouth=T and ln_traadv_cen2=T) + !! - increase vertical on the top nn_krnf vertical levels + !! at river runoff input grid point (nn_krnf>=2, see step.F90) + !! - set to zero SSS restoring flux at river mouth grid points + !! + !! ** Action : rnfmsk set to 1 at river runoff input, 0 elsewhere + !! rnfmsk_z vertical structure + !!---------------------------------------------------------------------- + INTEGER :: inum ! temporary integers + CHARACTER(len=140) :: cl_rnfile ! runoff file name + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' rnf_mouth : river mouth mask' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~ ' + ! + cl_rnfile = TRIM( cn_dir )//TRIM( sn_cnf%clname ) + IF( .NOT. sn_cnf%ln_clim ) THEN ; WRITE(cl_rnfile, '(a,"_y",i4.4)' ) TRIM( cl_rnfile ), nyear ! add year + IF( sn_cnf%clftyp == 'monthly' ) WRITE(cl_rnfile, '(a,"m" ,i2.2)' ) TRIM( cl_rnfile ), nmonth ! add month + ENDIF + ! + ! horizontal mask (read in NetCDF file) + CALL iom_open ( cl_rnfile, inum ) ! open file + CALL iom_get ( inum, jpdom_global, sn_cnf%clvar, rnfmsk ) ! read the river mouth array + CALL iom_close( inum ) ! close file + ! + IF( l_clo_rnf ) CALL clo_rnf( rnfmsk ) ! closed sea inflow set as river mouth + ! + rnfmsk_z(:) = 0._wp ! vertical structure + rnfmsk_z(1) = 1.0 + rnfmsk_z(2) = 1.0 ! ********** + rnfmsk_z(3) = 0.5 ! HARD CODED on the 5 first levels + rnfmsk_z(4) = 0.25 ! ********** + rnfmsk_z(5) = 0.125 + ! + END SUBROUTINE rnf_mouth + + !!====================================================================== +END MODULE sbcrnf \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcssm.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcssm.F90 new file mode 100644 index 0000000..fa54d2f --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcssm.F90 @@ -0,0 +1,260 @@ +MODULE sbcssm + !!====================================================================== + !! *** MODULE sbcssm *** + !! Surface module : provide time-mean ocean surface variables + !!====================================================================== + !! History : 9.0 ! 2006-07 (G. Madec) Original code + !! 3.3 ! 2010-10 (C. Bricaud, G. Madec) add the Patm forcing for sea-ice + !! 3.7 ! 2015-11 (G. Madec) non linear free surface by default: e3t_m always computed + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_ssm : calculate sea surface mean currents, temperature, + !! and salinity over nn_fsbc time-step + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface boundary condition: ocean fields + USE sbcapr ! surface boundary condition: atmospheric pressure + USE eosbn2 ! equation of state and related derivatives + USE traqsr, ONLY: ln_traqsr + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE iom ! IOM library + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_ssm ! routine called by step.F90 + PUBLIC sbc_ssm_init ! routine called by sbcmod.F90 + + LOGICAL, SAVE :: l_ssm_mean = .FALSE. ! keep track of whether means have been read from restart file + +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcssm.F90 15145 2021-07-26 16:16:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_ssm( kt, Kbb, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_oce *** + !! + !! ** Purpose : provide ocean surface variable to sea-surface boundary + !! condition computation + !! + !! ** Method : compute mean surface velocity (2 components at U and + !! V-points) [m/s], temperature [Celsius] and salinity [psu] over + !! the periode (kt - nn_fsbc) to kt + !! Note that the inverse barometer ssh (i.e. ssh associated with Patm) + !! is add to ssh_m when ln_apr_dyn = T. Required for sea-ice dynamics. + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + ! + INTEGER :: ji, jj ! loop index + REAL(wp) :: zcoef, zf_sbc ! local scalar + REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts + !!--------------------------------------------------------------------- + ! + ! !* surface T-, U-, V- ocean level variables (T, S, depth, velocity) + zts(:,:,jp_tem) = ts(:,:,1,jp_tem,Kmm) + zts(:,:,jp_sal) = ts(:,:,1,jp_sal,Kmm) + ! + ! ! ---------------------------------------- ! + IF( nn_fsbc == 1 ) THEN ! Instantaneous surface fields ! + ! ! ---------------------------------------- ! + ssu_m(:,:) = uu(:,:,1,Kbb) + ssv_m(:,:) = vv(:,:,1,Kbb) + IF( l_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) + ELSE ; sst_m(:,:) = zts(:,:,jp_tem) + ENDIF + sss_m(:,:) = zts(:,:,jp_sal) + ! ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics) + IF( ln_apr_dyn ) THEN ; ssh_m(:,:) = ssh(:,:,Kmm) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) + ELSE ; ssh_m(:,:) = ssh(:,:,Kmm) + ENDIF + ! + e3t_m(:,:) = e3t(:,:,1,Kmm) + ! + frq_m(:,:) = fraqsr_1lev(:,:) + ! + ELSE + ! ! ----------------------------------------------- ! + IF( kt == nit000 .AND. .NOT. l_ssm_mean ) THEN ! Initialisation: 1st time-step, no input means ! + ! ! ----------------------------------------------- ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc_ssm : mean fields initialised to instantaneous values' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + zcoef = REAL( nn_fsbc - 1, wp ) + ssu_m(:,:) = zcoef * uu(:,:,1,Kbb) + ssv_m(:,:) = zcoef * vv(:,:,1,Kbb) + IF( l_useCT ) THEN ; sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) + ELSE ; sst_m(:,:) = zcoef * zts(:,:,jp_tem) + ENDIF + sss_m(:,:) = zcoef * zts(:,:,jp_sal) + ! ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics) + IF( ln_apr_dyn ) THEN ; ssh_m(:,:) = zcoef * ( ssh(:,:,Kmm) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) ) + ELSE ; ssh_m(:,:) = zcoef * ssh(:,:,Kmm) + ENDIF + ! + e3t_m(:,:) = zcoef * e3t(:,:,1,Kmm) + ! + frq_m(:,:) = zcoef * fraqsr_1lev(:,:) + ! ! ---------------------------------------- ! + ELSEIF( MOD( kt - 2 , nn_fsbc ) == 0 ) THEN ! Initialisation: New mean computation ! + ! ! ---------------------------------------- ! + ssu_m(:,:) = 0._wp ! reset to zero ocean mean sbc fields + ssv_m(:,:) = 0._wp + sst_m(:,:) = 0._wp + sss_m(:,:) = 0._wp + ssh_m(:,:) = 0._wp + e3t_m(:,:) = 0._wp + frq_m(:,:) = 0._wp + ENDIF + ! ! ---------------------------------------- ! + ! ! Cumulate at each time step ! + ! ! ---------------------------------------- ! + ssu_m(:,:) = ssu_m(:,:) + uu(:,:,1,Kbb) + ssv_m(:,:) = ssv_m(:,:) + vv(:,:,1,Kbb) + IF( l_useCT ) THEN ; sst_m(:,:) = sst_m(:,:) + eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) + ELSE ; sst_m(:,:) = sst_m(:,:) + zts(:,:,jp_tem) + ENDIF + sss_m(:,:) = sss_m(:,:) + zts(:,:,jp_sal) + ! ! removed inverse barometer ssh when Patm forcing is used (for sea-ice dynamics) + IF( ln_apr_dyn ) THEN ; ssh_m(:,:) = ssh_m(:,:) + ssh(:,:,Kmm) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) + ELSE ; ssh_m(:,:) = ssh_m(:,:) + ssh(:,:,Kmm) + ENDIF + ! + e3t_m(:,:) = e3t_m(:,:) + e3t(:,:,1,Kmm) + ! + frq_m(:,:) = frq_m(:,:) + fraqsr_1lev(:,:) + + ! ! ---------------------------------------- ! + IF( MOD( kt - 1 , nn_fsbc ) == 0 ) THEN ! Mean value at each nn_fsbc time-step ! + ! ! ---------------------------------------- ! + zcoef = 1. / REAL( nn_fsbc, wp ) + sst_m(:,:) = sst_m(:,:) * zcoef ! mean SST [Celsius] + sss_m(:,:) = sss_m(:,:) * zcoef ! mean SSS [psu] + ssu_m(:,:) = ssu_m(:,:) * zcoef ! mean suface current [m/s] + ssv_m(:,:) = ssv_m(:,:) * zcoef ! + ssh_m(:,:) = ssh_m(:,:) * zcoef ! mean SSH [m] + e3t_m(:,:) = e3t_m(:,:) * zcoef ! mean vertical scale factor [m] + frq_m(:,:) = frq_m(:,:) * zcoef ! mean fraction of solar net radiation absorbed in the 1st T level [-] + ! + ENDIF + ! ! ---------------------------------------- ! + IF( lrst_oce ) THEN ! Write in the ocean restart file ! + ! ! ---------------------------------------- ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc_ssm : sea surface mean fields written in ocean restart file ', & + & 'at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~~~~' + zf_sbc = REAL( nn_fsbc, wp ) + CALL iom_rstput( kt, nitrst, numrow, 'nn_fsbc', zf_sbc ) ! sbc frequency + CALL iom_rstput( kt, nitrst, numrow, 'ssu_m' , ssu_m ) ! sea surface mean fields + CALL iom_rstput( kt, nitrst, numrow, 'ssv_m' , ssv_m ) + CALL iom_rstput( kt, nitrst, numrow, 'sst_m' , sst_m ) + CALL iom_rstput( kt, nitrst, numrow, 'sss_m' , sss_m ) + CALL iom_rstput( kt, nitrst, numrow, 'ssh_m' , ssh_m ) + CALL iom_rstput( kt, nitrst, numrow, 'e3t_m' , e3t_m ) + CALL iom_rstput( kt, nitrst, numrow, 'frq_m' , frq_m ) + ! + ENDIF + ! + ENDIF + ! + IF( MOD( kt - 1 , nn_fsbc ) == 0 ) THEN ! Mean value at each nn_fsbc time-step ! + CALL iom_put( 'ssu_m', ssu_m ) + CALL iom_put( 'ssv_m', ssv_m ) + CALL iom_put( 'sst_m', sst_m ) + CALL iom_put( 'sss_m', sss_m ) + CALL iom_put( 'ssh_m', ssh_m ) + CALL iom_put( 'e3t_m', e3t_m ) + CALL iom_put( 'frq_m', frq_m ) + ENDIF + ! + END SUBROUTINE sbc_ssm + + + SUBROUTINE sbc_ssm_init( Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_ssm_init *** + !! + !! ** Purpose : Initialisation of the sbc data + !! + !! ** Action : - read parameters + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices + REAL(wp) :: zcoef, zf_sbc ! local scalar + !!---------------------------------------------------------------------- + ! + IF( nn_fsbc == 1 ) THEN + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc_ssm_init : sea surface mean fields, nn_fsbc=1 : instantaneous values' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ ' + ! + ELSE + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc_ssm_init : sea surface mean fields' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ ' + ! + IF( ln_rstart .AND. iom_varid( numror, 'nn_fsbc', ldstop = .FALSE. ) > 0 ) THEN + l_ssm_mean = .TRUE. + CALL iom_get( numror , 'nn_fsbc', zf_sbc ) ! sbc frequency of previous run + CALL iom_get( numror, jpdom_auto, 'ssu_m' , ssu_m, cd_type = 'U', psgn = -1._dp ) ! sea surface mean velocity (U-point) + CALL iom_get( numror, jpdom_auto, 'ssv_m' , ssv_m, cd_type = 'V', psgn = -1._dp ) ! " " velocity (V-point) + CALL iom_get( numror, jpdom_auto, 'sst_m' , sst_m ) ! " " temperature (T-point) + CALL iom_get( numror, jpdom_auto, 'sss_m' , sss_m ) ! " " salinity (T-point) + CALL iom_get( numror, jpdom_auto, 'ssh_m' , ssh_m ) ! " " height (T-point) + CALL iom_get( numror, jpdom_auto, 'e3t_m' , e3t_m ) ! 1st level thickness (T-point) + ! fraction of solar net radiation absorbed in 1st T level + IF( iom_varid( numror, 'frq_m', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, jpdom_auto, 'frq_m' , frq_m ) + ELSE + frq_m(:,:) = 1._wp ! default definition + ENDIF + ! + IF( zf_sbc /= REAL( nn_fsbc, wp ) ) THEN ! nn_fsbc has changed between 2 runs + IF(lwp) WRITE(numout,*) ' restart with a change in the frequency of mean from ', zf_sbc, ' to ', nn_fsbc + zcoef = REAL( nn_fsbc - 1, wp ) / zf_sbc + ssu_m(:,:) = zcoef * ssu_m(:,:) + ssv_m(:,:) = zcoef * ssv_m(:,:) + sst_m(:,:) = zcoef * sst_m(:,:) + sss_m(:,:) = zcoef * sss_m(:,:) + ssh_m(:,:) = zcoef * ssh_m(:,:) + e3t_m(:,:) = zcoef * e3t_m(:,:) + frq_m(:,:) = zcoef * frq_m(:,:) + ELSE + IF(lwp) WRITE(numout,*) ' mean fields read in the ocean restart file' + ENDIF + ENDIF + ENDIF + ! + IF( .NOT.l_ssm_mean ) THEN ! default initialisation. needed by iceistate + ! + IF(lwp) WRITE(numout,*) ' default initialisation of ss._m arrays' + ssu_m(:,:) = uu(:,:,1,Kbb) + ssv_m(:,:) = vv(:,:,1,Kbb) + IF( l_useCT ) THEN ; sst_m(:,:) =eos_pt_from_ct( CASTSP(ts(:,:,1,jp_tem,Kmm)), CASTSP(ts(:,:,1,jp_sal,Kmm)) ) + ELSE ; sst_m(:,:) = ts(:,:,1,jp_tem,Kmm) + ENDIF + sss_m(:,:) = ts (:,:,1,jp_sal,Kmm) + ssh_m(:,:) = ssh(:,:,Kmm) + e3t_m(:,:) = e3t(:,:,1,Kmm) + frq_m(:,:) = 1._wp + ! + ENDIF + ! + IF( .NOT. ln_traqsr ) fraqsr_1lev(:,:) = 1._wp ! default definition: qsr 100% in the fisrt level + ! + END SUBROUTINE sbc_ssm_init + + !!====================================================================== +END MODULE sbcssm diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcssr.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcssr.F90 new file mode 100644 index 0000000..3984cbf --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcssr.F90 @@ -0,0 +1,256 @@ +MODULE sbcssr + !!====================================================================== + !! *** MODULE sbcssr *** + !! Surface module : heat and fresh water fluxes a restoring term toward observed SST/SSS + !!====================================================================== + !! History : 3.0 ! 2006-06 (G. Madec) Original code + !! 3.2 ! 2009-04 (B. Lemaire) Introduce iom_put + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_ssr : add to sbc a restoring term toward SST/SSS climatology + !! sbc_ssr_init : initialisation of surface restoring + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! surface boundary condition + USE phycst ! physical constants + USE sbcrnf ! surface boundary condition : runoffs + ! + USE fldread ! read input fields + USE in_out_manager ! I/O manager + USE iom ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_ssr ! routine called in sbcmod + PUBLIC sbc_ssr_init ! routine called in sbcmod + PUBLIC sbc_ssr_alloc ! routine called in sbcmod + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: erp !: evaporation damping [kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qrp !: heat flux damping [w/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: coefice !: under ice relaxation coefficient + + ! !!* Namelist namsbc_ssr * + INTEGER, PUBLIC :: nn_sstr ! SST/SSS restoring indicator + INTEGER, PUBLIC :: nn_sssr ! SST/SSS restoring indicator + REAL(wp) :: rn_dqdt ! restoring factor on SST and SSS + REAL(wp) :: rn_deds ! restoring factor on SST and SSS + LOGICAL :: ln_sssr_bnd ! flag to bound erp term + REAL(wp) :: rn_sssr_bnd ! ABS(Max./Min.) value of erp term [mm/day] + INTEGER :: nn_sssr_ice ! Control of restoring under ice + + REAL(wp) , ALLOCATABLE, DIMENSION(:) :: buffer ! Temporary buffer for exchange + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_sst ! structure of input SST (file informations, fields read) + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_sss ! structure of input SSS (file informations, fields read) + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcssr.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_ssr( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_ssr *** + !! + !! ** Purpose : Add to heat and/or freshwater fluxes a damping term + !! toward observed SST and/or SSS. + !! + !! ** Method : - Read namelist namsbc_ssr + !! - Read observed SST and/or SSS + !! - at each nscb time step + !! add a retroaction term on qns (nn_sstr = 1) + !! add a damping term on sfx (nn_sssr = 1) + !! add a damping term on emp (nn_sssr = 2) + !!--------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time step + !! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zerp ! local scalar for evaporation damping + REAL(wp) :: zqrp ! local scalar for heat flux damping + REAL(wp) :: zsrp ! local scalar for unit conversion of rn_deds factor + REAL(wp) :: zerp_bnd ! local scalar for unit conversion of rn_epr_max factor + INTEGER :: ierror ! return error code + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files + TYPE(FLD_N) :: sn_sst, sn_sss ! informations about the fields to be read + !!---------------------------------------------------------------------- + ! + IF( nn_sstr + nn_sssr /= 0 ) THEN + ! + IF( nn_sstr == 1) CALL fld_read( kt, nn_fsbc, sf_sst ) ! Read SST data and provides it at kt + IF( nn_sssr >= 1) CALL fld_read( kt, nn_fsbc, sf_sss ) ! Read SSS data and provides it at kt + ! + ! ! ========================= ! + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! Add restoring term ! + ! ! ========================= ! + ! + qrp(:,:) = 0._wp ! necessary init + erp(:,:) = 0._wp + ! + IF( nn_sstr == 1 ) THEN !* Temperature restoring term + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zqrp = rn_dqdt * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) ) * tmask(ji,jj,1) + qns(ji,jj) = qns(ji,jj) + zqrp + qrp(ji,jj) = zqrp + END_2D + ENDIF + ! + IF( nn_sssr /= 0 .AND. nn_sssr_ice /= 1 ) THEN + ! use fraction of ice ( fr_i ) to adjust relaxation under ice if nn_sssr_ice .ne. 1 + ! n.b. coefice is initialised and fixed to 1._wp if nn_sssr_ice = 1 + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + SELECT CASE ( nn_sssr_ice ) + CASE ( 0 ) ; coefice(ji,jj) = 1._wp - fr_i(ji,jj) ! no/reduced damping under ice + CASE DEFAULT ; coefice(ji,jj) = 1._wp + ( nn_sssr_ice - 1 ) * fr_i(ji,jj) ! reinforced damping (x nn_sssr_ice) under ice ) + END SELECT + END_2D + ENDIF + ! + IF( nn_sssr == 1 ) THEN !* Salinity damping term (salt flux only (sfx)) + zsrp = rn_deds / rday ! from [mm/day] to [kg/m2/s] + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) ) & ! No damping in vicinity of river mouths + & * coefice(ji,jj) & ! Optional control of damping under sea-ice + & * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) * tmask(ji,jj,1) + sfx(ji,jj) = sfx(ji,jj) + zerp ! salt flux + erp(ji,jj) = zerp / MAX( sss_m(ji,jj), 1.e-20 ) ! converted into an equivalent volume flux (diagnostic only) + END_2D + ! + ELSEIF( nn_sssr == 2 ) THEN !* Salinity damping term (volume flux (emp) and associated heat flux (qns) + zsrp = rn_deds / rday ! from [mm/day] to [kg/m2/s] + zerp_bnd = rn_sssr_bnd / rday ! - - + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zerp = zsrp * ( 1. - 2.*rnfmsk(ji,jj) ) & ! No damping in vicinity of river mouths + & * coefice(ji,jj) & ! Optional control of damping under sea-ice + & * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) ) & + & / MAX( sss_m(ji,jj), 1.e-20 ) * tmask(ji,jj,1) + IF( ln_sssr_bnd ) zerp = SIGN( 1.0_wp, zerp ) * MIN( zerp_bnd, ABS(zerp) ) + emp(ji,jj) = emp (ji,jj) + zerp + qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj) + erp(ji,jj) = zerp + qrp(ji,jj) = qrp(ji,jj) - zerp * rcp * sst_m(ji,jj) + END_2D + ENDIF + ! outputs + CALL iom_put( 'hflx_ssr_cea', qrp(:,:) ) + IF( nn_sssr == 1 ) CALL iom_put( 'sflx_ssr_cea', erp(:,:) * sss_m(:,:) ) + IF( nn_sssr == 2 ) CALL iom_put( 'vflx_ssr_cea', -erp(:,:) ) + ! + ENDIF + ! + ENDIF + ! + END SUBROUTINE sbc_ssr + + + SUBROUTINE sbc_ssr_init + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_ssr_init *** + !! + !! ** Purpose : initialisation of surface damping term + !! + !! ** Method : - Read namelist namsbc_ssr + !! - Read observed SST and/or SSS if required + !!--------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zerp ! local scalar for evaporation damping + REAL(wp) :: zqrp ! local scalar for heat flux damping + REAL(wp) :: zsrp ! local scalar for unit conversion of rn_deds factor + REAL(wp) :: zerp_bnd ! local scalar for unit conversion of rn_epr_max factor + INTEGER :: ierror ! return error code + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files + TYPE(FLD_N) :: sn_sst, sn_sss ! informations about the fields to be read + NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, & + & sn_sss, ln_sssr_bnd, rn_sssr_bnd, nn_sssr_ice + INTEGER :: ios + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_ssr : SST and/or SSS damping term ' + WRITE(numout,*) '~~~~~~~ ' + ENDIF + ! + READ ( numnam_ref, namsbc_ssr, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist' ) + + READ ( numnam_cfg, namsbc_ssr, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_ssr ) + + IF(lwp) THEN !* control print + WRITE(numout,*) ' Namelist namsbc_ssr :' + WRITE(numout,*) ' SST restoring term (Yes=1) nn_sstr = ', nn_sstr + WRITE(numout,*) ' dQ/dT (restoring magnitude on SST) rn_dqdt = ', rn_dqdt, ' W/m2/K' + WRITE(numout,*) ' SSS damping term (Yes=1, salt flux) nn_sssr = ', nn_sssr + WRITE(numout,*) ' (Yes=2, volume flux) ' + WRITE(numout,*) ' dE/dS (restoring magnitude on SST) rn_deds = ', rn_deds, ' mm/day' + WRITE(numout,*) ' flag to bound erp term ln_sssr_bnd = ', ln_sssr_bnd + WRITE(numout,*) ' ABS(Max./Min.) erp threshold rn_sssr_bnd = ', rn_sssr_bnd, ' mm/day' + WRITE(numout,*) ' Cntrl of surface restoration under ice nn_sssr_ice = ', nn_sssr_ice + WRITE(numout,*) ' ( 0 = no restoration under ice)' + WRITE(numout,*) ' ( 1 = restoration everywhere )' + WRITE(numout,*) ' (>1 = enhanced restoration under ice )' + ENDIF + ! + IF( nn_sstr == 1 ) THEN !* set sf_sst structure & allocate arrays + ! + ALLOCATE( sf_sst(1), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst structure' ) + ALLOCATE( sf_sst(1)%fnow(jpi,jpj,1), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst now array' ) + ! + ! fill sf_sst with sn_sst and control print + CALL fld_fill( sf_sst, (/ sn_sst /), cn_dir, 'sbc_ssr', 'SST restoring term toward SST data', 'namsbc_ssr', no_print ) + IF( sf_sst(1)%ln_tint ) ALLOCATE( sf_sst(1)%fdta(jpi,jpj,1,2), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sst data array' ) + ! + ENDIF + ! + IF( nn_sssr >= 1 ) THEN !* set sf_sss structure & allocate arrays + ! + ALLOCATE( sf_sss(1), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss structure' ) + ALLOCATE( sf_sss(1)%fnow(jpi,jpj,1), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss now array' ) + ! + ! fill sf_sss with sn_sss and control print + CALL fld_fill( sf_sss, (/ sn_sss /), cn_dir, 'sbc_ssr', 'SSS restoring term toward SSS data', 'namsbc_ssr', no_print ) + IF( sf_sss(1)%ln_tint ) ALLOCATE( sf_sss(1)%fdta(jpi,jpj,1,2), STAT=ierror ) + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_ssr: unable to allocate sf_sss data array' ) + ! + ENDIF + ! + coefice(:,:) = 1._wp ! Initialise coefice to 1._wp ; will not need to be changed if nn_sssr_ice=1 + ! !* Initialize qrp and erp if no restoring + IF( nn_sstr /= 1 ) qrp(:,:) = 0._wp + IF( nn_sssr /= 1 .OR. nn_sssr /= 2 ) erp(:,:) = 0._wp + ! + END SUBROUTINE sbc_ssr_init + + INTEGER FUNCTION sbc_ssr_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_ssr_alloc *** + !!---------------------------------------------------------------------- + sbc_ssr_alloc = 0 ! set to zero if no array to be allocated + IF( .NOT. ALLOCATED( erp ) ) THEN + ALLOCATE( qrp(jpi,jpj), erp(jpi,jpj), coefice(jpi,jpj), STAT= sbc_ssr_alloc ) + ! + IF( lk_mpp ) CALL mpp_sum ( 'sbcssr', sbc_ssr_alloc ) + IF( sbc_ssr_alloc /= 0 ) CALL ctl_warn('sbc_ssr_alloc: failed to allocate arrays.') + ! + ENDIF + END FUNCTION + + !!====================================================================== +END MODULE sbcssr \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcwave.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcwave.F90 new file mode 100644 index 0000000..a9435f9 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/SBC/sbcwave.F90 @@ -0,0 +1,534 @@ +MODULE sbcwave + !!====================================================================== + !! *** MODULE sbcwave *** + !! Wave module + !!====================================================================== + !! History : 3.3 ! 2011-09 (M. Adani) Original code: Drag Coefficient + !! : 3.4 ! 2012-10 (M. Adani) Stokes Drift + !! 3.6 ! 2014-09 (E. Clementi,P. Oddo) New Stokes Drift Computation + !! - ! 2016-12 (G. Madec, E. Clementi) update Stoke drift computation + !! + add sbc_wave_ini routine + !! 4.2 ! 2020-12 (G. Madec, E. Clementi) updates, new Stoke drift computation + !! according to Couvelard et al.,2019 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_stokes : calculate 3D Stokes-drift velocities + !! sbc_wave : wave data from wave model: forced (netcdf files) or coupled mode + !! sbc_wave_init : initialisation fo surface waves + !!---------------------------------------------------------------------- + USE phycst ! physical constants + USE oce ! ocean variables + USE dom_oce ! ocean domain variables + USE sbc_oce ! Surface boundary condition: ocean fields + USE bdy_oce ! open boundary condition variables + USE domvvl ! domain: variable volume layers + USE zdf_oce, ONLY : ln_zdfswm ! Qiao wave enhanced mixing + ! + USE iom ! I/O manager library + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE fldread ! read input fields + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_stokes ! routine called in sbccpl + PUBLIC sbc_wave ! routine called in sbcmod + PUBLIC sbc_wave_init ! routine called in sbcmod + + ! Variables checking if the wave parameters are coupled (if not, they are read from file) + LOGICAL, PUBLIC :: cpl_hsig = .FALSE. + LOGICAL, PUBLIC :: cpl_phioc = .FALSE. + LOGICAL, PUBLIC :: cpl_sdrftx = .FALSE. + LOGICAL, PUBLIC :: cpl_sdrfty = .FALSE. + LOGICAL, PUBLIC :: cpl_wper = .FALSE. + LOGICAL, PUBLIC :: cpl_wnum = .FALSE. + LOGICAL, PUBLIC :: cpl_wstrf = .FALSE. + LOGICAL, PUBLIC :: cpl_wdrag = .FALSE. + LOGICAL, PUBLIC :: cpl_charn = .FALSE. + LOGICAL, PUBLIC :: cpl_taw = .FALSE. + LOGICAL, PUBLIC :: cpl_bhd = .FALSE. + LOGICAL, PUBLIC :: cpl_tusd = .FALSE. + LOGICAL, PUBLIC :: cpl_tvsd = .FALSE. + + INTEGER :: jpfld ! number of files to read for stokes drift + INTEGER :: jp_usd ! index of stokes drift (i-component) (m/s) at T-point + INTEGER :: jp_vsd ! index of stokes drift (j-component) (m/s) at T-point + INTEGER :: jp_hsw ! index of significant wave hight (m) at T-point + INTEGER :: jp_wmp ! index of mean wave period (s) at T-point + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_cd ! structure of input fields (file informations, fields read) Drag Coefficient + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_sd ! structure of input fields (file informations, fields read) Stokes Drift + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_wn ! structure of input fields (file informations, fields read) wave number for Qiao + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tauoc ! structure of input fields (file informations, fields read) normalized wave stress into the ocean + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: cdn_wave !: Neutral drag coefficient at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: hsw !: Significant Wave Height at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wmp !: Wave Mean Period at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wnum !: Wave Number at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wave !: stress reduction factor at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tsd2d !: Surface Stokes Drift module at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: div_sd !: barotropic stokes drift divergence + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: ut0sd, vt0sd !: surface Stokes drift velocities at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: wsd!: Stokes drift velocities at u-, v- & w-points, resp.u + REAL(dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: usd, vsd!: Stokes drift velocities at u-, v- & w-points, resp.u +! + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: charn !: charnock coefficient at t-point + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tawx !: Net wave-supported stress, u + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tawy !: Net wave-supported stress, v + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: twox !: wave-ocean momentum flux, u + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: twoy !: wave-ocean momentum flux, v + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wavex !: stress reduction factor at, u component + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wavey !: stress reduction factor at, v component + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: phioc !: tke flux from wave model + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: KZN2 !: Kz*N2 + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: bhd_wave !: Bernoulli head. wave induce pression + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tusd, tvsd !: Stokes drift transport + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: ZMX !: Kz*N2 + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: sbcwave.F90 15199 2021-08-19 07:57:52Z amoulin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_stokes( Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_stokes *** + !! + !! ** Purpose : compute the 3d Stokes Drift according to Breivik et al., + !! 2014 (DOI: 10.1175/JPO-D-14-0020.1) + !! + !! ** Method : - Calculate the horizontal Stokes drift velocity (Breivik et al. 2014) + !! - Calculate its horizontal divergence + !! - Calculate the vertical Stokes drift velocity + !! - Calculate the barotropic Stokes drift divergence + !! + !! ** action : - tsd2d : module of the surface Stokes drift velocity + !! - usd, vsd, wsd : 3 components of the Stokes drift velocity + !! - div_sd : barotropic Stokes drift divergence + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! ocean time level index + INTEGER :: jj, ji, jk ! dummy loop argument + INTEGER :: ik ! local integer + REAL(wp) :: ztransp, zfac, ztemp, zsp0, zsqrt, zbreiv16_w + REAL(wp) :: zdep_u, zdep_v, zkh_u, zkh_v, zda_u, zda_v, sdtrp + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zk_t, zk_u, zk_v, zu0_sd, zv0_sd ! 2D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3divh, zInt_w ! 3D workspace + !!--------------------------------------------------------------------- + ! + ALLOCATE( ze3divh(jpi,jpj,jpkm1) ) ! jpkm1 -> avoid lbc_lnk on jpk that is not defined + ALLOCATE( zInt_w(jpi,jpj,jpk) ) + ALLOCATE( zk_t(jpi,jpj), zk_u(jpi,jpj), zk_v(jpi,jpj), zu0_sd(jpi,jpj), zv0_sd(jpi,jpj) ) + zk_t (:,:) = 0._wp + zk_u (:,:) = 0._wp + zk_v (:,:) = 0._wp + zu0_sd (:,:) = 0._wp + zv0_sd (:,:) = 0._wp + ze3divh (:,:,:) = 0._wp + + ! + ! select parameterization for the calculation of vertical Stokes drift + ! exp. wave number at t-point + IF( ln_breivikFV_2016 ) THEN + ! Assumptions : ut0sd and vt0sd are surface Stokes drift at T-points + ! sdtrp is the norm of Stokes transport + ! + zfac = 0.166666666667_wp + DO_2D( 1, 1, 1, 1 ) ! In the deep-water limit we have ke = ||ust0||/( 6 * ||transport|| ) + zsp0 = SQRT( ut0sd(ji,jj)*ut0sd(ji,jj) + vt0sd(ji,jj)*vt0sd(ji,jj) ) !<-- norm of Surface Stokes drift + tsd2d(ji,jj) = zsp0 + IF( cpl_tusd .AND. cpl_tvsd ) THEN !stokes transport is provided in coupled mode + sdtrp = SQRT( tusd(ji,jj)*tusd(ji,jj) + tvsd(ji,jj)*tvsd(ji,jj) ) !<-- norm of Surface Stokes drift transport + ELSE + ! Stokes drift transport estimated from Hs and Tmean + sdtrp = 2.0_wp * rpi / 16.0_wp * & + & hsw(ji,jj)*hsw(ji,jj) / MAX( wmp(ji,jj), 0.0000001_wp ) + ENDIF + zk_t (ji,jj) = zfac * zsp0 / MAX ( sdtrp, 0.0000001_wp ) !<-- ke = ||ust0||/( 6 * ||transport|| ) + END_2D + !# define zInt_w ze3divh + DO_3D( 1, 1, 1, 1, 1, jpk ) ! Compute the primitive of Breivik 2016 function at W-points + zfac = - 2._wp * zk_t (ji,jj) * gdepw(ji,jj,jk,Kmm) !<-- zfac should be negative definite + ztemp = EXP ( zfac ) + zsqrt = SQRT( -zfac ) + zbreiv16_w = ztemp - SQRT(rpi)*zsqrt*ERFC(zsqrt) !Eq. 16 Breivik 2016 + zInt_w(ji,jj,jk) = ztemp - 4._wp * zk_t (ji,jj) * gdepw(ji,jj,jk,Kmm) * zbreiv16_w + END_3D +! + DO jk = 1, jpkm1 + zfac = 0.166666666667_wp + DO_2D( 1, 1, 1, 1 ) !++ Compute the FV Breivik 2016 function at T-points + zsp0 = zfac / MAX(zk_t (ji,jj),0.0000001_wp) + ztemp = zInt_w(ji,jj,jk) - zInt_w(ji,jj,jk+1) + zu0_sd(ji,jj) = ut0sd(ji,jj) * zsp0 * ztemp * tmask(ji,jj,jk) + zv0_sd(ji,jj) = vt0sd(ji,jj) * zsp0 * ztemp * tmask(ji,jj,jk) + END_2D + DO_2D( 1, 0, 1, 0 ) ! ++ Interpolate at U/V points + zfac = 1.0_wp / e3u(ji ,jj,jk,Kmm) + usd(ji,jj,jk) = 0.5_wp * zfac * ( zu0_sd(ji,jj)+zu0_sd(ji+1,jj) ) * umask(ji,jj,jk) + zfac = 1.0_wp / e3v(ji ,jj,jk,Kmm) + vsd(ji,jj,jk) = 0.5_wp * zfac * ( zv0_sd(ji,jj)+zv0_sd(ji,jj+1) ) * vmask(ji,jj,jk) + END_2D + ENDDO + !# undef zInt_w + ! + ELSE + zfac = 2.0_wp * rpi / 16.0_wp + DO_2D( 1, 1, 1, 1 ) + ! Stokes drift velocity estimated from Hs and Tmean + ztransp = zfac * hsw(ji,jj)*hsw(ji,jj) / MAX( wmp(ji,jj), 0.0000001_wp ) + ! Stokes surface speed + tsd2d(ji,jj) = SQRT( ut0sd(ji,jj)*ut0sd(ji,jj) + vt0sd(ji,jj)*vt0sd(ji,jj)) + ! Wavenumber scale + zk_t(ji,jj) = ABS( tsd2d(ji,jj) ) / MAX( ABS( 5.97_wp*ztransp ), 0.0000001_wp ) + END_2D + DO_2D( 1, 0, 1, 0 ) ! exp. wave number & Stokes drift velocity at u- & v-points + zk_u(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji+1,jj) ) + zk_v(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji,jj+1) ) + ! + zu0_sd(ji,jj) = 0.5_wp * ( ut0sd(ji,jj) + ut0sd(ji+1,jj) ) + zv0_sd(ji,jj) = 0.5_wp * ( vt0sd(ji,jj) + vt0sd(ji,jj+1) ) + END_2D + + ! !== horizontal Stokes Drift 3D velocity ==! + + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zdep_u = 0.5_wp * ( gdept(ji,jj,jk,Kmm) + gdept(ji+1,jj,jk,Kmm) ) + zdep_v = 0.5_wp * ( gdept(ji,jj,jk,Kmm) + gdept(ji,jj+1,jk,Kmm) ) + ! + zkh_u = zk_u(ji,jj) * zdep_u ! k * depth + zkh_v = zk_v(ji,jj) * zdep_v + ! ! Depth attenuation + zda_u = EXP( -2.0_wp*zkh_u ) / ( 1.0_wp + 8.0_wp*zkh_u ) + zda_v = EXP( -2.0_wp*zkh_v ) / ( 1.0_wp + 8.0_wp*zkh_v ) + ! + usd(ji,jj,jk) = zda_u * zu0_sd(ji,jj) * umask(ji,jj,jk) + vsd(ji,jj,jk) = zda_v * zv0_sd(ji,jj) * vmask(ji,jj,jk) + END_3D + ENDIF + + CALL lbc_lnk( 'sbcwave', usd, 'U', -1.0_dp, vsd, 'V', -1.0_dp ) + + ! + ! !== vertical Stokes Drift 3D velocity ==! + ! + DO_3D( 0, 1, 0, 1, 1, jpkm1 ) ! Horizontal e3*divergence + ze3divh(ji,jj,jk) = ( e2u(ji ,jj) * e3u(ji ,jj,jk,Kmm) * usd(ji ,jj,jk) & + & - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * usd(ji-1,jj,jk) & + & + e1v(ji,jj ) * e3v(ji,jj ,jk,Kmm) * vsd(ji,jj ,jk) & + & - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vsd(ji,jj-1,jk) ) & + & * r1_e1e2t(ji,jj) + END_3D + ! + CALL lbc_lnk( 'sbcwave', ze3divh, 'T', 1.0_wp ) + ! + IF( ln_linssh ) THEN ; ik = 1 ! none zero velocity through the sea surface + ELSE ; ik = 2 ! w=0 at the surface (set one for all in sbc_wave_init) + ENDIF + DO jk = jpkm1, ik, -1 ! integrate from the bottom the hor. divergence (NB: at k=jpk w is always zero) + wsd(:,:,jk) = wsd(:,:,jk+1) - ze3divh(:,:,jk) + END DO + ! + IF( ln_bdy ) THEN + DO jk = 1, jpkm1 + wsd(:,:,jk) = wsd(:,:,jk) * bdytmask(:,:) + END DO + ENDIF + ! !== Horizontal divergence of barotropic Stokes transport ==! + div_sd(:,:) = 0._wp + DO jk = 1, jpkm1 ! + div_sd(:,:) = div_sd(:,:) + ze3divh(:,:,jk) + END DO + ! + CALL iom_put( "ustokes", usd ) + CALL iom_put( "vstokes", vsd ) + CALL iom_put( "wstokes", wsd ) +! ! + DEALLOCATE( ze3divh, zInt_w ) + DEALLOCATE( zk_t, zk_u, zk_v, zu0_sd, zv0_sd ) + ! + END SUBROUTINE sbc_stokes +! +! + SUBROUTINE sbc_wave( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_wave *** + !! + !! ** Purpose : read wave parameters from wave model in netcdf files + !! or from a coupled wave mdoel + !! + !!--------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time step + INTEGER, INTENT(in ) :: Kmm ! ocean time index + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_wave : update the read waves fields' + WRITE(numout,*) '~~~~~~~~ ' + ENDIF + ! + IF( ln_cdgw .AND. .NOT. cpl_wdrag ) THEN !== Neutral drag coefficient ==! + CALL fld_read( kt, nn_fsbc, sf_cd ) ! read from external forcing + cdn_wave(:,:) = sf_cd(1)%fnow(:,:,1) * tmask(:,:,1) + ENDIF + + IF( ln_tauoc .AND. .NOT. cpl_wstrf ) THEN !== Wave induced stress ==! + CALL fld_read( kt, nn_fsbc, sf_tauoc ) ! read stress reduction factor due to wave from external forcing + tauoc_wave(:,:) = sf_tauoc(1)%fnow(:,:,1) * tmask(:,:,1) + ELSEIF ( ln_taw .AND. cpl_taw ) THEN + IF (kt < 1) THEN ! The first fields gave by OASIS have very high erroneous values .... + twox(:,:)=0._wp + twoy(:,:)=0._wp + tawx(:,:)=0._wp + tawy(:,:)=0._wp + tauoc_wavex(:,:) = 1._wp + tauoc_wavey(:,:) = 1._wp + ELSE + tauoc_wavex(:,:) = abs(twox(:,:)/tawx(:,:)) + tauoc_wavey(:,:) = abs(twoy(:,:)/tawy(:,:)) + ENDIF + ENDIF + + IF ( ln_phioc .and. cpl_phioc .and. kt == nit000 ) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_wave : PHIOC from wave model' + WRITE(numout,*) '~~~~~~~~ ' + ENDIF + + IF( ln_sdw .AND. .NOT. cpl_sdrftx) THEN !== Computation of the 3d Stokes Drift ==! + ! + IF( jpfld > 0 ) THEN ! Read from file only if the field is not coupled + CALL fld_read( kt, nn_fsbc, sf_sd ) ! read wave parameters from external forcing + ! ! NB: test case mode, not read as jpfld=0 + IF( jp_hsw > 0 ) hsw (:,:) = sf_sd(jp_hsw)%fnow(:,:,1) * tmask(:,:,1) ! significant wave height + IF( jp_wmp > 0 ) wmp (:,:) = sf_sd(jp_wmp)%fnow(:,:,1) * tmask(:,:,1) ! wave mean period + IF( jp_usd > 0 ) ut0sd(:,:) = sf_sd(jp_usd)%fnow(:,:,1) * tmask(:,:,1) ! 2D zonal Stokes Drift at T point + IF( jp_vsd > 0 ) vt0sd(:,:) = sf_sd(jp_vsd)%fnow(:,:,1) * tmask(:,:,1) ! 2D meridional Stokes Drift at T point + ENDIF + + ! Read also wave number if needed, so that it is available in + ! coupling routines + IF( ln_zdfswm .AND. .NOT. cpl_wnum ) THEN !==wavenumber==! + CALL fld_read( kt, nn_fsbc, sf_wn ) ! read wave parameters from external forcing + wnum(:,:) = sf_wn(1)%fnow(:,:,1) * tmask(:,:,1) + ENDIF + + ! + IF( jpfld == 4 .OR. ln_wave_test ) & + & CALL sbc_stokes( Kmm ) ! Calculate only if all required fields are read + ! ! or in wave test case + ! ! ! In coupled case the call is done after (in sbc_cpl) + ENDIF + ! + END SUBROUTINE sbc_wave + + + SUBROUTINE sbc_wave_init + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_wave_init *** + !! + !! ** Purpose : Initialisation fo surface waves + !! + !! ** Method : - Read namelist namsbc_wave + !! - create the structure used to read required wave fields + !! (its size depends on namelist options) + !! ** action + !!--------------------------------------------------------------------- + INTEGER :: ierror, ios ! local integer + INTEGER :: ifpr + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of drag coefficient files + TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: slf_i ! array of namelist informations on the fields to read + TYPE(FLD_N) :: sn_cdg, sn_usd, sn_vsd, & + & sn_hsw, sn_wmp, sn_wnum, sn_tauoc ! informations about the fields to be read + ! + NAMELIST/namsbc_wave/ cn_dir, sn_cdg, sn_usd, sn_vsd, sn_hsw, sn_wmp, sn_wnum, sn_tauoc, & + & ln_cdgw, ln_sdw, ln_tauoc, ln_stcor, ln_charn, ln_taw, ln_phioc, & + & ln_wave_test, ln_bern_srfc, ln_breivikFV_2016, ln_vortex_force, ln_stshear + !!--------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_wave_init : surface waves in the system' + WRITE(numout,*) '~~~~~~~~~~~~~ ' + ENDIF + ! + READ ( numnam_ref, namsbc_wave, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_wave in reference namelist') + + READ ( numnam_cfg, namsbc_wave, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_wave in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_wave ) + ! + IF(lwp) THEN + WRITE(numout,*) ' Namelist namsbc_wave' + WRITE(numout,*) ' Stokes drift ln_sdw = ', ln_sdw + WRITE(numout,*) ' Breivik 2016 ln_breivikFV_2016 = ', ln_breivikFV_2016 + WRITE(numout,*) ' Stokes Coriolis & tracer advection terms ln_stcor = ', ln_stcor + WRITE(numout,*) ' Vortex Force ln_vortex_force = ', ln_vortex_force + WRITE(numout,*) ' Bernouilli Head Pressure ln_bern_srfc = ', ln_bern_srfc + WRITE(numout,*) ' wave modified ocean stress ln_tauoc = ', ln_tauoc + WRITE(numout,*) ' neutral drag coefficient (CORE bulk only) ln_cdgw = ', ln_cdgw + WRITE(numout,*) ' charnock coefficient ln_charn = ', ln_charn + WRITE(numout,*) ' Stress modificated by wave ln_taw = ', ln_taw + WRITE(numout,*) ' TKE flux from wave ln_phioc = ', ln_phioc + WRITE(numout,*) ' Surface shear with Stokes drift ln_stshear = ', ln_stshear + WRITE(numout,*) ' Test with constant wave fields ln_wave_test = ', ln_wave_test + ENDIF + + ! ! option check + IF( .NOT.( ln_cdgw .OR. ln_sdw .OR. ln_tauoc .OR. ln_stcor .OR. ln_charn) ) & + & CALL ctl_warn( 'Ask for wave coupling but ln_cdgw=F, ln_sdw=F, ln_tauoc=F, ln_stcor=F') + IF( ln_cdgw .AND. ln_blk ) & + & CALL ctl_stop( 'drag coefficient read from wave model NOT available yet with aerobulk package') + IF( ln_stcor .AND. .NOT.ln_sdw ) & + & CALL ctl_stop( 'Stokes-Coriolis term calculated only if activated Stokes Drift ln_sdw=T') + + ! !== Allocate wave arrays ==! + ALLOCATE( ut0sd (jpi,jpj) , vt0sd (jpi,jpj) ) + ALLOCATE( hsw (jpi,jpj) , wmp (jpi,jpj) ) + ALLOCATE( wnum (jpi,jpj) ) + ALLOCATE( tsd2d (jpi,jpj) , div_sd(jpi,jpj) , bhd_wave(jpi,jpj) ) + ALLOCATE( usd (jpi,jpj,jpk), vsd (jpi,jpj,jpk), wsd (jpi,jpj,jpk) ) + ALLOCATE( tusd (jpi,jpj) , tvsd (jpi,jpj) , ZMX (jpi,jpj,jpk) ) + usd (:,:,:) = 0._wp + vsd (:,:,:) = 0._wp + wsd (:,:,:) = 0._wp + hsw (:,:) = 0._wp + wmp (:,:) = 0._wp + ut0sd (:,:) = 0._wp + vt0sd (:,:) = 0._wp + tusd (:,:) = 0._wp + tvsd (:,:) = 0._wp + bhd_wave(:,:) = 0._wp + ZMX (:,:,:) = 0._wp +! + IF( ln_wave_test ) THEN !== Wave TEST case ==! set uniform waves fields + jpfld = 0 ! No field read + ln_cdgw = .FALSE. ! No neutral wave drag input + ln_tauoc = .FALSE. ! No wave induced drag reduction factor + ut0sd(:,:) = 0.13_wp * tmask(:,:,1) ! m/s + vt0sd(:,:) = 0.00_wp ! m/s + hsw (:,:) = 2.80_wp ! meters + wmp (:,:) = 8.00_wp ! seconds + ! + ELSE !== create the structure associated with fields to be read ==! + IF( ln_cdgw ) THEN ! wave drag + IF( .NOT. cpl_wdrag ) THEN + ALLOCATE( sf_cd(1), STAT=ierror ) !* allocate and fill sf_wave with sn_cdg + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) + ! + ALLOCATE( sf_cd(1)%fnow(jpi,jpj,1) ) + IF( sn_cdg%ln_tint ) ALLOCATE( sf_cd(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_cd, (/ sn_cdg /), cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) + ENDIF + ALLOCATE( cdn_wave(jpi,jpj) ) + cdn_wave(:,:) = 0._wp + ENDIF + IF( ln_charn ) THEN ! wave drag + IF( .NOT. cpl_charn ) THEN + CALL ctl_stop( 'STOP', 'Charnock based wind stress can be used in coupled mode only' ) + ENDIF + ALLOCATE( charn(jpi,jpj) ) + charn(:,:) = 0._wp + ENDIF + IF( ln_taw ) THEN ! wind stress + IF( .NOT. cpl_taw ) THEN + CALL ctl_stop( 'STOP', 'wind stress from wave model can be used in coupled mode only, use ln_cdgw instead' ) + ENDIF + ALLOCATE( tawx(jpi,jpj) ) + ALLOCATE( tawy(jpi,jpj) ) + ALLOCATE( twox(jpi,jpj) ) + ALLOCATE( twoy(jpi,jpj) ) + ALLOCATE( tauoc_wavex(jpi,jpj) ) + ALLOCATE( tauoc_wavey(jpi,jpj) ) + tawx(:,:) = 0._wp + tawy(:,:) = 0._wp + twox(:,:) = 0._wp + twoy(:,:) = 0._wp + tauoc_wavex(:,:) = 1._wp + tauoc_wavey(:,:) = 1._wp + ENDIF + + IF( ln_phioc ) THEN ! TKE flux + IF( .NOT. cpl_phioc ) THEN + CALL ctl_stop( 'STOP', 'phioc can be used in coupled mode only' ) + ENDIF + ALLOCATE( phioc(jpi,jpj) ) + phioc(:,:) = 0._wp + ENDIF + + IF( ln_tauoc ) THEN ! normalized wave stress into the ocean + IF( .NOT. cpl_wstrf ) THEN + ALLOCATE( sf_tauoc(1), STAT=ierror ) !* allocate and fill sf_wave with sn_tauoc + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_tauoc structure' ) + ! + ALLOCATE( sf_tauoc(1)%fnow(jpi,jpj,1) ) + IF( sn_tauoc%ln_tint ) ALLOCATE( sf_tauoc(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_tauoc, (/ sn_tauoc /), cn_dir, 'sbc_wave_init', 'Wave module', 'namsbc_wave' ) + ENDIF + ALLOCATE( tauoc_wave(jpi,jpj) ) + tauoc_wave(:,:) = 0._wp + ENDIF + + IF( ln_sdw ) THEN ! Stokes drift + ! 1. Find out how many fields have to be read from file if not coupled + jpfld=0 + jp_usd=0 ; jp_vsd=0 ; jp_hsw=0 ; jp_wmp=0 + IF( .NOT. cpl_sdrftx ) THEN + jpfld = jpfld + 1 + jp_usd = jpfld + ENDIF + IF( .NOT. cpl_sdrfty ) THEN + jpfld = jpfld + 1 + jp_vsd = jpfld + ENDIF + IF( .NOT. cpl_hsig ) THEN + jpfld = jpfld + 1 + jp_hsw = jpfld + ENDIF + IF( .NOT. cpl_wper ) THEN + jpfld = jpfld + 1 + jp_wmp = jpfld + ENDIF + ! 2. Read from file only the non-coupled fields + IF( jpfld > 0 ) THEN + ALLOCATE( slf_i(jpfld) ) + IF( jp_usd > 0 ) slf_i(jp_usd) = sn_usd + IF( jp_vsd > 0 ) slf_i(jp_vsd) = sn_vsd + IF( jp_hsw > 0 ) slf_i(jp_hsw) = sn_hsw + IF( jp_wmp > 0 ) slf_i(jp_wmp) = sn_wmp + ALLOCATE( sf_sd(jpfld), STAT=ierror ) !* allocate and fill sf_sd with stokes drift + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) + ! + DO ifpr= 1, jpfld + ALLOCATE( sf_sd(ifpr)%fnow(jpi,jpj,1) ) + IF( slf_i(ifpr)%ln_tint ) ALLOCATE( sf_sd(ifpr)%fdta(jpi,jpj,1,2) ) + END DO + ! + CALL fld_fill( sf_sd, slf_i, cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) + sf_sd(jp_usd)%zsgn = -1._wp ; sf_sd(jp_vsd)%zsgn = -1._wp ! vector field at T point: overwrite default definition of zsgn + ENDIF + ! + ! 3. Wave number (only needed for Qiao parametrisation, ln_zdfswm=T) + IF( .NOT. cpl_wnum ) THEN + ALLOCATE( sf_wn(1), STAT=ierror ) !* allocate and fill sf_wave with sn_wnum + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wn structure' ) + ALLOCATE( sf_wn(1)%fnow(jpi,jpj,1) ) + IF( sn_wnum%ln_tint ) ALLOCATE( sf_wn(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_wn, (/ sn_wnum /), cn_dir, 'sbc_wave', 'Wave module', 'namsbc_wave' ) + ENDIF + ! + ENDIF + ! + ENDIF + ! + END SUBROUTINE sbc_wave_init + + !!====================================================================== +END MODULE sbcwave diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/STO/stopar.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/STO/stopar.F90 new file mode 100644 index 0000000..8ce9b2c --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/STO/stopar.F90 @@ -0,0 +1,917 @@ +MODULE stopar + !!====================================================================== + !! *** MODULE stopar *** + !! Stochastic parameters : definition and time stepping + !!===================================================================== + !! History : 3.3 ! 2011-10 (J.-M. Brankart) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sto_par : update the stochastic parameters + !! sto_par_init : define the stochastic parameterization + !! sto_rst_read : read restart file for stochastic parameters + !! sto_rst_write : write restart file for stochastic parameters + !! sto_par_white : fill input array with white Gaussian noise + !! sto_par_flt : apply horizontal Laplacian filter to input array + !!---------------------------------------------------------------------- + USE storng ! random number generator (external module) + USE par_oce ! ocean parameters + USE dom_oce ! ocean space and time domain variables + USE lbclnk ! lateral boundary conditions (or mpp link) + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE lib_mpp + + + IMPLICIT NONE + PRIVATE + + PUBLIC sto_par_init ! called by nemogcm.F90 + PUBLIC sto_par ! called by step.F90 + PUBLIC sto_rst_write ! called by step.F90 + + LOGICAL :: ln_rststo = .FALSE. ! restart stochastic parameters from restart file + LOGICAL :: ln_rstseed = .FALSE. ! read seed of RNG from restart file + CHARACTER(len=32) :: cn_storst_in = "restart_sto" ! suffix of sto restart name (input) + CHARACTER(len=32) :: cn_storst_out = "restart_sto" ! suffix of sto restart name (output) + INTEGER :: numstor, numstow ! logical unit for restart (read and write) + + INTEGER :: jpsto2d = 0 ! number of 2D stochastic parameters + INTEGER :: jpsto3d = 0 ! number of 3D stochastic parameters + + REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: sto2d ! 2D stochastic parameters + REAL(wp), PUBLIC, DIMENSION(:,:,:,:), ALLOCATABLE :: sto3d ! 3D stochastic parameters + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sto_tmp ! temporary workspace + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sto2d_abc ! a, b, c parameters (for 2D arrays) + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sto3d_abc ! a, b, c parameters (for 3D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_ave ! mean value (for 2D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_ave ! mean value (for 3D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_std ! standard deviation (for 2D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_std ! standard deviation (for 3D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_lim ! limitation factor (for 2D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_lim ! limitation factor (for 3D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_tcor ! time correlation (for 2D arrays) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_tcor ! time correlation (for 3D arrays) + INTEGER, DIMENSION(:), ALLOCATABLE :: sto2d_ord ! order of autoregressive process + INTEGER, DIMENSION(:), ALLOCATABLE :: sto3d_ord ! order of autoregressive process + + CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: sto2d_typ ! nature of grid point (T, U, V, W, F, I) + CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: sto3d_typ ! nature of grid point (T, U, V, W, F, I) + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_sgn ! control of the sign accross the north fold + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_sgn ! control of the sign accross the north fold + INTEGER, DIMENSION(:), ALLOCATABLE :: sto2d_flt ! number of passes of Laplacian filter + INTEGER, DIMENSION(:), ALLOCATABLE :: sto3d_flt ! number of passes of Laplacian filter + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto2d_fac ! factor to restore std after filtering + REAL(wp), DIMENSION(:), ALLOCATABLE :: sto3d_fac ! factor to restore std after filtering + + LOGICAL, PUBLIC :: ln_sto_ldf = .FALSE. ! stochastic lateral diffusion + INTEGER, PUBLIC :: jsto_ldf ! index of lateral diffusion stochastic parameter + REAL(wp) :: rn_ldf_std ! lateral diffusion standard deviation (in percent) + REAL(wp) :: rn_ldf_tcor ! lateral diffusion correlation timescale (in timesteps) + + LOGICAL, PUBLIC :: ln_sto_hpg = .FALSE. ! stochastic horizontal pressure gradient + INTEGER, PUBLIC :: jsto_hpgi ! index of stochastic hpg parameter (i direction) + INTEGER, PUBLIC :: jsto_hpgj ! index of stochastic hpg parameter (j direction) + REAL(wp) :: rn_hpg_std ! density gradient standard deviation (in percent) + REAL(wp) :: rn_hpg_tcor ! density gradient correlation timescale (in timesteps) + + LOGICAL, PUBLIC :: ln_sto_pstar = .FALSE. ! stochastic ice strength + INTEGER, PUBLIC :: jsto_pstar ! index of stochastic ice strength + REAL(wp), PUBLIC:: rn_pstar_std ! ice strength standard deviation (in percent) + REAL(wp) :: rn_pstar_tcor ! ice strength correlation timescale (in timesteps) + INTEGER :: nn_pstar_flt = 0 ! number of passes of Laplacian filter + INTEGER :: nn_pstar_ord = 1 ! order of autoregressive processes + + LOGICAL, PUBLIC :: ln_sto_trd = .FALSE. ! stochastic model trend + INTEGER, PUBLIC :: jsto_trd ! index of stochastic trend parameter + REAL(wp) :: rn_trd_std ! trend standard deviation (in percent) + REAL(wp) :: rn_trd_tcor ! trend correlation timescale (in timesteps) + + LOGICAL, PUBLIC :: ln_sto_eos = .FALSE. ! stochastic equation of state + INTEGER, PUBLIC :: nn_sto_eos = 1 ! number of degrees of freedom in stochastic equation of state + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_eosi ! index of stochastic eos parameter (i direction) + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_eosj ! index of stochastic eos parameter (j direction) + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_eosk ! index of stochastic eos parameter (k direction) + REAL(wp) :: rn_eos_stdxy ! random walk horz. standard deviation (in grid points) + REAL(wp) :: rn_eos_stdz ! random walk vert. standard deviation (in grid points) + REAL(wp) :: rn_eos_tcor ! random walk correlation timescale (in timesteps) + REAL(wp) :: rn_eos_lim = 3.0_wp ! limitation factor + INTEGER :: nn_eos_flt = 0 ! number of passes of Laplacian filter + INTEGER :: nn_eos_ord = 1 ! order of autoregressive processes + + LOGICAL, PUBLIC :: ln_sto_trc = .FALSE. ! stochastic tracer dynamics + INTEGER, PUBLIC :: nn_sto_trc = 1 ! number of degrees of freedom in stochastic tracer dynamics + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_trci ! index of stochastic trc parameter (i direction) + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_trcj ! index of stochastic trc parameter (j direction) + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: jsto_trck ! index of stochastic trc parameter (k direction) + REAL(wp) :: rn_trc_stdxy ! random walk horz. standard deviation (in grid points) + REAL(wp) :: rn_trc_stdz ! random walk vert. standard deviation (in grid points) + REAL(wp) :: rn_trc_tcor ! random walk correlation timescale (in timesteps) + REAL(wp) :: rn_trc_lim = 3.0_wp ! limitation factor + INTEGER :: nn_trc_flt = 0 ! number of passes of Laplacian filter + INTEGER :: nn_trc_ord = 1 ! order of autoregressive processes + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: stopar.F90 13295 2020-07-10 18:24:21Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sto_par( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_par *** + !! + !! ** Purpose : update the stochastic parameters + !! + !! ** Method : model basic stochastic parameters + !! as a first order autoregressive process AR(1), + !! governed by the equation: + !! X(t) = a * X(t-1) + b * w + c + !! where the parameters a, b and c are related + !! to expected value, standard deviation + !! and time correlation (all stationary in time) by: + !! E [X(t)] = c / ( 1 - a ) + !! STD [X(t)] = b / SQRT( 1 - a * a ) + !! COR [X(t),X(t-k)] = a ** k + !! and w is a Gaussian white noise. + !! + !! Higher order autoregressive proces can be optionally generated + !! by replacing the white noise by a lower order process. + !! + !! 1) The statistics of the stochastic parameters (X) are assumed + !! constant in space (homogeneous) and time (stationary). + !! This could be generalized by replacing the constant + !! a, b, c parameters by functions of space and time. + !! + !! 2) The computation is performed independently for every model + !! grid point, which corresponds to assume that the stochastic + !! parameters are uncorrelated in space. + !! This could be generalized by including a spatial filter: Y = Filt[ X ] + !! (possibly non-homgeneous and non-stationary) in the computation, + !! or by solving an elliptic equation: L[ Y ] = X. + !! + !! 3) The stochastic model for the parameters could also + !! be generalized to depend on the current state of the ocean (not done here). + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk, jsto, jflt + REAL(wp) :: stomax + !!---------------------------------------------------------------------- + ! + ! Update 2D stochastic arrays + ! + DO jsto = 1, jpsto2d + ! Store array from previous time step + sto_tmp(:,:) = sto2d(:,:,jsto) + + IF ( sto2d_ord(jsto) == 1 ) THEN + ! Draw new random numbers from N(0,1) --> w + CALL sto_par_white( sto2d(:,:,jsto) ) + ! Apply horizontal Laplacian filter to w + DO jflt = 1, sto2d_flt(jsto) + CALL lbc_lnk( 'stopar', sto2d(:,:,jsto), sto2d_typ(jsto), sto2d_sgn(jsto) ) + CALL sto_par_flt( sto2d(:,:,jsto) ) + END DO + ! Factor to restore standard deviation after filtering + sto2d(:,:,jsto) = sto2d(:,:,jsto) * sto2d_fac(jsto) + ELSE + ! Use previous process (one order lower) instead of white noise + sto2d(:,:,jsto) = sto2d(:,:,jsto-1) + ENDIF + + ! Multiply white noise (or lower order process) by b --> b * w + sto2d(:,:,jsto) = sto2d(:,:,jsto) * sto2d_abc(jsto,2) + ! Update autoregressive processes --> a * X(t-1) + b * w + sto2d(:,:,jsto) = sto2d(:,:,jsto) + sto_tmp(:,:) * sto2d_abc(jsto,1) + ! Add parameter c --> a * X(t-1) + b * w + c + sto2d(:,:,jsto) = sto2d(:,:,jsto) + sto2d_abc(jsto,3) + ! Limit random parameter anomalies to std times the limitation factor + stomax = sto2d_std(jsto) * sto2d_lim(jsto) + sto2d(:,:,jsto) = sto2d(:,:,jsto) - sto2d_ave(jsto) + sto2d(:,:,jsto) = SIGN(MIN(stomax,ABS(sto2d(:,:,jsto))),sto2d(:,:,jsto)) + sto2d(:,:,jsto) = sto2d(:,:,jsto) + sto2d_ave(jsto) + + ! Lateral boundary conditions on sto2d + CALL lbc_lnk( 'stopar', sto2d(:,:,jsto), sto2d_typ(jsto), sto2d_sgn(jsto) ) + END DO + ! + ! Update 3D stochastic arrays + ! + DO jsto = 1, jpsto3d + DO jk = 1, jpk + ! Store array from previous time step + sto_tmp(:,:) = sto3d(:,:,jk,jsto) + + IF ( sto3d_ord(jsto) == 1 ) THEN + ! Draw new random numbers from N(0,1) --> w + CALL sto_par_white( sto3d(:,:,jk,jsto) ) + ! Apply horizontal Laplacian filter to w + DO jflt = 1, sto3d_flt(jsto) + CALL lbc_lnk( 'stopar', sto3d(:,:,jk,jsto), sto3d_typ(jsto), sto3d_sgn(jsto) ) + CALL sto_par_flt( sto3d(:,:,jk,jsto) ) + END DO + ! Factor to restore standard deviation after filtering + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) * sto3d_fac(jsto) + ELSE + ! Use previous process (one order lower) instead of white noise + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto-1) + ENDIF + + ! Multiply white noise by b --> b * w + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) * sto3d_abc(jsto,2) + ! Update autoregressive processes --> a * X(t-1) + b * w + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) + sto_tmp(:,:) * sto3d_abc(jsto,1) + ! Add parameter c --> a * X(t-1) + b * w + c + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) + sto3d_abc(jsto,3) + ! Limit random parameters anomalies to std times the limitation factor + stomax = sto3d_std(jsto) * sto3d_lim(jsto) + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) - sto3d_ave(jsto) + sto3d(:,:,jk,jsto) = SIGN(MIN(stomax,ABS(sto3d(:,:,jk,jsto))),sto3d(:,:,jk,jsto)) + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) + sto3d_ave(jsto) + END DO + ! Lateral boundary conditions on sto3d + CALL lbc_lnk( 'stopar', sto3d(:,:,:,jsto), sto3d_typ(jsto), sto3d_sgn(jsto) ) + END DO + ! + END SUBROUTINE sto_par + + + SUBROUTINE sto_par_init + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_par_init *** + !! + !! ** Purpose : define the stochastic parameterization + !!---------------------------------------------------------------------- + NAMELIST/namsto/ ln_sto_ldf, rn_ldf_std, rn_ldf_tcor, & + & ln_sto_hpg, rn_hpg_std, rn_hpg_tcor, & + & ln_sto_pstar, rn_pstar_std, rn_pstar_tcor, nn_pstar_flt, nn_pstar_ord, & + & ln_sto_trd, rn_trd_std, rn_trd_tcor, & + & ln_sto_eos, nn_sto_eos, rn_eos_stdxy, rn_eos_stdz, & + & rn_eos_tcor, nn_eos_ord, nn_eos_flt, rn_eos_lim, & + & ln_sto_trc, nn_sto_trc, rn_trc_stdxy, rn_trc_stdz, & + & rn_trc_tcor, nn_trc_ord, nn_trc_flt, rn_trc_lim, & + & ln_rststo, ln_rstseed, cn_storst_in, cn_storst_out + !!---------------------------------------------------------------------- + INTEGER :: jsto, jmem, jarea, jdof, jord, jordm1, jk, jflt + INTEGER(KIND=8) :: zseed1, zseed2, zseed3, zseed4 + REAL(wp) :: rinflate + INTEGER :: ios ! Local integer output status for namelist read + + ! Read namsto namelist : stochastic parameterization + READ ( numnam_ref, namsto, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsto in reference namelist' ) + + READ ( numnam_cfg, namsto, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsto in configuration namelist' ) + IF(lwm) WRITE ( numond, namsto ) + + IF( .NOT.ln_sto_eos ) THEN ! no use of stochastic parameterization + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sto_par_init : NO use of stochastic parameterization' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + RETURN + ENDIF + + !IF(ln_ens_rst_in) cn_storst_in = cn_mem//cn_storst_in + + ! Parameter print + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sto_par_init : stochastic parameterization' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namsto : stochastic parameterization' + WRITE(numout,*) ' restart stochastic parameters ln_rststo = ', ln_rststo + WRITE(numout,*) ' read seed of RNG from restart file ln_rstseed = ', ln_rstseed + WRITE(numout,*) ' suffix of sto restart name (input) cn_storst_in = ', cn_storst_in + WRITE(numout,*) ' suffix of sto restart name (output) cn_storst_out = ', cn_storst_out + + ! WRITE(numout,*) ' stochastic lateral diffusion ln_sto_ldf = ', ln_sto_ldf + ! WRITE(numout,*) ' lateral diffusion std (in percent) rn_ldf_std = ', rn_ldf_std + ! WRITE(numout,*) ' lateral diffusion tcor (in timesteps) rn_ldf_tcor = ', rn_ldf_tcor + + ! WRITE(numout,*) ' stochastic horizontal pressure gradient ln_sto_hpg = ', ln_sto_hpg + ! WRITE(numout,*) ' density gradient std (in percent) rn_hpg_std = ', rn_hpg_std + ! WRITE(numout,*) ' density gradient tcor (in timesteps) rn_hpg_tcor = ', rn_hpg_tcor + + ! WRITE(numout,*) ' stochastic ice strength ln_sto_pstar = ', ln_sto_pstar + ! WRITE(numout,*) ' ice strength std (in percent) rn_pstar_std = ', rn_pstar_std + ! WRITE(numout,*) ' ice strength tcor (in timesteps) rn_pstar_tcor = ', rn_pstar_tcor + ! WRITE(numout,*) ' order of autoregressive processes nn_pstar_ord = ', nn_pstar_ord + ! WRITE(numout,*) ' passes of Laplacian filter nn_pstar_flt = ', nn_pstar_flt + + !WRITE(numout,*) ' stochastic trend ln_sto_trd = ', ln_sto_trd + !WRITE(numout,*) ' trend std (in percent) rn_trd_std = ', rn_trd_std + !WRITE(numout,*) ' trend tcor (in timesteps) rn_trd_tcor = ', rn_trd_tcor + + WRITE(numout,*) ' stochastic equation of state ln_sto_eos = ', ln_sto_eos + WRITE(numout,*) ' number of degrees of freedom nn_sto_eos = ', nn_sto_eos + WRITE(numout,*) ' random walk horz. std (in grid points) rn_eos_stdxy = ', rn_eos_stdxy + WRITE(numout,*) ' random walk vert. std (in grid points) rn_eos_stdz = ', rn_eos_stdz + WRITE(numout,*) ' random walk tcor (in timesteps) rn_eos_tcor = ', rn_eos_tcor + WRITE(numout,*) ' order of autoregressive processes nn_eos_ord = ', nn_eos_ord + WRITE(numout,*) ' passes of Laplacian filter nn_eos_flt = ', nn_eos_flt + WRITE(numout,*) ' limitation factor rn_eos_lim = ', rn_eos_lim + + ! WRITE(numout,*) ' stochastic tracers dynamics ln_sto_trc = ', ln_sto_trc + ! WRITE(numout,*) ' number of degrees of freedom nn_sto_trc = ', nn_sto_trc + ! WRITE(numout,*) ' random walk horz. std (in grid points) rn_trc_stdxy = ', rn_trc_stdxy + ! WRITE(numout,*) ' random walk vert. std (in grid points) rn_trc_stdz = ', rn_trc_stdz + ! WRITE(numout,*) ' random walk tcor (in timesteps) rn_trc_tcor = ', rn_trc_tcor + ! WRITE(numout,*) ' order of autoregressive processes nn_trc_ord = ', nn_trc_ord + ! WRITE(numout,*) ' passes of Laplacian filter nn_trc_flt = ', nn_trc_flt + ! WRITE(numout,*) ' limitation factor rn_trc_lim = ', rn_trc_lim + + ENDIF + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' stochastic parameterization :' + + ! Set number of 2D stochastic arrays + jpsto2d = 0 + IF( ln_sto_ldf ) THEN + IF(lwp) WRITE(numout,*) ' - stochastic lateral diffusion' + jpsto2d = jpsto2d + 1 + jsto_ldf = jpsto2d + ENDIF + IF( ln_sto_pstar ) THEN + IF(lwp) WRITE(numout,*) ' - stochastic ice strength' + jpsto2d = jpsto2d + 1 * nn_pstar_ord + jsto_pstar = jpsto2d + ENDIF + IF( ln_sto_eos ) THEN + IF ( lk_agrif ) CALL ctl_stop('EOS stochastic parametrization is not compatible with AGRIF') + IF(lwp) WRITE(numout,*) ' - stochastic equation of state' + ALLOCATE(jsto_eosi(nn_sto_eos)) + ALLOCATE(jsto_eosj(nn_sto_eos)) + ALLOCATE(jsto_eosk(nn_sto_eos)) + DO jdof = 1, nn_sto_eos + jpsto2d = jpsto2d + 3 * nn_eos_ord + jsto_eosi(jdof) = jpsto2d - 2 * nn_eos_ord + jsto_eosj(jdof) = jpsto2d - 1 * nn_eos_ord + jsto_eosk(jdof) = jpsto2d + END DO + ELSE + nn_sto_eos = 0 + ENDIF + IF( ln_sto_trc ) THEN + IF(lwp) WRITE(numout,*) ' - stochastic tracers dynamics' + ALLOCATE(jsto_trci(nn_sto_trc)) + ALLOCATE(jsto_trcj(nn_sto_trc)) + ALLOCATE(jsto_trck(nn_sto_trc)) + DO jdof = 1, nn_sto_trc + jpsto2d = jpsto2d + 3 * nn_trc_ord + jsto_trci(jdof) = jpsto2d - 2 * nn_trc_ord + jsto_trcj(jdof) = jpsto2d - 1 * nn_trc_ord + jsto_trck(jdof) = jpsto2d + END DO + ELSE + nn_sto_trc = 0 + ENDIF + + ! Set number of 3D stochastic arrays + jpsto3d = 0 + IF( ln_sto_hpg ) THEN + IF(lwp) WRITE(numout,*) ' - stochastic horizontal pressure gradient' + jpsto3d = jpsto3d + 2 + jsto_hpgi = jpsto3d - 1 + jsto_hpgj = jpsto3d + ENDIF + IF( ln_sto_trd ) THEN + IF(lwp) WRITE(numout,*) ' - stochastic trend' + jpsto3d = jpsto3d + 1 + jsto_trd = jpsto3d + ENDIF + + ! Allocate 2D stochastic arrays + IF ( jpsto2d > 0 ) THEN + ALLOCATE ( sto2d(jpi,jpj,jpsto2d) ) + ALLOCATE ( sto2d_abc(jpsto2d,3) ) + ALLOCATE ( sto2d_ave(jpsto2d) ) + ALLOCATE ( sto2d_std(jpsto2d) ) + ALLOCATE ( sto2d_lim(jpsto2d) ) + ALLOCATE ( sto2d_tcor(jpsto2d) ) + ALLOCATE ( sto2d_ord(jpsto2d) ) + ALLOCATE ( sto2d_typ(jpsto2d) ) + ALLOCATE ( sto2d_sgn(jpsto2d) ) + ALLOCATE ( sto2d_flt(jpsto2d) ) + ALLOCATE ( sto2d_fac(jpsto2d) ) + ENDIF + + ! Allocate 3D stochastic arrays + IF ( jpsto3d > 0 ) THEN + ALLOCATE ( sto3d(jpi,jpj,jpk,jpsto3d) ) + ALLOCATE ( sto3d_abc(jpsto3d,3) ) + ALLOCATE ( sto3d_ave(jpsto3d) ) + ALLOCATE ( sto3d_std(jpsto3d) ) + ALLOCATE ( sto3d_lim(jpsto3d) ) + ALLOCATE ( sto3d_tcor(jpsto3d) ) + ALLOCATE ( sto3d_ord(jpsto3d) ) + ALLOCATE ( sto3d_typ(jpsto3d) ) + ALLOCATE ( sto3d_sgn(jpsto3d) ) + ALLOCATE ( sto3d_flt(jpsto3d) ) + ALLOCATE ( sto3d_fac(jpsto3d) ) + ENDIF + + ! Allocate temporary workspace + IF ( jpsto2d > 0 .OR. jpsto3d > 0 ) THEN + ALLOCATE ( sto_tmp(jpi,jpj) ) ; sto_tmp(:,:) = 0._wp + ENDIF + + ! 1) For every stochastic parameter: + ! ---------------------------------- + ! - set nature of grid point and control of the sign + ! across the north fold (sto2d_typ, sto2d_sgn) + ! - set number of passes of Laplacian filter (sto2d_flt) + ! - set order of every autoregressive process (sto2d_ord) + DO jsto = 1, jpsto2d + sto2d_typ(jsto) = 'T' + sto2d_sgn(jsto) = 1._wp + sto2d_flt(jsto) = 0 + sto2d_ord(jsto) = 1 + DO jord = 0, nn_pstar_ord-1 + IF ( jsto+jord == jsto_pstar ) THEN ! Stochastic ice strength (ave=1) + sto2d_ord(jsto) = nn_pstar_ord - jord + sto2d_flt(jsto) = nn_pstar_flt + ENDIF + ENDDO + DO jdof = 1, nn_sto_eos + DO jord = 0, nn_eos_ord-1 + IF ( jsto+jord == jsto_eosi(jdof) ) THEN ! Stochastic equation of state i (ave=0) + sto2d_ord(jsto) = nn_eos_ord - jord + sto2d_sgn(jsto) = -1._wp + sto2d_flt(jsto) = nn_eos_flt + ENDIF + IF ( jsto+jord == jsto_eosj(jdof) ) THEN ! Stochastic equation of state j (ave=0) + sto2d_ord(jsto) = nn_eos_ord - jord + sto2d_sgn(jsto) = -1._wp + sto2d_flt(jsto) = nn_eos_flt + ENDIF + IF ( jsto+jord == jsto_eosk(jdof) ) THEN ! Stochastic equation of state k (ave=0) + sto2d_ord(jsto) = nn_eos_ord - jord + sto2d_flt(jsto) = nn_eos_flt + ENDIF + END DO + END DO + DO jdof = 1, nn_sto_trc + DO jord = 0, nn_trc_ord-1 + IF ( jsto+jord == jsto_trci(jdof) ) THEN ! Stochastic tracers dynamics i (ave=0) + sto2d_ord(jsto) = nn_trc_ord - jord + sto2d_sgn(jsto) = -1._wp + sto2d_flt(jsto) = nn_trc_flt + ENDIF + IF ( jsto+jord == jsto_trcj(jdof) ) THEN ! Stochastic tracers dynamics j (ave=0) + sto2d_ord(jsto) = nn_trc_ord - jord + sto2d_sgn(jsto) = -1._wp + sto2d_flt(jsto) = nn_trc_flt + ENDIF + IF ( jsto+jord == jsto_trck(jdof) ) THEN ! Stochastic tracers dynamics k (ave=0) + sto2d_ord(jsto) = nn_trc_ord - jord + sto2d_flt(jsto) = nn_trc_flt + ENDIF + END DO + END DO + + sto2d_fac(jsto) = sto_par_flt_fac ( sto2d_flt(jsto) ) + END DO + ! + DO jsto = 1, jpsto3d + sto3d_typ(jsto) = 'T' + sto3d_sgn(jsto) = 1._wp + sto3d_flt(jsto) = 0 + sto3d_ord(jsto) = 1 + IF ( jsto == jsto_hpgi ) THEN ! Stochastic density gradient i (ave=1) + sto3d_typ(jsto) = 'U' + ENDIF + IF ( jsto == jsto_hpgj ) THEN ! Stochastic density gradient j (ave=1) + sto3d_typ(jsto) = 'V' + ENDIF + sto3d_fac(jsto) = sto_par_flt_fac ( sto3d_flt(jsto) ) + END DO + + ! 2) For every stochastic parameter: + ! ---------------------------------- + ! set average, standard deviation and time correlation + DO jsto = 1, jpsto2d + sto2d_ave(jsto) = 0._wp + sto2d_std(jsto) = 1._wp + sto2d_tcor(jsto) = 1._wp + sto2d_lim(jsto) = 3._wp + IF ( jsto == jsto_ldf ) THEN ! Stochastic lateral diffusion (ave=1) + sto2d_ave(jsto) = 1._wp + sto2d_std(jsto) = rn_ldf_std + sto2d_tcor(jsto) = rn_ldf_tcor + ENDIF + DO jord = 0, nn_pstar_ord-1 + IF ( jsto+jord == jsto_pstar ) THEN ! Stochastic ice strength (ave=1) + sto2d_std(jsto) = 1._wp + sto2d_tcor(jsto) = rn_pstar_tcor + ENDIF + ENDDO + DO jdof = 1, nn_sto_eos + DO jord = 0, nn_eos_ord-1 + IF ( jsto+jord == jsto_eosi(jdof) ) THEN ! Stochastic equation of state i (ave=0) + sto2d_std(jsto) = rn_eos_stdxy + sto2d_tcor(jsto) = rn_eos_tcor + sto2d_lim(jsto) = rn_eos_lim + ENDIF + IF ( jsto+jord == jsto_eosj(jdof) ) THEN ! Stochastic equation of state j (ave=0) + sto2d_std(jsto) = rn_eos_stdxy + sto2d_tcor(jsto) = rn_eos_tcor + sto2d_lim(jsto) = rn_eos_lim + ENDIF + IF ( jsto+jord == jsto_eosk(jdof) ) THEN ! Stochastic equation of state k (ave=0) + sto2d_std(jsto) = rn_eos_stdz + sto2d_tcor(jsto) = rn_eos_tcor + sto2d_lim(jsto) = rn_eos_lim + ENDIF + END DO + END DO + DO jdof = 1, nn_sto_trc + DO jord = 0, nn_trc_ord-1 + IF ( jsto+jord == jsto_trci(jdof) ) THEN ! Stochastic tracer dynamics i (ave=0) + sto2d_std(jsto) = rn_trc_stdxy + sto2d_tcor(jsto) = rn_trc_tcor + sto2d_lim(jsto) = rn_trc_lim + ENDIF + IF ( jsto+jord == jsto_trcj(jdof) ) THEN ! Stochastic tracer dynamics j (ave=0) + sto2d_std(jsto) = rn_trc_stdxy + sto2d_tcor(jsto) = rn_trc_tcor + sto2d_lim(jsto) = rn_trc_lim + ENDIF + IF ( jsto+jord == jsto_trck(jdof) ) THEN ! Stochastic tracer dynamics k (ave=0) + sto2d_std(jsto) = rn_trc_stdz + sto2d_tcor(jsto) = rn_trc_tcor + sto2d_lim(jsto) = rn_trc_lim + ENDIF + END DO + END DO + + END DO + ! + DO jsto = 1, jpsto3d + sto3d_ave(jsto) = 0._wp + sto3d_std(jsto) = 1._wp + sto3d_tcor(jsto) = 1._wp + sto3d_lim(jsto) = 3._wp + IF ( jsto == jsto_hpgi ) THEN ! Stochastic density gradient i (ave=1) + sto3d_ave(jsto) = 1._wp + sto3d_std(jsto) = rn_hpg_std + sto3d_tcor(jsto) = rn_hpg_tcor + ENDIF + IF ( jsto == jsto_hpgj ) THEN ! Stochastic density gradient j (ave=1) + sto3d_ave(jsto) = 1._wp + sto3d_std(jsto) = rn_hpg_std + sto3d_tcor(jsto) = rn_hpg_tcor + ENDIF + IF ( jsto == jsto_trd ) THEN ! Stochastic trend (ave=1) + sto3d_ave(jsto) = 1._wp + sto3d_std(jsto) = rn_trd_std + sto3d_tcor(jsto) = rn_trd_tcor + ENDIF + END DO + + ! 3) For every stochastic parameter: + ! ---------------------------------- + ! - compute parameters (a, b, c) of the AR1 autoregressive process + ! from expected value (ave), standard deviation (std) + ! and time correlation (tcor): + ! a = EXP ( - 1 / tcor ) --> sto2d_abc(:,1) + ! b = std * SQRT( 1 - a * a ) --> sto2d_abc(:,2) + ! c = ave * ( 1 - a ) --> sto2d_abc(:,3) + ! - for higher order processes (ARn, n>1), use approximate formula + ! for the b parameter (valid for tcor>>1 time step) + DO jsto = 1, jpsto2d + IF ( sto2d_tcor(jsto) == 0._wp ) THEN + sto2d_abc(jsto,1) = 0._wp + ELSE + sto2d_abc(jsto,1) = EXP ( - 1._wp / sto2d_tcor(jsto) ) + ENDIF + IF ( sto2d_ord(jsto) == 1 ) THEN ! Exact formula for 1st order process + rinflate = sto2d_std(jsto) + ELSE + ! Approximate formula, valid for tcor >> 1 + jordm1 = sto2d_ord(jsto) - 1 + rinflate = SQRT ( REAL( jordm1 , wp ) / REAL( 2*(2*jordm1-1) , wp ) ) + ENDIF + sto2d_abc(jsto,2) = rinflate * SQRT ( 1._wp - sto2d_abc(jsto,1) & + * sto2d_abc(jsto,1) ) + sto2d_abc(jsto,3) = sto2d_ave(jsto) * ( 1._wp - sto2d_abc(jsto,1) ) + END DO + ! + DO jsto = 1, jpsto3d + IF ( sto3d_tcor(jsto) == 0._wp ) THEN + sto3d_abc(jsto,1) = 0._wp + ELSE + sto3d_abc(jsto,1) = EXP ( - 1._wp / sto3d_tcor(jsto) ) + ENDIF + IF ( sto3d_ord(jsto) == 1 ) THEN ! Exact formula for 1st order process + rinflate = sto3d_std(jsto) + ELSE + ! Approximate formula, valid for tcor >> 1 + jordm1 = sto3d_ord(jsto) - 1 + rinflate = SQRT ( REAL( jordm1 , wp ) / REAL( 2*(2*jordm1-1) , wp ) ) + ENDIF + sto3d_abc(jsto,2) = rinflate * SQRT ( 1._wp - sto3d_abc(jsto,1) & + * sto3d_abc(jsto,1) ) + sto3d_abc(jsto,3) = sto3d_ave(jsto) * ( 1._wp - sto3d_abc(jsto,1) ) + END DO + + ! 4) Initialize seeds for random number generator + ! ----------------------------------------------- + ! using different seeds for different processors (jarea) + ! and different ensemble members (jmem) + CALL kiss_reset( ) + DO jarea = 1, narea + !DO jmem = 0, nmember + zseed1 = kiss() ; zseed2 = kiss() ; zseed3 = kiss() ; zseed4 = kiss() + !END DO + END DO + CALL kiss_seed( zseed1, zseed2, zseed3, zseed4 ) + + ! 5) Initialize stochastic parameters to: ave + std * w + ! ----------------------------------------------------- + DO jsto = 1, jpsto2d + ! Draw random numbers from N(0,1) --> w + CALL sto_par_white( sto2d(:,:,jsto) ) + ! Apply horizontal Laplacian filter to w + DO jflt = 1, sto2d_flt(jsto) + CALL lbc_lnk( 'stopar', sto2d(:,:,jsto), sto2d_typ(jsto), sto2d_sgn(jsto) ) + CALL sto_par_flt( sto2d(:,:,jsto) ) + END DO + ! Factor to restore standard deviation after filtering + sto2d(:,:,jsto) = sto2d(:,:,jsto) * sto2d_fac(jsto) + ! Limit random parameter to the limitation factor + sto2d(:,:,jsto) = SIGN(MIN(sto2d_lim(jsto),ABS(sto2d(:,:,jsto))),sto2d(:,:,jsto)) + ! Multiply by standard devation and add average value + sto2d(:,:,jsto) = sto2d(:,:,jsto) * sto2d_std(jsto) + sto2d_ave(jsto) + END DO + ! + DO jsto = 1, jpsto3d + DO jk = 1, jpk + ! Draw random numbers from N(0,1) --> w + CALL sto_par_white( sto3d(:,:,jk,jsto) ) + ! Apply horizontal Laplacian filter to w + DO jflt = 1, sto3d_flt(jsto) + CALL lbc_lnk( 'stopar', sto3d(:,:,jk,jsto), sto3d_typ(jsto), sto3d_sgn(jsto) ) + CALL sto_par_flt( sto3d(:,:,jk,jsto) ) + END DO + ! Factor to restore standard deviation after filtering + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) * sto3d_fac(jsto) + ! Limit random parameter to the limitation factor + sto3d(:,:,jk,jsto) = SIGN(MIN(sto3d_lim(jsto),ABS(sto3d(:,:,jk,jsto))),sto3d(:,:,jk,jsto)) + ! Multiply by standard devation and add average value + sto3d(:,:,jk,jsto) = sto3d(:,:,jk,jsto) * sto3d_std(jsto) + sto3d_ave(jsto) + END DO + END DO + + ! 6) Restart stochastic parameters from file + ! ------------------------------------------ + IF( ln_rststo ) CALL sto_rst_read + + END SUBROUTINE sto_par_init + + + SUBROUTINE sto_rst_read + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_rst_read *** + !! + !! ** Purpose : read stochastic parameters from restart file + !!---------------------------------------------------------------------- + INTEGER :: jsto, jseed + INTEGER :: idg ! number of digits + INTEGER(KIND=8) :: ziseed(4) ! RNG seeds in integer type + REAL(KIND=dp) :: zrseed(4) ! RNG seeds in double-precision (with same bits to save in restart) + CHARACTER(LEN=9) :: clsto2d='sto2d_000' ! stochastic parameter variable name + CHARACTER(LEN=9) :: clsto3d='sto3d_000' ! stochastic parameter variable name + CHARACTER(LEN=15) :: clseed='seed0_0000' ! seed variable name + CHARACTER(LEN=6) :: clfmt ! writing format + !!---------------------------------------------------------------------- + + IF ( jpsto2d > 0 .OR. jpsto3d > 0 ) THEN + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sto_rst_read : read stochastic parameters from restart file' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + + ! Open the restart file + CALL iom_open( cn_storst_in, numstor ) + + ! Get stochastic parameters from restart file: + ! 2D stochastic parameters + DO jsto = 1 , jpsto2d + WRITE(clsto2d(7:9),'(i3.3)') jsto + CALL iom_get( numstor, jpdom_auto, clsto2d, sto2d(:,:, jsto) ) + END DO + ! 3D stochastic parameters + DO jsto = 1 , jpsto3d + WRITE(clsto3d(7:9),'(i3.3)') jsto + CALL iom_get( numstor, jpdom_auto, clsto3d, sto3d(:,:,:,jsto) ) + END DO + + IF (ln_rstseed) THEN + ! Get saved state of the random number generator + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(i', i1, '.', i1, ')')") idg, idg ! "(ix.x)" + DO jseed = 1 , 4 + WRITE(clseed(5:5) ,'(i1.1)') jseed + WRITE(clseed(7:7+idg-1), clfmt ) narea + CALL iom_get( numstor, clseed(1:7+idg-1) , zrseed(jseed) ) + END DO + ziseed = TRANSFER( zrseed , ziseed) + CALL kiss_seed( ziseed(1) , ziseed(2) , ziseed(3) , ziseed(4) ) + ENDIF + + ! Close the restart file + CALL iom_close( numstor ) + + ENDIF + + END SUBROUTINE sto_rst_read + + + SUBROUTINE sto_rst_write( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_rst_write *** + !! + !! ** Purpose : write stochastic parameters in restart file + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step + !! + INTEGER :: jsto, jseed + INTEGER :: idg ! number of digits + INTEGER(KIND=8) :: ziseed(4) ! RNG seeds in integer type + REAL(KIND=dp) :: zrseed(4) ! RNG seeds in double-precision (with same bits to save in restart) + CHARACTER(LEN=20) :: clkt ! ocean time-step defined as a character + CHARACTER(LEN=50) :: clname ! restart file name + CHARACTER(LEN=9) :: clsto2d='sto2d_000' ! stochastic parameter variable name + CHARACTER(LEN=9) :: clsto3d='sto3d_000' ! stochastic parameter variable name + CHARACTER(LEN=15) :: clseed='seed0_0000' ! seed variable name + CHARACTER(LEN=6) :: clfmt ! writing format + !!---------------------------------------------------------------------- + + IF( .NOT. ln_rst_list .AND. nn_stock == -1 ) RETURN ! we will never do any restart + + IF ( jpsto2d > 0 .OR. jpsto3d > 0 ) THEN + + IF( kt == nitrst .OR. kt == nitend ) THEN + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sto_rst_write : write stochastic parameters in restart file' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + ENDIF + + ! Put stochastic parameters in restart files + ! (as opened at previous timestep, see below) + IF( kt > nit000) THEN + IF( kt == nitrst .OR. kt == nitend ) THEN + ! get and save current state of the random number generator + CALL kiss_state( ziseed(1) , ziseed(2) , ziseed(3) , ziseed(4) ) + zrseed = TRANSFER( ziseed , zrseed) + idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9 + WRITE(clfmt, "('(i', i1, '.', i1, ')')") idg, idg ! "(ix.x)" + DO jseed = 1 , 4 + WRITE(clseed(5:5) ,'(i1.1)') jseed + WRITE(clseed(7:7+idg-1), clfmt ) narea + CALL iom_rstput( kt, nitrst, numstow, clseed(1:7+idg-1), zrseed(jseed) ) + END DO + ! 2D stochastic parameters + DO jsto = 1 , jpsto2d + WRITE(clsto2d(7:9),'(i3.3)') jsto + CALL iom_rstput( kt, nitrst, numstow, clsto2d , sto2d(:,:,jsto) ) + END DO + ! 3D stochastic parameters + DO jsto = 1 , jpsto3d + WRITE(clsto3d(7:9),'(i3.3)') jsto + CALL iom_rstput( kt, nitrst, numstow, clsto3d , sto3d(:,:,:,jsto) ) + END DO + ! close the restart file + CALL iom_close( numstow ) + ENDIF + ENDIF + + ! Open the restart file one timestep before writing restart + IF( kt < nitend) THEN + IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. kt == nitend-1 ) THEN + ! create the filename + IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst + ELSE ; WRITE(clkt, '(i8.8)') nitrst + ENDIF + clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_storst_out) + ! print information + IF(lwp) THEN + WRITE(numout,*) ' open stochastic parameters restart file: '//clname + IF( kt == nitrst - 1 ) THEN + WRITE(numout,*) ' kt = nitrst - 1 = ', kt + ELSE + WRITE(numout,*) ' kt = ' , kt + ENDIF + ENDIF + ! open the restart file + CALL iom_open( clname, numstow, ldwrt = .TRUE. ) + ENDIF + ENDIF + + ENDIF + + END SUBROUTINE sto_rst_write + + + SUBROUTINE sto_par_white( psto ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_par_white *** + !! + !! ** Purpose : fill input array with white Gaussian noise + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: psto + !! + INTEGER :: ji, jj + REAL(wp) :: gran ! Gaussian random number (forced KIND=8 as in kiss_gaussian) + + DO_2D( 1, 1, 1, 1 ) + CALL kiss_gaussian( gran ) + psto(ji,jj) = gran + END_2D + + END SUBROUTINE sto_par_white + + + SUBROUTINE sto_par_flt( psto ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_par_flt *** + !! + !! ** Purpose : apply horizontal Laplacian filter to input array + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(out) :: psto + !! + INTEGER :: ji, jj + + DO_2D( 0, 0, 0, 0 ) + psto(ji,jj) = 0.5_wp * psto(ji,jj) + 0.125_wp * & + & ( psto(ji-1,jj) + psto(ji+1,jj) + & + & psto(ji,jj-1) + psto(ji,jj+1) ) + END_2D + + END SUBROUTINE sto_par_flt + + + FUNCTION sto_par_flt_fac( kpasses ) + !!---------------------------------------------------------------------- + !! *** FUNCTION sto_par_flt_fac *** + !! + !! ** Purpose : compute factor to restore standard deviation + !! as a function of the number of passes + !! of the Laplacian filter + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kpasses + REAL(wp) :: sto_par_flt_fac + !! + INTEGER :: jpasses, ji, jj, jflti, jfltj + INTEGER, DIMENSION(-1:1,-1:1) :: pflt0 + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pfltb + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pflta + REAL(wp) :: ratio + + pflt0(-1,-1) = 0 ; pflt0(-1,0) = 1 ; pflt0(-1,1) = 0 + pflt0( 0,-1) = 1 ; pflt0( 0,0) = 4 ; pflt0( 0,1) = 1 + pflt0( 1,-1) = 0 ; pflt0( 1,0) = 1 ; pflt0( 1,1) = 0 + + ALLOCATE(pfltb(-kpasses-1:kpasses+1,-kpasses-1:kpasses+1)) + ALLOCATE(pflta(-kpasses-1:kpasses+1,-kpasses-1:kpasses+1)) + + pfltb(:,:) = 0 + pfltb(0,0) = 1 + DO jpasses = 1, kpasses + pflta(:,:) = 0 + DO jflti= -1, 1 + DO jfltj= -1, 1 + DO ji= -kpasses, kpasses + DO jj= -kpasses, kpasses + pflta(ji,jj) = pflta(ji,jj) + pfltb(ji+jflti,jj+jfltj) * pflt0(jflti,jfltj) + ENDDO + ENDDO + ENDDO + ENDDO + pfltb(:,:) = pflta(:,:) + ENDDO + + ratio = SUM(pfltb(:,:)) + ratio = ratio * ratio / SUM(pfltb(:,:)*pfltb(:,:)) + ratio = SQRT(ratio) + + DEALLOCATE(pfltb,pflta) + + sto_par_flt_fac = ratio + + END FUNCTION sto_par_flt_fac + + +END MODULE stopar \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/STO/stopts.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/STO/stopts.F90 new file mode 100644 index 0000000..aeb80e5 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/STO/stopts.F90 @@ -0,0 +1,142 @@ +MODULE stopts + !!============================================================================== + !! *** MODULE stopts *** + !! Stochastic parameterization: compute stochastic tracer fluctuations + !!============================================================================== + !! History : 3.3 ! 2011-12 (J.-M. Brankart) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sto_pts : compute current stochastic tracer fluctuations + !! sto_pts_init : initialisation for stochastic tracer fluctuations + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE lbclnk ! lateral boundary conditions (or mpp link) + USE phycst ! physical constants + USE stopar ! stochastic parameterization + + IMPLICIT NONE + PRIVATE + + PUBLIC sto_pts ! called by step.F90 + PUBLIC sto_pts_init ! called by nemogcm.F90 + + ! Public array with random tracer fluctuations + REAL(wp), PUBLIC, DIMENSION(:,:,:,:,:), ALLOCATABLE :: pts_ran + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: stopts.F90 13295 2020-07-10 18:24:21Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sto_pts( pts ) + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_pts *** + !! + !! ** Purpose : Compute current stochastic tracer fluctuations + !! + !! ** Method : Compute tracer differences from a random walk + !! around every model grid point + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + INTEGER :: ji, jj, jk, jts, jdof ! dummy loop indices + INTEGER :: jim1, jjm1, jkm1 ! incremented indices + INTEGER :: jip1, jjp1, jkp1 ! - - + REAL(wp) :: zdtsim, zdtsjm, zdtskm ! temporary scalars + REAL(wp) :: zdtsip, zdtsjp, zdtskp, zdts ! - - + !!---------------------------------------------------------------------- + + DO jts = 1, jpts + CALL lbc_lnk( 'stopts', pts(:,:,:,jts), 'T' , 1._dp ) + ENDDO + + DO jdof = 1, nn_sto_eos + DO jts = 1, jpts + DO jk = 1, jpkm1 + jkm1 = MAX(jk-1,1) ; jkp1 = MIN(jk+1,jpkm1) + DO jj = 1, jpj + jjm1 = MAX(jj-1,1) ; jjp1 = MIN(jj+1,jpj) + DO ji = 1, jpi + jim1 = MAX(ji-1,1) ; jip1 = MIN(ji+1,jpi) + ! + ! compute tracer gradient + zdtsip = ( pts(jip1,jj,jk,jts) - pts(ji,jj,jk,jts) ) * tmask(jip1,jj,jk) + zdtsim = ( pts(ji,jj,jk,jts) - pts(jim1,jj,jk,jts) ) * tmask(jim1,jj,jk) + zdtsjp = ( pts(ji,jjp1,jk,jts) - pts(ji,jj,jk,jts) ) * tmask(ji,jjp1,jk) + zdtsjm = ( pts(ji,jj,jk,jts) - pts(ji,jjm1,jk,jts) ) * tmask(ji,jjm1,jk) + zdtskp = ( pts(ji,jj,jkp1,jts) - pts(ji,jj,jk,jts) ) * tmask(ji,jj,jkp1) + zdtskm = ( pts(ji,jj,jk,jts) - pts(ji,jj,jkm1,jts) ) * tmask(ji,jj,jkm1) + ! + ! compute random tracer fluctuation (zdts) + zdts = ( zdtsip + zdtsim ) * sto2d(ji,jj,jsto_eosi(jdof)) + & + & ( zdtsjp + zdtsjm ) * sto2d(ji,jj,jsto_eosj(jdof)) + & + & ( zdtskp + zdtskm ) * sto2d(ji,jj,jsto_eosk(jdof)) +! zdts = zdtsip * MAX(sto2d(ji,jj,jsto_eosi),0._wp) + & +! & zdtsim * MIN(sto2d(ji,jj,jsto_eosi),0._wp) + & +! & zdtsjp * MAX(sto2d(ji,jj,jsto_eosj),0._wp) + & +! & zdtsjm * MIN(sto2d(ji,jj,jsto_eosj),0._wp) + & +! & zdtskp * MAX(sto2d(ji,jj,jsto_eosk),0._wp) + & +! & zdtskm * MIN(sto2d(ji,jj,jsto_eosk),0._wp) + zdts = zdts * tmask(ji,jj,jk) *SIN( gphit(ji,jj) * rad ) + pts_ran(ji,jj,jk,jts,jdof) = zdts * 0.5_wp + ! + END DO + END DO + END DO + END DO + END DO + + ! Eliminate any possible negative salinity + DO jdof = 1, nn_sto_eos + DO_3D( 1, 1, 1, 1, 1, jpkm1 ) + pts_ran(ji,jj,jk,jp_sal,jdof) = MIN( ABS(pts_ran(ji,jj,jk,jp_sal,jdof)) , & + & MAX(pts(ji,jj,jk,jp_sal),0._wp) ) & + & * SIGN(1._wp,pts_ran(ji,jj,jk,jp_sal,jdof)) + END_3D + END DO + + ! Eliminate any temperature lower than -2 degC +! DO jdof = 1, nn_sto_eos +! DO jk = 1, jpkm1 +! DO jj = 1, jpj +! DO ji = 1, jpi +! pts_ran(ji,jj,jk,jp_tem,jdof) = MIN( ABS(pts_ran(ji,jj,jk,jp_tem,jdof)) , & +! & MAX(pts(ji,jj,jk,jp_tem)+2._wp,0._wp) ) & +! & * SIGN(1._wp,pts_ran(ji,jj,jk,jp_tem,jdof)) +! END DO +! END DO +! END DO +! END DO + + + ! Lateral boundary conditions on pts_ran + DO jdof = 1, nn_sto_eos + DO jts = 1, jpts + CALL lbc_lnk( 'stopts', pts_ran(:,:,:,jts,jdof), 'T' , 1._wp ) + END DO + END DO + + END SUBROUTINE sto_pts + + + SUBROUTINE sto_pts_init + !!---------------------------------------------------------------------- + !! *** ROUTINE sto_pts_init *** + !! + !! ** Purpose : Initialisation for stochastic tracer fluctuations + !! + !! ** Method : Allocate required array + !! + !!---------------------------------------------------------------------- + + ALLOCATE(pts_ran(jpi,jpj,jpk,jpts,nn_sto_eos)) + + END SUBROUTINE sto_pts_init + +END MODULE stopts diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/STO/storng.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/STO/storng.F90 new file mode 100644 index 0000000..57eef37 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/STO/storng.F90 @@ -0,0 +1,408 @@ +MODULE storng +!$AGRIF_DO_NOT_TREAT + !!====================================================================== + !! *** MODULE storng *** + !! Random number generator, used in NEMO stochastic parameterization + !! + !!===================================================================== + !! History : 3.3 ! 2011-10 (J.-M. Brankart) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! The module is based on (and includes) the + !! 64-bit KISS (Keep It Simple Stupid) random number generator + !! distributed by George Marsaglia : + !! http://groups.google.com/group/comp.lang.fortran/ + !! browse_thread/thread/a85bf5f2a97f5a55 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! kiss : 64-bit KISS random number generator (period ~ 2^250) + !! kiss_seed : Define seeds for KISS random number generator + !! kiss_state : Get current state of KISS random number generator + !! kiss_save : Save current state of KISS (for future restart) + !! kiss_load : Load the saved state of KISS + !! kiss_reset : Reset the default seeds + !! kiss_check : Check the KISS pseudo-random sequence + !! kiss_uniform : Real random numbers with uniform distribution in [0,1] + !! kiss_gaussian : Real random numbers with Gaussian distribution N(0,1) + !! kiss_gamma : Real random numbers with Gamma distribution Gamma(k,1) + !! kiss_sample : Select a random sample from a set of integers + !! + !! ---CURRENTLY NOT USED IN NEMO : + !! kiss_save, kiss_load, kiss_check, kiss_gamma, kiss_sample + !!---------------------------------------------------------------------- + USE par_kind + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + ! Public functions/subroutines + PUBLIC :: kiss, kiss_seed, kiss_state, kiss_reset ! kiss_save, kiss_load, kiss_check + PUBLIC :: kiss_uniform, kiss_gaussian, kiss_gamma, kiss_sample + + ! Default/initial seeds + INTEGER(KIND=i8) :: x=1234567890987654321_8 + INTEGER(KIND=i8) :: y=362436362436362436_8 + INTEGER(KIND=i8) :: z=1066149217761810_8 + INTEGER(KIND=i8) :: w=123456123456123456_8 + + ! Parameters to generate real random variates + REAL(KIND=wp), PARAMETER :: zero=0.0, half=0.5, one=1.0, two=2.0 + + ! Variables to store 2 Gaussian random numbers with current index (ig) + INTEGER(KIND=i8), SAVE :: ig=1 + REAL(KIND=wp), SAVE :: gran1, gran2 + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: storng.F90 12649 2020-04-03 07:11:57Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + FUNCTION kiss() + !! -------------------------------------------------------------------- + !! *** FUNCTION kiss *** + !! + !! ** Purpose : 64-bit KISS random number generator + !! + !! ** Method : combine several random number generators: + !! (1) Xorshift (XSH), period 2^64-1, + !! (2) Multiply-with-carry (MWC), period (2^121+2^63-1) + !! (3) Congruential generator (CNG), period 2^64. + !! + !! overall period: + !! (2^250+2^192+2^64-2^186-2^129)/6 + !! ~= 2^(247.42) or 10^(74.48) + !! + !! set your own seeds with 'kiss_seed' + ! -------------------------------------------------------------------- + IMPLICIT NONE + INTEGER(KIND=i8) :: kiss, t + + t = ISHFT(x,58) + w + IF (s(x).eq.s(t)) THEN + w = ISHFT(x,-6) + s(x) + ELSE + w = ISHFT(x,-6) + 1 - s(x+t) + ENDIF + x = t + x + y = m( m( m(y,13_8), -17_8 ), 43_8 ) + z = 6906969069_8 * z + 1234567_8 + + kiss = x + y + z + + CONTAINS + + FUNCTION s(k) + INTEGER(KIND=i8) :: s, k + s = ISHFT(k,-63) + END FUNCTION s + + FUNCTION m(k, n) + INTEGER(KIND=i8) :: m, k, n + m = IEOR(k, ISHFT(k, n) ) + END FUNCTION m + + END FUNCTION kiss + + + SUBROUTINE kiss_seed(ix, iy, iz, iw) + !! -------------------------------------------------------------------- + !! *** ROUTINE kiss_seed *** + !! + !! ** Purpose : Define seeds for KISS random number generator + !! + !! -------------------------------------------------------------------- + IMPLICIT NONE + INTEGER(KIND=i8) :: ix, iy, iz, iw + + x = ix + y = iy + z = iz + w = iw + + END SUBROUTINE kiss_seed + + + SUBROUTINE kiss_state(ix, iy, iz, iw) + !! -------------------------------------------------------------------- + !! *** ROUTINE kiss_state *** + !! + !! ** Purpose : Get current state of KISS random number generator + !! + !! -------------------------------------------------------------------- + IMPLICIT NONE + INTEGER(KIND=i8) :: ix, iy, iz, iw + + ix = x + iy = y + iz = z + iw = w + + END SUBROUTINE kiss_state + + + SUBROUTINE kiss_reset() + !! -------------------------------------------------------------------- + !! *** ROUTINE kiss_reset *** + !! + !! ** Purpose : Reset the default seeds for KISS random number generator + !! + !! -------------------------------------------------------------------- + IMPLICIT NONE + + x=1234567890987654321_8 + y=362436362436362436_8 + z=1066149217761810_8 + w=123456123456123456_8 + + END SUBROUTINE kiss_reset + + + ! SUBROUTINE kiss_check(check_type) + ! !! -------------------------------------------------------------------- + ! !! *** ROUTINE kiss_check *** + ! !! + ! !! ** Purpose : Check the KISS pseudo-random sequence + ! !! + ! !! ** Method : Check that it reproduces the correct sequence + ! !! from the default seed + ! !! + ! !! -------------------------------------------------------------------- + ! IMPLICIT NONE + ! INTEGER(KIND=i8) :: iter, niter, correct, iran + ! CHARACTER(LEN=*) :: check_type + ! LOGICAL :: print_success + + ! ! Save current state of KISS + ! CALL kiss_save() + ! ! Reset the default seed + ! CALL kiss_reset() + + ! ! Select check type + ! SELECT CASE(check_type) + ! CASE('short') + ! niter = 5_8 + ! correct = 542381058189297533 + ! print_success = .FALSE. + ! CASE('long') + ! niter = 100000000_8 + ! correct = 1666297717051644203 ! Check provided by G. Marsaglia + ! print_success = .TRUE. + ! CASE('default') + ! CASE DEFAULT + ! STOP 'Bad check type in kiss_check' + ! END SELECT + + ! ! Run kiss for the required number of iterations (niter) + ! DO iter=1,niter + ! iran = kiss() + ! ENDDO + + ! ! Check that last iterate is correct + ! IF (iran.NE.correct) THEN + ! STOP 'Check failed: KISS internal error !!' + ! ELSE + ! IF (print_success) PRINT *, 'Check successful: 100 million calls to KISS OK' + ! ENDIF + + ! ! Reload the previous state of KISS + ! CALL kiss_load() + + ! END SUBROUTINE kiss_check + + + ! SUBROUTINE kiss_save + ! !! -------------------------------------------------------------------- + ! !! *** ROUTINE kiss_save *** + ! !! + ! !! ** Purpose : Save current state of KISS random number generator + ! !! + ! !! -------------------------------------------------------------------- + ! INTEGER :: inum !! Local integer + + ! IMPLICIT NONE + + ! CALL ctl_opn( inum, '.kiss_restart', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) + + ! ! OPEN(UNIT=30,FILE='.kiss_restart') + ! WRITE(inum,*) x + ! WRITE(inum,*) y + ! WRITE(inum,*) z + ! WRITE(inum,*) w + ! CALL flush(inum) + + ! END SUBROUTINE kiss_save + + + ! SUBROUTINE kiss_load + ! !! -------------------------------------------------------------------- + ! !! *** ROUTINE kiss_load *** + ! !! + ! !! ** Purpose : Load the saved state of KISS random number generator + ! !! + ! !! -------------------------------------------------------------------- + ! IMPLICIT NONE + ! LOGICAL :: filexists + ! Use ctl_opn routine rather than fortran intrinsic functions + ! INQUIRE(FILE='.kiss_restart',EXIST=filexists) + ! IF (filexists) THEN + ! OPEN(UNIT=30,FILE='.kiss_restart') + ! READ(30,*) x + ! READ(30,*) y + ! READ(30,*) z + ! READ(30,*) w + ! CLOSE(30) + ! ENDIF + + ! END SUBROUTINE kiss_load + + + SUBROUTINE kiss_uniform(uran) + !! -------------------------------------------------------------------- + !! *** ROUTINE kiss_uniform *** + !! + !! ** Purpose : Real random numbers with uniform distribution in [0,1] + !! + !! -------------------------------------------------------------------- + IMPLICIT NONE + REAL(KIND=wp) :: uran + + uran = half * ( one + REAL(kiss(),wp) / HUGE(1._wp) ) + + END SUBROUTINE kiss_uniform + + + SUBROUTINE kiss_gaussian(gran) + !! -------------------------------------------------------------------- + !! *** ROUTINE kiss_gaussian *** + !! + !! ** Purpose : Real random numbers with Gaussian distribution N(0,1) + !! + !! ** Method : Generate 2 new Gaussian draws (gran1 and gran2) + !! from 2 uniform draws on [-1,1] (u1 and u2), + !! using the Marsaglia polar method + !! (see Devroye, Non-Uniform Random Variate Generation, p. 235-236) + !! + !! -------------------------------------------------------------------- + IMPLICIT NONE + REAL(KIND=wp) :: gran, u1, u2, rsq, fac + + IF (ig.EQ.1) THEN + rsq = two + DO WHILE ( (rsq.GE.one).OR. (rsq.EQ.zero) ) + u1 = REAL(kiss(),wp) / HUGE(1._wp) + u2 = REAL(kiss(),wp) / HUGE(1._wp) + rsq = u1*u1 + u2*u2 + ENDDO + fac = SQRT(-two*LOG(rsq)/rsq) + gran1 = u1 * fac + gran2 = u2 * fac + ENDIF + + ! Output one of the 2 draws + IF (ig.EQ.1) THEN + gran = gran1 ; ig = 2 + ELSE + gran = gran2 ; ig = 1 + ENDIF + + END SUBROUTINE kiss_gaussian + + + SUBROUTINE kiss_gamma(gamr,k) + !! -------------------------------------------------------------------- + !! *** ROUTINE kiss_gamma *** + !! + !! ** Purpose : Real random numbers with Gamma distribution Gamma(k,1) + !! + !! -------------------------------------------------------------------- + IMPLICIT NONE + REAL(KIND=wp), PARAMETER :: p1 = 4.5_8 + REAL(KIND=wp), PARAMETER :: p2 = 2.50407739677627_8 ! 1+LOG(9/2) + REAL(KIND=wp), PARAMETER :: p3 = 1.38629436111989_8 ! LOG(4) + REAL(KIND=wp) :: gamr, k, u1, u2, b, c, d, xx, yy, zz, rr, ee + LOGICAL :: accepted + + IF (k.GT.one) THEN + ! Cheng's rejection algorithm + ! (see Devroye, Non-Uniform Random Variate Generation, p. 413) + b = k - p3 ; d = SQRT(two*k-one) ; c = k + d + + accepted=.FALSE. + DO WHILE (.NOT.accepted) + CALL kiss_uniform(u1) + yy = LOG(u1/(one-u1)) / d ! Mistake in Devroye: "* k" instead of "/ d" + xx = k * EXP(yy) + rr = b + c * yy - xx + CALL kiss_uniform(u2) + zz = u1 * u1 * u2 + + accepted = rr .GE. (zz*p1-p2) + IF (.NOT.accepted) accepted = rr .GE. LOG(zz) + ENDDO + + gamr = xx + + ELSEIF (k.LT.one) THEN + ! Rejection from the Weibull density + ! (see Devroye, Non-Uniform Random Variate Generation, p. 415) + c = one/k ; d = (one-k) * EXP( (k/(one-k)) * LOG(k) ) + + accepted=.FALSE. + DO WHILE (.NOT.accepted) + CALL kiss_uniform(u1) + zz = -LOG(u1) + xx = EXP( c * LOG(zz) ) + CALL kiss_uniform(u2) + ee = -LOG(u2) + + accepted = (zz+ee) .GE. (d+xx) ! Mistake in Devroye: "LE" instead of "GE" + ENDDO + + gamr = xx + + ELSE + ! Exponential distribution + CALL kiss_uniform(u1) + gamr = -LOG(u1) + + ENDIF + + END SUBROUTINE kiss_gamma + + + SUBROUTINE kiss_sample(a,n,k) + !! -------------------------------------------------------------------- + !! *** ROUTINE kiss_sample *** + !! + !! ** Purpose : Select a random sample of size k from a set of n integers + !! + !! ** Method : The sample is output in the first k elements of a + !! Set k equal to n to obtain a random permutation + !! of the whole set of integers + !! + !! -------------------------------------------------------------------- + IMPLICIT NONE + INTEGER(KIND=i8), DIMENSION(:) :: a + INTEGER(KIND=i8) :: n, k, i, j, atmp + REAL(KIND=wp) :: uran + + ! Select the sample using the swapping method + ! (see Devroye, Non-Uniform Random Variate Generation, p. 612) + DO i=1,k + ! Randomly select the swapping element between i and n (inclusive) + CALL kiss_uniform(uran) + j = i - 1 + CEILING( REAL(n-i+1,8) * uran ) + ! Swap elements i and j + atmp = a(i) ; a(i) = a(j) ; a(j) = atmp + ENDDO + + END SUBROUTINE kiss_sample +!$AGRIF_END_DO_NOT_TREAT +END MODULE storng \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TDE/tide.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TDE/tide.h90 new file mode 100644 index 0000000..fb03c09 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TDE/tide.h90 @@ -0,0 +1,172 @@ +!!===================================================================== + !! *** Include file tide.h90 *** + !!====================================================================== + !! History : 3.2 ! 2007 (O. Le Galloudec) Original code + !! ! 2019 (S. Mueller, N. Bruneau) Alternative parameter set + !!---------------------------------------------------------------------- + !! + !! ** Purpose : Inclusion of alternative variants of tidal-constituent + !! parameter definitions during code preprocessing: the default + !! variant includes the 34 constituents available in the FES2014 + !! version of the Finite Element Solution - Global Tide data + !! product + !! (https://www.aviso.altimetry.fr/en/data/products/auxiliary-products/global-tide-fes.html); + !! also available is the default parameter set available in + !! previous NEMO versions + !! + !! ** References : + !! S58) Schureman, P. (1958): Manual of Harmonic Analysis and + !! Prediction of Tides (Revised (1940) Edition (Reprinted 1958 + !! with corrections). Reprinted June 2001). U.S. Department of + !! Commerce, Coast and Geodetic Survey Special Publication + !! No. 98. Washington DC, United States Government Printing + !! Office. 317 pp. DOI: 10.25607/OBP-155. + !! CT71) Cartwright, D. E. and Tayler, R. J. (1971): New computations of + !! the Tide-generating Potential. Geophys. J. R. astr. Soc. 23, + !! pp. 45-74. DOI: 10.1111/j.1365-246X.1971.tb01803.x + !! CE73) Cartwright, D. E. and Edden, A. C. (1973): Corrected Tables of + !! Tidal Harmonics. Geophys. J. R. astr. Soc. 33, + !! pp. 253-264. DOI: 10.1111/j.1365-246X.1973.tb03420.x + !! FES2014) FES (Finite element Solution) - Global + !! tide. https://www.aviso.altimetry.fr/en/data/products/auxiliary-products/global-tide-fes.html + !! + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2019) + !! $Id: tide.h90 14502 2021-02-18 18:48:54Z smueller $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +#ifndef TIDE_VAR_0 + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Name | Equilibrium | nt | ns | nh | np | np1 | Phase | nxi | nnu0 | nnu1 | nnu2 | R | Nodal | Equilibrium | Parameters source | Notes | + ! | | tide | | | | | | shift | | | | | | correction | tide | | | + ! | | | | | | | | | | | | | | formula | source/comment | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Long-period tidal constituents | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 1) = tide( 'Mf' , 0.042054_wp , 0 , 2 , 1 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) ! CE73 | S54 (Table 2, A6) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 2) = tide( 'Mm' , 0.022187_wp , 0 , 1 , 0 , -1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 73 ) ! CE73 | S54 (Table 2, A2) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 3) = tide( 'Ssa' , 0.019572_wp , 0 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73 | S54 (Table 2, B6) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 4) = tide( 'Mtm' , 0.008052_wp , 0 , 3 , 0 , -1 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) ! CE73 | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm); S54 | | + ! | | | | | | | | | | | | | | | | (Table 2, A7) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 5) = tide( 'Msf' , 0.003677_wp , 0 , 2 , -2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 73 ) ! CE73 | S54 (Table 2, A5) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 6) = tide( 'Msqm' , 0.001287_wp , 0 , 4 , -2 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) ! CE73 | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm); S54 | | + ! | | | | | | | | | | | | | | | | (Table 2, A12) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 7) = tide( 'Sa' , 0.000000_wp , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! Meteorological | S54 (Table 2, B64) | | + ! | | | | | | | | | | | | | | | tide only | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Diurnal tidal constituents | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 8) = tide( 'K1' , 0.142486_wp , 1 , 0 , 1 , 0 , 0 , -90 , 0 , 0 , -1 , 0 , 0 , 227 ) ! CE73, sign | S54 (Table 2) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components( 9) = tide( 'O1' , 0.101316_wp , 1 , -2 , 1 , 0 , 0 , 90 , 2 , -1 , 0 , 0 , 0 , 75 ) ! CE73 | S54 (Table 2, A14) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(10) = tide( 'P1' , 0.047152_wp , 1 , 0 , -1 , 0 , 0 , 90 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73 | S54 (Table 2, B14) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(11) = tide( 'Q1' , 0.019396_wp , 1 , -3 , 1 , 1 , 0 , 90 , 2 , -1 , 0 , 0 , 0 , 75 ) ! CE73 | S54 (Table 2, A15) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(12) = tide( 'J1' , 0.007967_wp , 1 , 1 , 1 , -1 , 0 , -90 , 0 , -1 , 0 , 0 , 0 , 76 ) ! CE73, sign | S54 (Table 2, A24) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(13) = tide( 'S1' , 0.000000_wp , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! Meteorological | S54 (Table 2, B71) | | + ! | | | | | | | | | | | | | | | tide only | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Semidiurnal tidal constituents | + ! +--------+-------------+-----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(14) = tide( 'M2' , 0.244081_wp , 2 , -2 , 2 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A39) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(15) = tide( 'S2' , 0.110242_wp , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73 | S54 (Table 2, B39) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(16) = tide( 'N2' , 0.046732_wp , 2 , -3 , 2 , 1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A40) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(17) = tide( 'K2' , 0.030905_wp , 2 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , -2 , 0 , 235 ) ! CE73 | S54 (Table 2) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(18) = tide( 'nu2' , 0.008877_wp , 2 , -3 , 4 , -1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A43) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(19) = tide( 'mu2' , 0.007463_wp , 2 , -4 , 4 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A45) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(20) = tide( '2N2' , 0.006184_wp , 2 , -4 , 2 , 2 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | S54 (Table 2, A42) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(21) = tide( 'L2' , 0.006899_wp , 2 , -1 , 2 , -1 , 0 , 180 , 2 , -2 , 0 , 0 , -1 , 215 ) ! CE73, sign | S54 (Table 2) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(22) = tide( 'T2' , 0.006655_wp , 2 , 0 , -1 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73 | S54 (Table 2, B40) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(23) = tide( 'eps2' , 0.001804_wp , 2 , -5 , 4 , 1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73 | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(24) = tide( 'lam2' , 0.001800_wp , 2 , -1 , 0 , 1 , 0 , 180 , 2 , -2 , 0 , 0 , 0 , 78 ) ! CE73, sign | S54 (Table 2, A44) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(25) = tide( 'R2' , 0.000952_wp , 2 , 0 , 1 , 0 , -1 , 180 , 0 , 0 , 0 , 0 , 0 , 0 ) ! CE73, sign | S54 (Table 2, B41) | Note 1 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Terdiurnal tidal constituents | + ! +--------+-------------+-----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(26) = tide( 'M3' , 0.003192_wp , 3 , -3 , 3 , 0 , 0 , 0 , 3 , -3 , 0 , 0 , 0 , 149 ) ! CT71, sign | S54 (Table 2, A82) | Note 2 | + ! | | | | | | | | | | | | | | | change | | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Compound tides | + ! +--------+-------------+-----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(27) = tide( 'MKS2' , 0.000000_wp , 2 , -2 , 4 , 0 , 0 , 0 , 2 , -2 , 0 , -2 , 0 , 4 ) ! Compound tide | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(28) = tide( 'MN4' , 0.000000_wp , 4 , -5 , 4 , 1 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) ! Compound tide | S54 (Table 2a) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(29) = tide( 'MS4' , 0.000000_wp , 4 , -2 , 2 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) ! Compound tide | FES2014 (prediction | Note 3 | + ! | | | | | | | | | | | | | | | | algorithm); S54 | | + ! | | | | | | | | | | | | | | | | (Table 2a) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! | Overtides | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(30) = tide( 'M4' , 0.000000_wp , 4 , -4 , 4 , 0 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) ! Overtide | S54 | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(31) = tide( 'N4' , 0.000000_wp , 4 , -6 , 4 , 2 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) ! Overtide | FES2014 (prediction | | + ! | | | | | | | | | | | | | | | | algorithm) | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(32) = tide( 'S4' , 0.000000_wp , 4 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) ! Overtide | S54 | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(33) = tide( 'M6' , 0.000000_wp , 6 , -6 , 6 , 0 , 0 , 0 , 6 , -6 , 0 , 0 , 0 , 18 ) ! Overtide | S54 | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + tide_components(34) = tide( 'M8' , 0.000000_wp , 8 , -8 , 8 , 0 , 0 , 0 , 8 , -8 , 0 , 0 , 0 , 20 ) ! Overtide | S54 | | + ! +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ + ! Note 1: the negative sign of the equilibrium-tide value derived from CE73 has been changed to accomodate the phase shift from Table 2 of S54. + ! Note 2: the negative sign of the equilibrium-tide value derived from CT71 has been changed to accomodate the phase shift from Table 2 of S54. + ! Note 3: the nodal correction factor formulas from FES2014 and S54 differ; here, the version from FES2014 has been selected. +#else + ! !! name_tide , equitide , nt , ns , nh , np , np1 , shift , nksi , nnu0 , nnu1 , nnu2 , R , formula !! + ! !! ! ! ! ! ! ! ! ! ! ! ! ! ! !! + tide_components( 1) = tide( 'M2' , 0.242297 , 2 , -2 , 2 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components( 2) = tide( 'N2' , 0.046313 , 2 , -3 , 2 , 1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components( 3) = tide( '2N2' , 0.006184 , 2 , -4 , 2 , 2 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components( 4) = tide( 'S2' , 0.113572 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) + tide_components( 5) = tide( 'K2' , 0.030875 , 2 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , -2 , 0 , 235 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + tide_components( 6) = tide( 'K1' , 0.142408 , 1 , 0 , 1 , 0 , 0 , -90 , 0 , 0 , -1 , 0 , 0 , 227 ) + tide_components( 7) = tide( 'O1' , 0.101266 , 1 , -2 , 1 , 0 , 0 , +90 , 2 , -1 , 0 , 0 , 0 , 75 ) + tide_components( 8) = tide( 'Q1' , 0.019387 , 1 , -3 , 1 , 1 , 0 , +90 , 2 , -1 , 0 , 0 , 0 , 75 ) + tide_components( 9) = tide( 'P1' , 0.047129 , 1 , 0 , -1 , 0 , 0 , +90 , 0 , 0 , 0 , 0 , 0 , 0 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + tide_components(10) = tide( 'M4' , 0.000000 , 4 , -4 , 4 , 0 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + tide_components(11) = tide( 'Mf' , 0.042017 , 0 , 2 , 0 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) + tide_components(12) = tide( 'Mm' , 0.022191 , 0 , 1 , 0 , -1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 73 ) + tide_components(13) = tide( 'Msqm' , 0.000667 , 0 , 4 , -2 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) + tide_components(14) = tide( 'Mtm' , 0.008049 , 0 , 3 , 0 , -1 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + tide_components(15) = tide( 'S1' , 0.000000 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) + tide_components(16) = tide( 'MU2' , 0.005841 , 2 , -4 , 4 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components(17) = tide( 'NU2' , 0.009094 , 2 , -3 , 4 , -1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + tide_components(18) = tide( 'L2' , 0.006694 , 2 , -1 , 2 , -1 , 0 , +180 , 2 , -2 , 0 , 0 , 0 , 215 ) + tide_components(19) = tide( 'T2' , 0.006614 , 2 , 0 , -1 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) +#endif \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TDE/tide_mod.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TDE/tide_mod.F90 new file mode 100644 index 0000000..7d13bf4 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TDE/tide_mod.F90 @@ -0,0 +1,762 @@ +MODULE tide_mod + !!====================================================================== + !! *** MODULE tide_mod *** + !! Compute nodal modulations corrections and pulsations + !!====================================================================== + !! History : 1.0 ! 2007 (O. Le Galloudec) Original code + !! ! 2019 (S. Mueller) + !!---------------------------------------------------------------------- + !! + !! ** Reference : + !! S58) Schureman, P. (1958): Manual of Harmonic Analysis and + !! Prediction of Tides (Revised (1940) Edition (Reprinted 1958 + !! with corrections). Reprinted June 2001). U.S. Department of + !! Commerce, Coast and Geodetic Survey Special Publication + !! No. 98. Washington DC, United States Government Printing + !! Office. 317 pp. DOI: 10.25607/OBP-155. + !!---------------------------------------------------------------------- + + USE oce, ONLY : ssh ! sea-surface height + USE par_oce ! ocean parameters + USE phycst, ONLY : rpi, rad, rday + USE daymod, ONLY : ndt05 ! half-length of time step + USE in_out_manager ! I/O units + USE iom ! xIOs server + + IMPLICIT NONE + PRIVATE + + PUBLIC tide_init + PUBLIC tide_update ! called by stp + PUBLIC tide_init_harmonics ! called internally and by module diaharm + PUBLIC upd_tide ! called in dynspg_... modules + + INTEGER, PUBLIC, PARAMETER :: jpmax_harmo = 64 !: maximum number of harmonic components + + TYPE :: tide + CHARACTER(LEN=4) :: cname_tide = '' + REAL(wp) :: equitide + INTEGER :: nt, ns, nh, np, np1, shift + INTEGER :: nksi, nnu0, nnu1, nnu2, R + INTEGER :: nformula + END TYPE tide + + TYPE(tide), DIMENSION(:), POINTER :: tide_components !: Array of selected tidal component parameters + + TYPE, PUBLIC :: tide_harmonic !: Oscillation parameters of harmonic tidal components + CHARACTER(LEN=4) :: cname_tide ! Name of component + REAL(wp) :: equitide ! Amplitude of equilibrium tide + REAL(wp) :: f ! Node factor + REAL(wp) :: omega ! Angular velocity + REAL(wp) :: v0 ! Initial phase at prime meridian + REAL(wp) :: u ! Phase correction + END type tide_harmonic + + TYPE(tide_harmonic), PUBLIC, DIMENSION(:), POINTER :: tide_harmonics !: Oscillation parameters of selected tidal components + + LOGICAL , PUBLIC :: ln_tide !: + LOGICAL , PUBLIC :: ln_tide_pot !: + INTEGER :: nn_tide_var ! Variant of tidal parameter set and tide-potential computation + LOGICAL :: ln_tide_dia ! Enable tidal diagnostic output + LOGICAL :: ln_read_load !: + LOGICAL , PUBLIC :: ln_scal_load !: + LOGICAL , PUBLIC :: ln_tide_ramp !: + INTEGER , PUBLIC :: nb_harmo !: Number of active tidal components + REAL(wp), PUBLIC :: rn_tide_ramp_dt !: + REAL(wp), PUBLIC :: rn_scal_load !: + CHARACTER(lc), PUBLIC :: cn_tide_load !: + REAL(wp) :: rn_tide_gamma ! Tidal tilt factor + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: pot_astro !: tidal potential + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: pot_astro_comp ! tidal-potential component + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_pot, phi_pot + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_load, phi_load + + REAL(wp) :: rn_tide_ramp_t ! Elapsed time in seconds + + REAL(wp) :: sh_T, sh_s, sh_h, sh_p, sh_p1 ! astronomic angles + REAL(wp) :: sh_xi, sh_nu, sh_nuprim, sh_nusec, sh_R ! + REAL(wp) :: sh_I, sh_x1ra, sh_N ! + + ! Longitudes on 1 Jan 1900, 00h and angular velocities (units of deg and + ! deg/h, respectively. The values of these module variables have been copied + ! from subroutine astronomic_angle of the version of this module used in + ! release version 4.0 of NEMO. + REAL(wp) :: rlon00_N = 259.1560564_wp ! Longitude of ascending lunar node + REAL(wp) :: romega_N = -.0022064139_wp + REAL(wp) :: rlon00_T = 180.0_wp ! Mean solar angle (GMT) + REAL(wp) :: romega_T = 15.0_wp + REAL(wp) :: rlon00_h = 280.1895014_wp ! Mean solar Longitude + REAL(wp) :: romega_h = .0410686387_wp + REAL(wp) :: rlon00_s = 277.0256206_wp ! Mean lunar Longitude + REAL(wp) :: romega_s = .549016532_wp + REAL(wp) :: rlon00_p1 = 281.2208569_wp ! Longitude of solar perigee + REAL(wp) :: romega_p1 = .000001961_wp + REAL(wp) :: rlon00_p = 334.3837214_wp ! Longitude of lunar perigee + REAL(wp) :: romega_p = .004641834_wp + ! Values of cos(i)*cos(epsilon), rcice, and sin(incl)*sin(epsilon), rsise, + ! where i is the inclination of the orbit of the Moon w.r.t. the ecliptic and + ! epsilon the obliquity of the ecliptic on 1 January 1900, 00h. The values of + ! these module variables have been copied from subroutine astronomic_angle + ! (computation of the cosine of inclination of orbit of Moon to the celestial + ! equator) of the version of this module used in release version 4.0 of NEMO. + REAL(wp) :: rcice = 0.913694997_wp + REAL(wp) :: rsise = 0.035692561_wp + ! Coefficients used to compute sh_xi and sh_nu in subroutine astronomic_angle + ! according to two equations given in the explanation of Table 6 of S58 + REAL(wp) :: rxinu1, rxinu2 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: tide_mod.F90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tide_init + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init *** + !!---------------------------------------------------------------------- + INTEGER :: ji, jk + CHARACTER(LEN=4), DIMENSION(jpmax_harmo) :: sn_tide_cnames ! Names of selected tidal components + INTEGER :: ios ! Local integer output status for namelist read + ! + NAMELIST/nam_tide/ln_tide, nn_tide_var, ln_tide_dia, ln_tide_pot, rn_tide_gamma, & + & ln_scal_load, ln_read_load, cn_tide_load, & + & ln_tide_ramp, rn_scal_load, rn_tide_ramp_dt, & + & sn_tide_cnames + !!---------------------------------------------------------------------- + ! + ! Initialise all array elements of sn_tide_cnames, as some of them + ! typically do not appear in namelist_ref or namelist_cfg + sn_tide_cnames(:) = '' + ! Read Namelist nam_tide + READ ( numnam_ref, nam_tide, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_tide in reference namelist' ) + ! + READ ( numnam_cfg, nam_tide, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_tide in configuration namelist' ) + IF(lwm) WRITE ( numond, nam_tide ) + ! + IF( ln_tide ) THEN + IF (lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'tide_init : Initialization of the tidal components' + WRITE(numout,*) '~~~~~~~~~ ' + WRITE(numout,*) ' Namelist nam_tide' + WRITE(numout,*) ' Use tidal components ln_tide = ', ln_tide + WRITE(numout,*) ' Variant (1: default; 0: legacy option) nn_tide_var = ', nn_tide_var + WRITE(numout,*) ' Tidal diagnostic output ln_tide_dia = ', ln_tide_dia + WRITE(numout,*) ' Apply astronomical potential ln_tide_pot = ', ln_tide_pot + WRITE(numout,*) ' Tidal tilt factor rn_tide_gamma = ', rn_tide_gamma + WRITE(numout,*) ' Use scalar approx. for load potential ln_scal_load = ', ln_scal_load + WRITE(numout,*) ' Read load potential from file ln_read_load = ', ln_read_load + WRITE(numout,*) ' Apply ramp on tides at startup ln_tide_ramp = ', ln_tide_ramp + WRITE(numout,*) ' Fraction of SSH used in scal. approx. rn_scal_load = ', rn_scal_load + WRITE(numout,*) ' Duration (days) of ramp rn_tide_ramp_dt = ', rn_tide_ramp_dt + ENDIF + ELSE + rn_scal_load = 0._wp + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tide_init : tidal components not used (ln_tide = F)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~ ' + RETURN + ENDIF + ! + IF( ln_read_load.AND.(.NOT.ln_tide_pot) ) & + & CALL ctl_stop('ln_read_load requires ln_tide_pot') + IF( ln_scal_load.AND.(.NOT.ln_tide_pot) ) & + & CALL ctl_stop('ln_scal_load requires ln_tide_pot') + IF( ln_scal_load.AND.ln_read_load ) & + & CALL ctl_stop('Choose between ln_scal_load and ln_read_load') + IF( ln_tide_ramp.AND.((nitend-nit000+1)*rn_Dt/rday < rn_tide_ramp_dt) ) & + & CALL ctl_stop('rn_tide_ramp_dt must be lower than run duration') + IF( ln_tide_ramp.AND.(rn_tide_ramp_dt<0.) ) & + & CALL ctl_stop('rn_tide_ramp_dt must be positive') + ! + ! Compute coefficients which are used in subroutine astronomic_angle to + ! compute sh_xi and sh_nu according to two equations given in the + ! explanation of Table 6 of S58 + rxinu1 = COS( 0.5_wp * ( ABS( ACOS( rcice + rsise ) ) ) ) / COS( 0.5_wp * ( ACOS( rcice - rsise ) ) ) + rxinu2 = SIN( 0.5_wp * ( ABS( ACOS( rcice + rsise ) ) ) ) / SIN( 0.5_wp * ( ACOS( rcice - rsise ) ) ) + ! + ! Initialise array used to store tidal oscillation parameters (frequency, + ! amplitude, phase); also retrieve and store array of information about + ! selected tidal components + CALL tide_init_harmonics(sn_tide_cnames, tide_harmonics, tide_components) + ! + ! Number of active tidal components + nb_harmo = size(tide_components) + ! + ! Ensure that tidal components have been set in namelist_cfg + IF( nb_harmo == 0 ) CALL ctl_stop( 'tide_init : No tidal components set in nam_tide' ) + ! + IF (.NOT.ln_scal_load ) rn_scal_load = 0._wp + ! + ALLOCATE( amp_pot(jpi,jpj,nb_harmo), & + & phi_pot(jpi,jpj,nb_harmo), pot_astro(jpi,jpj) ) + IF( ln_tide_dia ) ALLOCATE( pot_astro_comp(jpi,jpj) ) + IF( ln_read_load ) THEN + ALLOCATE( amp_load(jpi,jpj,nb_harmo), phi_load(jpi,jpj,nb_harmo) ) + CALL tide_init_load + amp_pot(:,:,:) = amp_load(:,:,:) + phi_pot(:,:,:) = phi_load(:,:,:) + ELSE + amp_pot(:,:,:) = 0._wp + phi_pot(:,:,:) = 0._wp + ENDIF + ! + END SUBROUTINE tide_init + + + SUBROUTINE tide_init_components(pcnames, ptide_comp) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init_components *** + !! + !! Returns pointer to array of variables of type 'tide' that contain + !! information about the selected tidal components + !! ---------------------------------------------------------------------- + CHARACTER(LEN=4), DIMENSION(jpmax_harmo), INTENT(in) :: pcnames ! Names of selected components + TYPE(tide), POINTER, DIMENSION(:), INTENT(out) :: ptide_comp ! Selected components + INTEGER, ALLOCATABLE, DIMENSION(:) :: icomppos ! Indices of selected components + INTEGER :: icomp, jk, jj, ji ! Miscellaneous integers + LOGICAL :: llmatch ! Local variables used for + INTEGER :: ic1, ic2 ! string comparison + TYPE(tide), POINTER, DIMENSION(:) :: tide_components ! All available components + + ! Populate local array with information about all available tidal + ! components + ! + ! Note, here 'tide_components' locally overrides the global module + ! variable of the same name to enable the use of the global name in the + ! include file that contains the initialisation of elements of array + ! 'tide_components' + ALLOCATE(tide_components(jpmax_harmo), icomppos(jpmax_harmo)) + ! Initialise array of indices of the selected componenents + icomppos(:) = 0 + ! Include tidal component parameters for all available components + IF (nn_tide_var < 1) THEN +#define TIDE_VAR_0 +#include "tide.h90" +#undef TIDE_VAR_0 + ELSE +#include "tide.h90" + END IF + ! Identify the selected components that are availble + icomp = 0 + DO jk = 1, jpmax_harmo + IF (TRIM(pcnames(jk)) /= '') THEN + DO jj = 1, jpmax_harmo + ! Find matches between selected and available constituents + ! (ignore capitalisation unless legacy variant has been selected) + IF (nn_tide_var < 1) THEN + llmatch = (TRIM(pcnames(jk)) == TRIM(tide_components(jj)%cname_tide)) + ELSE + llmatch = .TRUE. + ji = MAX(LEN_TRIM(pcnames(jk)), LEN_TRIM(tide_components(jj)%cname_tide)) + DO WHILE (llmatch.AND.(ji > 0)) + ic1 = IACHAR(pcnames(jk)(ji:ji)) + IF ((ic1 >= 97).AND.(ic1 <= 122)) ic1 = ic1 - 32 + ic2 = IACHAR(tide_components(jj)%cname_tide(ji:ji)) + IF ((ic2 >= 97).AND.(ic2 <= 122)) ic2 = ic2 - 32 + llmatch = (ic1 == ic2) + ji = ji - 1 + END DO + END IF + IF (llmatch) THEN + ! Count and record the match + icomp = icomp + 1 + icomppos(icomp) = jj + ! Set the capitalisation of the tidal constituent identifier + ! as specified in the namelist + tide_components(jj)%cname_tide = pcnames(jk) + IF (lwp) WRITE(numout, '(10X,"Tidal component #",I2.2,36X,"= ",A4)') icomp, tide_components(jj)%cname_tide + EXIT + END IF + END DO + IF ((lwp).AND.(jj > jpmax_harmo)) WRITE(numout, '(10X,"Tidal component ",A4," is not available!")') pcnames(jk) + END IF + END DO + + ! Allocate and populate reduced list of components + ALLOCATE(ptide_comp(icomp)) + DO jk = 1, icomp + ptide_comp(jk) = tide_components(icomppos(jk)) + END DO + + ! Release local array of available components and list of selected + ! components + DEALLOCATE(tide_components, icomppos) + + END SUBROUTINE tide_init_components + + + SUBROUTINE tide_init_harmonics(pcnames, ptide_harmo, ptide_comp) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init_harmonics *** + !! + !! Returns pointer to array of variables of type 'tide_harmonics' that + !! contain oscillation parameters of the selected harmonic tidal + !! components + !! ---------------------------------------------------------------------- + CHARACTER(LEN=4), DIMENSION(jpmax_harmo), INTENT(in) :: pcnames ! Names of selected components + TYPE(tide_harmonic), POINTER, DIMENSION(:) :: ptide_harmo ! Oscillation parameters of tidal components + TYPE(tide), POINTER, DIMENSION(:), OPTIONAL :: ptide_comp ! Selected components + TYPE(tide), POINTER, DIMENSION(:) :: ztcomp ! Selected components + + ! Retrieve information about selected tidal components + ! If requested, prepare tidal component array for returning + IF (PRESENT(ptide_comp)) THEN + CALL tide_init_components(pcnames, ptide_comp) + ztcomp => ptide_comp + ELSE + CALL tide_init_components(pcnames, ztcomp) + END IF + + ! Allocate and populate array of oscillation parameters + ALLOCATE(ptide_harmo(size(ztcomp))) + ptide_harmo(:)%cname_tide = ztcomp(:)%cname_tide + ptide_harmo(:)%equitide = ztcomp(:)%equitide + CALL tide_harmo(ztcomp, ptide_harmo) + + END SUBROUTINE tide_init_harmonics + + + SUBROUTINE tide_init_potential + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init_potential *** + !! + !! ** Reference : + !! CT71) Cartwright, D. E. and Tayler, R. J. (1971): New computations of + !! the Tide-generating Potential. Geophys. J. R. astr. Soc. 23, + !! pp. 45-74. DOI: 10.1111/j.1365-246X.1971.tb01803.x + !! + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcons, ztmp1, ztmp2, zlat, zlon, ztmp, zamp, zcs ! local scalar + !!---------------------------------------------------------------------- + + IF( ln_read_load ) THEN + amp_pot(:,:,:) = amp_load(:,:,:) + phi_pot(:,:,:) = phi_load(:,:,:) + ELSE + amp_pot(:,:,:) = 0._wp + phi_pot(:,:,:) = 0._wp + ENDIF + DO jk = 1, nb_harmo + zcons = rn_tide_gamma * tide_components(jk)%equitide * tide_harmonics(jk)%f + DO ji = 1, jpi + DO jj = 1, jpj + ztmp1 = tide_harmonics(jk)%f * amp_pot(ji,jj,jk) * COS( phi_pot(ji,jj,jk) & + & + tide_harmonics(jk)%v0 + tide_harmonics(jk)%u ) + ztmp2 = -tide_harmonics(jk)%f * amp_pot(ji,jj,jk) * SIN( phi_pot(ji,jj,jk) & + & + tide_harmonics(jk)%v0 + tide_harmonics(jk)%u ) + zlat = gphit(ji,jj)*rad !! latitude en radian + zlon = glamt(ji,jj)*rad !! longitude en radian + ztmp = tide_harmonics(jk)%v0 + tide_harmonics(jk)%u + tide_components(jk)%nt * zlon + ! le potentiel est composé des effets des astres: + SELECT CASE( tide_components(jk)%nt ) + CASE( 0 ) ! long-periodic tidal constituents (included unless + zcs = zcons * ( 0.5_wp - 1.5_wp * SIN( zlat )**2 ) ! compatibility with original formulation is requested) + IF ( nn_tide_var < 1 ) zcs = 0.0_wp + CASE( 1 ) ! diurnal tidal constituents + zcs = zcons * SIN( 2.0_wp*zlat ) + CASE( 2 ) ! semi-diurnal tidal constituents + zcs = zcons * COS( zlat )**2 + CASE( 3 ) ! Terdiurnal tidal constituents; the colatitude-dependent + zcs = zcons * COS( zlat )**3 ! factor is sin(theta)^3 (Table 2 of CT71) + CASE DEFAULT ! constituents of higher frequency are not included + zcs = 0.0_wp + END SELECT + ztmp1 = ztmp1 + zcs * COS( ztmp ) + ztmp2 = ztmp2 - zcs * SIN( ztmp ) + zamp = SQRT( ztmp1*ztmp1 + ztmp2*ztmp2 ) + amp_pot(ji,jj,jk) = zamp + phi_pot(ji,jj,jk) = ATAN2( -ztmp2 / MAX( 1.e-10_wp , zamp ) , & + & ztmp1 / MAX( 1.e-10_wp, zamp ) ) + END DO + END DO + END DO + ! + END SUBROUTINE tide_init_potential + + + SUBROUTINE tide_init_load + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_init_load *** + !!---------------------------------------------------------------------- + INTEGER :: inum ! Logical unit of input file + INTEGER :: ji, jj, itide ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: ztr, zti !: workspace to read in tidal harmonics data + !!---------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'tide_init_load : Initialization of load potential from file' + WRITE(numout,*) '~~~~~~~~~~~~~~ ' + ENDIF + ! + CALL iom_open ( cn_tide_load , inum ) + ! + DO itide = 1, nb_harmo + CALL iom_get ( inum, jpdom_global,TRIM(tide_components(itide)%cname_tide)//'_z1', ztr(:,:) ) + CALL iom_get ( inum, jpdom_global,TRIM(tide_components(itide)%cname_tide)//'_z2', zti(:,:) ) + ! + DO ji=1,jpi + DO jj=1,jpj + amp_load(ji,jj,itide) = SQRT( ztr(ji,jj)**2. + zti(ji,jj)**2. ) + phi_load(ji,jj,itide) = ATAN2(-zti(ji,jj), ztr(ji,jj) ) + END DO + END DO + ! + END DO + CALL iom_close( inum ) + ! + END SUBROUTINE tide_init_load + + + SUBROUTINE tide_update( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_update *** + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step + INTEGER :: jk ! dummy loop index + !!---------------------------------------------------------------------- + + IF( nsec_day == NINT(0.5_wp * rn_Dt) .OR. kt == nit000 ) THEN ! start a new day + ! + CALL tide_harmo(tide_components, tide_harmonics, ndt05) ! Update oscillation parameters of tidal components for start of current day + ! + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'tide_update : Update of the components and (re)Init. the potential at kt=', kt + WRITE(numout,*) '~~~~~~~~~~~ ' + DO jk = 1, nb_harmo + WRITE(numout,*) tide_harmonics(jk)%cname_tide, tide_harmonics(jk)%u, & + & tide_harmonics(jk)%f,tide_harmonics(jk)%v0, tide_harmonics(jk)%omega + END DO + ENDIF + ! + IF( ln_tide_pot ) CALL tide_init_potential + ! + rn_tide_ramp_t = (kt - nit000)*rn_Dt ! Elapsed time in seconds + ENDIF + ! + END SUBROUTINE tide_update + + + SUBROUTINE tide_harmo( ptide_comp, ptide_harmo, psec_day ) + ! + TYPE(tide), DIMENSION(:), POINTER :: ptide_comp ! Array of selected tidal component parameters + TYPE(tide_harmonic), DIMENSION(:), POINTER :: ptide_harmo ! Oscillation parameters of selected tidal components + INTEGER, OPTIONAL :: psec_day ! Number of seconds since the start of the current day + ! + IF (PRESENT(psec_day)) THEN + CALL astronomic_angle(psec_day) + ELSE + CALL astronomic_angle(nsec_day) + END IF + CALL tide_pulse( ptide_comp, ptide_harmo ) + CALL tide_vuf( ptide_comp, ptide_harmo ) + ! + END SUBROUTINE tide_harmo + + + SUBROUTINE astronomic_angle(psec_day) + !!---------------------------------------------------------------------- + !! *** ROUTINE astronomic_angle *** + !! + !! ** Purpose : Compute astronomic angles + !!---------------------------------------------------------------------- + INTEGER :: psec_day ! Number of seconds from midnight + REAL(wp) :: zp, zq, zt2, zs2, ztgI2, zP1, ztgn2, zat1, zat2 + REAL(wp) :: zqy , zsy, zday, zdj, zhfrac, zt + !!---------------------------------------------------------------------- + ! + ! Computation of the time from 1 Jan 1900, 00h in years + zqy = AINT( (nyear - 1901.0_wp) / 4.0_wp ) + zsy = nyear - 1900.0_wp + ! + zdj = dayjul( nyear, nmonth, nday ) + zday = zdj + zqy - 1.0_wp + ! + zhfrac = psec_day / 3600.0_wp + ! + zt = zsy * 365.0_wp * 24.0_wp + zday * 24.0_wp + zhfrac + ! + ! Longitude of ascending lunar node + sh_N = ( rlon00_N + romega_N * zt ) * rad + sh_N = MOD( sh_N, 2*rpi ) + ! Mean solar angle (Greenwhich time) + sh_T = ( rlon00_T + romega_T * zhfrac ) * rad + ! Mean solar Longitude + sh_h = ( rlon00_h + romega_h * zt ) * rad + sh_h = MOD( sh_h, 2*rpi ) + ! Mean lunar Longitude + sh_s = ( rlon00_s + romega_s * zt ) * rad + sh_s = MOD( sh_s, 2*rpi ) + ! Longitude of solar perigee + sh_p1 = ( rlon00_p1 + romega_p1 * zt ) * rad + sh_p1= MOD( sh_p1, 2*rpi ) + ! Longitude of lunar perigee + sh_p = ( rlon00_p + romega_p * zt ) * rad + sh_p = MOD( sh_p, 2*rpi ) + ! + ! Inclination of the orbit of the moon w.r.t. the celestial equator, see + ! explanation of Table 6 of S58 + sh_I = ACOS( rcice - rsise * COS( sh_N ) ) + ! + ! Computation of sh_xi and sh_nu, see explanation of Table 6 of S58 + ztgn2 = TAN( sh_N / 2.0_wp ) + zat1 = ATAN( rxinu1 * ztgn2 ) + zat2 = ATAN( rxinu2 * ztgn2 ) + sh_xi = sh_N - zat1 - zat2 + IF( sh_N > rpi ) sh_xi = sh_xi - 2.0_wp * rpi + sh_nu = zat1 - zat2 + ! + ! Computation of sh_x1ra, sh_R, sh_nuprim, and sh_nusec used for tidal + ! constituents L2, K1, and K2 + ! + ! Computation of sh_x1ra and sh_R (Equations 204, 213, and 214 of S58) + ztgI2 = tan( sh_I / 2.0_wp ) + zP1 = sh_p - sh_xi + zt2 = ztgI2 * ztgI2 + sh_x1ra = SQRT( 1.0 - 12.0 * zt2 * COS( 2.0_wp * zP1 ) + 36.0_wp * zt2 * zt2 ) + zp = SIN( 2.0_wp * zP1 ) + zq = 1.0_wp / ( 6.0_wp * zt2 ) - COS( 2.0_wp * zP1 ) + sh_R = ATAN( zp / zq ) + ! + ! Computation of sh_nuprim (Equation 224 of S58) + zp = SIN( 2.0_wp * sh_I ) * SIN( sh_nu ) + zq = SIN( 2.0_wp * sh_I ) * COS( sh_nu ) + 0.3347_wp + sh_nuprim = ATAN( zp / zq ) + ! + ! Computation of sh_nusec (Equation 232 of S58) + zs2 = SIN( sh_I ) * SIN( sh_I ) + zp = zs2 * SIN( 2.0_wp * sh_nu ) + zq = zs2 * COS( 2.0_wp * sh_nu ) + 0.0727_wp + sh_nusec = 0.5_wp * ATAN( zp / zq ) + ! + END SUBROUTINE astronomic_angle + + + SUBROUTINE tide_pulse( ptide_comp, ptide_harmo ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_pulse *** + !! + !! ** Purpose : Compute tidal frequencies + !!---------------------------------------------------------------------- + TYPE(tide), DIMENSION(:), POINTER :: ptide_comp ! Array of selected tidal component parameters + TYPE(tide_harmonic), DIMENSION(:), POINTER :: ptide_harmo ! Oscillation parameters of selected tidal components + ! + INTEGER :: jh + REAL(wp) :: zscale + !!---------------------------------------------------------------------- + ! + zscale = rad / 3600.0_wp + ! + DO jh = 1, size(ptide_harmo) + ptide_harmo(jh)%omega = ( romega_T * ptide_comp( jh )%nT & + & + romega_s * ptide_comp( jh )%ns & + & + romega_h * ptide_comp( jh )%nh & + & + romega_p * ptide_comp( jh )%np & + & + romega_p1* ptide_comp( jh )%np1 ) * zscale + END DO + ! + END SUBROUTINE tide_pulse + + + SUBROUTINE tide_vuf( ptide_comp, ptide_harmo ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tide_vuf *** + !! + !! ** Purpose : Compute nodal modulation corrections + !! + !! ** Outputs : vt: Phase of tidal potential relative to Greenwich (radians) + !! ut: Phase correction u due to nodal motion (radians) + !! ft: Nodal correction factor + !!---------------------------------------------------------------------- + TYPE(tide), DIMENSION(:), POINTER :: ptide_comp ! Array of selected tidal component parameters + TYPE(tide_harmonic), DIMENSION(:), POINTER :: ptide_harmo ! Oscillation parameters of selected tidal components + ! + INTEGER :: jh ! dummy loop index + !!---------------------------------------------------------------------- + ! + DO jh = 1, size(ptide_harmo) + ! Phase of the tidal potential relative to the Greenwhich + ! meridian (e.g. the position of the fictuous celestial body). Units are radian: + ptide_harmo(jh)%v0 = sh_T * ptide_comp( jh )%nT & + & + sh_s * ptide_comp( jh )%ns & + & + sh_h * ptide_comp( jh )%nh & + & + sh_p * ptide_comp( jh )%np & + & + sh_p1* ptide_comp( jh )%np1 & + & + ptide_comp( jh )%shift * rad + ! + ! Phase correction u due to nodal motion. Units are radian: + ptide_harmo(jh)%u = sh_xi * ptide_comp( jh )%nksi & + & + sh_nu * ptide_comp( jh )%nnu0 & + & + sh_nuprim * ptide_comp( jh )%nnu1 & + & + sh_nusec * ptide_comp( jh )%nnu2 & + & + sh_R * ptide_comp( jh )%R + + ! Nodal correction factor: + ptide_harmo(jh)%f = nodal_factort( ptide_comp( jh )%nformula ) + END DO + ! + END SUBROUTINE tide_vuf + + + RECURSIVE FUNCTION nodal_factort( kformula ) RESULT( zf ) + !!---------------------------------------------------------------------- + !! *** FUNCTION nodal_factort *** + !! + !! ** Purpose : Compute amplitude correction factors due to nodal motion + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kformula + ! + REAL(wp) :: zf + REAL(wp) :: zs, zf1, zf2 + CHARACTER(LEN=3) :: clformula + !!---------------------------------------------------------------------- + ! + SELECT CASE( kformula ) + ! + CASE( 0 ) ! Formula 0, solar waves + zf = 1.0 + ! + CASE( 1 ) ! Formula 1, compound waves (78 x 78) + zf=nodal_factort( 78 ) + zf = zf * zf + ! + CASE ( 4 ) ! Formula 4, compound waves (78 x 235) + zf1 = nodal_factort( 78 ) + zf = nodal_factort(235) + zf = zf1 * zf + ! + CASE( 18 ) ! Formula 18, compound waves (78 x 78 x 78 ) + zf1 = nodal_factort( 78 ) + zf = zf1 * zf1 * zf1 + ! + CASE( 20 ) ! Formula 20, compound waves ( 78 x 78 x 78 x 78 ) + zf1 = nodal_factort( 78 ) + zf = zf1 * zf1 * zf1 * zf1 + ! + CASE( 73 ) ! Formula 73 of S58 + zs = SIN( sh_I ) + zf = ( 2.0_wp / 3.0_wp - zs * zs ) / 0.5021_wp + ! + CASE( 74 ) ! Formula 74 of S58 + zs = SIN(sh_I) + zf = zs * zs / 0.1578_wp + ! + CASE( 75 ) ! Formula 75 of S58 + zs = COS( sh_I / 2.0_wp ) + zf = SIN( sh_I ) * zs * zs / 0.3800_wp + ! + CASE( 76 ) ! Formula 76 of S58 + zf = SIN( 2.0_wp * sh_I ) / 0.7214_wp + ! + CASE( 78 ) ! Formula 78 of S58 + zs = COS( sh_I/2 ) + zf = zs * zs * zs * zs / 0.9154_wp + ! + CASE( 149 ) ! Formula 149 of S58 + zs = COS( sh_I/2 ) + zf = zs * zs * zs * zs * zs * zs / 0.8758_wp + ! + CASE( 215 ) ! Formula 215 of S58 with typo correction (0.9154 instead of 0.9145) + zs = COS( sh_I/2 ) + zf = zs * zs * zs * zs / 0.9154_wp * sh_x1ra + ! + CASE( 227 ) ! Formula 227 of S58 + zs = SIN( 2.0_wp * sh_I ) + zf = SQRT( 0.8965_wp * zs * zs + 0.6001_wp * zs * COS( sh_nu ) + 0.1006_wp ) + ! + CASE ( 235 ) ! Formula 235 of S58 + zs = SIN( sh_I ) + zf = SQRT( 19.0444_wp * zs * zs * zs * zs + 2.7702_wp * zs * zs * cos( 2.0_wp * sh_nu ) + 0.0981_wp ) + ! + CASE DEFAULT + WRITE( clformula, '(I3)' ) kformula + CALL ctl_stop('nodal_factort: formula ' // clformula // ' is not available') + END SELECT + ! + END FUNCTION nodal_factort + + + FUNCTION dayjul( kyr, kmonth, kday ) + !!---------------------------------------------------------------------- + !! *** FUNCTION dayjul *** + !! + !! Purpose : compute the Julian day + !!---------------------------------------------------------------------- + INTEGER,INTENT(in) :: kyr, kmonth, kday + ! + INTEGER,DIMENSION(12) :: idayt = (/ 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 /) + INTEGER,DIMENSION(12) :: idays + INTEGER :: inc, ji, zyq + REAL(wp) :: dayjul + !!---------------------------------------------------------------------- + ! + idays(1) = 0 + idays(2) = 31 + inc = 0.0_wp + zyq = MOD( kyr - 1900 , 4 ) + IF( zyq == 0 ) inc = 1 + DO ji = 3, 12 + idays(ji) = idayt(ji) + inc + END DO + dayjul = REAL( idays(kmonth) + kday, KIND=wp ) + ! + END FUNCTION dayjul + + + SUBROUTINE upd_tide(pdelta, Kmm) + !!---------------------------------------------------------------------- + !! *** ROUTINE upd_tide *** + !! + !! ** Purpose : provide at each time step the astronomical potential + !! + !! ** Method : computed from pulsation and amplitude of all tide components + !! + !! ** Action : pot_astro actronomical potential + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: pdelta ! Temporal offset in seconds + INTEGER, INTENT(IN) :: Kmm ! Time level index + INTEGER :: jk ! Dummy loop index + REAL(wp) :: zt, zramp ! Local scalars + REAL(wp), DIMENSION(nb_harmo) :: zwt ! Temporary array + !!---------------------------------------------------------------------- + ! + zwt(:) = tide_harmonics(:)%omega * pdelta + ! + IF( ln_tide_ramp ) THEN ! linear increase if asked + zt = rn_tide_ramp_t + pdelta + zramp = MIN( MAX( zt / (rn_tide_ramp_dt*rday) , 0._wp ) , 1._wp ) + ENDIF + ! + pot_astro(:,:) = 0._wp ! update tidal potential (sum of all harmonics) + DO jk = 1, nb_harmo + IF ( .NOT. ln_tide_dia ) THEN + pot_astro(:,:) = pot_astro(:,:) + amp_pot(:,:,jk) * COS( zwt(jk) + phi_pot(:,:,jk) ) + ELSE + pot_astro_comp(:,:) = amp_pot(:,:,jk) * COS( zwt(jk) + phi_pot(:,:,jk) ) + pot_astro(:,:) = pot_astro(:,:) + pot_astro_comp(:,:) + IF ( iom_use( "tide_pot_" // TRIM( tide_harmonics(jk)%cname_tide ) ) ) THEN ! Output tidal potential (incl. load potential) + IF ( ln_tide_ramp ) pot_astro_comp(:,:) = zramp * pot_astro_comp(:,:) + CALL iom_put( "tide_pot_" // TRIM( tide_harmonics(jk)%cname_tide ), pot_astro_comp(:,:) ) + END IF + END IF + END DO + ! + IF ( ln_tide_ramp ) pot_astro(:,:) = zramp * pot_astro(:,:) + ! + IF( ln_tide_dia ) THEN ! Output total tidal potential (incl. load potential) + IF ( iom_use( "tide_pot" ) ) CALL iom_put( "tide_pot", pot_astro(:,:) + rn_scal_load * ssh(:,:,Kmm) ) + END IF + ! + END SUBROUTINE upd_tide + + !!====================================================================== +END MODULE tide_mod \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/eosbn2.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/eosbn2.F90 new file mode 100644 index 0000000..c49da6b --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/eosbn2.F90 @@ -0,0 +1,1818 @@ +MODULE eosbn2 + !!============================================================================== + !! *** MODULE eosbn2 *** + !! Equation Of Seawater : in situ density - Brunt-Vaisala frequency + !!============================================================================== + !! History : OPA ! 1989-03 (O. Marti) Original code + !! 6.0 ! 1994-07 (G. Madec, M. Imbard) add bn2 + !! 6.0 ! 1994-08 (G. Madec) Add Jackett & McDougall eos + !! 7.0 ! 1996-01 (G. Madec) statement function for e3 + !! 8.1 ! 1997-07 (G. Madec) density instead of volumic mass + !! - ! 1999-02 (G. Madec, N. Grima) semi-implicit pressure gradient + !! 8.2 ! 2001-09 (M. Ben Jelloul) bugfix on linear eos + !! NEMO 1.0 ! 2002-10 (G. Madec) add eos_init + !! - ! 2002-11 (G. Madec, A. Bozec) partial step, eos_insitu_2d + !! - ! 2003-08 (G. Madec) F90, free form + !! 3.0 ! 2006-08 (G. Madec) add tfreez function (now eos_fzp function) + !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + !! - ! 2010-10 (G. Nurser, G. Madec) add alpha/beta used in ldfslp + !! 3.7 ! 2012-03 (F. Roquet, G. Madec) add primitive of alpha and beta used in PE computation + !! - ! 2012-05 (F. Roquet) add Vallis and original JM95 equation of state + !! - ! 2013-04 (F. Roquet, G. Madec) add eos_rab, change bn2 computation and reorganize the module + !! - ! 2014-09 (F. Roquet) add TEOS-10, S-EOS, and modify EOS-80 + !! - ! 2015-06 (P.A. Bouttier) eos_fzp functions changed to subroutines for AGRIF + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! eos : generic interface of the equation of state + !! eos_insitu : Compute the in situ density + !! eos_insitu_pot: Compute the insitu and surface referenced potential volumic mass + !! eos_insitu_2d : Compute the in situ density for 2d fields + !! bn2 : compute the Brunt-Vaisala frequency + !! eos_pt_from_ct: compute the potential temperature from the Conservative Temperature + !! eos_rab : generic interface of in situ thermal/haline expansion ratio + !! eos_rab_3d : compute in situ thermal/haline expansion ratio + !! eos_rab_2d : compute in situ thermal/haline expansion ratio for 2d fields + !! eos_fzp_2d : freezing temperature for 2d fields + !! eos_fzp_0d : freezing temperature for scalar + !! eos_init : set eos parameters (namelist) + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE domutl, ONLY : is_tile + USE phycst ! physical constants + USE stopar ! Stochastic T/S fluctuations + USE stopts ! Stochastic T/S fluctuations + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + USE prtctl ! Print control + USE lbclnk ! ocean lateral boundary conditions + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + ! !! * Interface + INTERFACE eos + MODULE PROCEDURE eos_insitu, eos_insitu_pot, eos_insitu_2d, eos_insitu_pot_2d + END INTERFACE + ! + INTERFACE eos_rab + MODULE PROCEDURE rab_3d, rab_2d, rab_0d + END INTERFACE + ! + INTERFACE eos_fzp + MODULE PROCEDURE eos_fzp_2d, eos_fzp_0d + END INTERFACE + ! + PUBLIC eos ! called by step, istate, tranpc and zpsgrd modules + PUBLIC bn2 ! called by step module + PUBLIC eos_rab ! called by ldfslp, zdfddm, trabbl + PUBLIC eos_pt_from_ct ! called by sbcssm + PUBLIC eos_fzp ! called by traadv_cen2 and sbcice_... modules + PUBLIC eos_pen ! used for pe diagnostics in trdpen module + PUBLIC eos_init ! called by istate module + + ! !!** Namelist nameos ** + LOGICAL , PUBLIC :: ln_TEOS10 + LOGICAL , PUBLIC :: ln_EOS80 + LOGICAL , PUBLIC :: ln_SEOS + + ! Parameters + LOGICAL , PUBLIC :: l_useCT ! =T in ln_TEOS10=T (i.e. use eos_pt_from_ct to compute sst_m), =F otherwise + INTEGER , PUBLIC :: neos ! Identifier for equation of state used + + INTEGER , PARAMETER :: np_teos10 = -1 ! parameter for using TEOS10 + INTEGER , PARAMETER :: np_eos80 = 0 ! parameter for using EOS80 + INTEGER , PARAMETER :: np_seos = 1 ! parameter for using Simplified Equation of state + + ! !!! simplified eos coefficients (default value: Vallis 2006) + REAL(wp), PUBLIC :: rn_a0 = 1.6550e-1_wp ! thermal expansion coeff. + REAL(wp), PUBLIC :: rn_b0 = 7.6554e-1_wp ! saline expansion coeff. + REAL(wp) :: rn_lambda1 = 5.9520e-2_wp ! cabbeling coeff. in T^2 + REAL(wp) :: rn_lambda2 = 5.4914e-4_wp ! cabbeling coeff. in S^2 + REAL(wp) :: rn_mu1 = 1.4970e-4_wp ! thermobaric coeff. in T + REAL(wp) :: rn_mu2 = 1.1090e-5_wp ! thermobaric coeff. in S + REAL(wp) :: rn_nu = 2.4341e-3_wp ! cabbeling coeff. in theta*salt + + ! TEOS10/EOS80 parameters + REAL(wp) :: r1_S0, r1_T0, r1_Z0, rdeltaS + + ! EOS parameters + REAL(wp) :: EOS000 , EOS100 , EOS200 , EOS300 , EOS400 , EOS500 , EOS600 + REAL(wp) :: EOS010 , EOS110 , EOS210 , EOS310 , EOS410 , EOS510 + REAL(wp) :: EOS020 , EOS120 , EOS220 , EOS320 , EOS420 + REAL(wp) :: EOS030 , EOS130 , EOS230 , EOS330 + REAL(wp) :: EOS040 , EOS140 , EOS240 + REAL(wp) :: EOS050 , EOS150 + REAL(wp) :: EOS060 + REAL(wp) :: EOS001 , EOS101 , EOS201 , EOS301 , EOS401 + REAL(wp) :: EOS011 , EOS111 , EOS211 , EOS311 + REAL(wp) :: EOS021 , EOS121 , EOS221 + REAL(wp) :: EOS031 , EOS131 + REAL(wp) :: EOS041 + REAL(wp) :: EOS002 , EOS102 , EOS202 + REAL(wp) :: EOS012 , EOS112 + REAL(wp) :: EOS022 + REAL(wp) :: EOS003 , EOS103 + REAL(wp) :: EOS013 + + ! ALPHA parameters + REAL(wp) :: ALP000 , ALP100 , ALP200 , ALP300 , ALP400 , ALP500 + REAL(wp) :: ALP010 , ALP110 , ALP210 , ALP310 , ALP410 + REAL(wp) :: ALP020 , ALP120 , ALP220 , ALP320 + REAL(wp) :: ALP030 , ALP130 , ALP230 + REAL(wp) :: ALP040 , ALP140 + REAL(wp) :: ALP050 + REAL(wp) :: ALP001 , ALP101 , ALP201 , ALP301 + REAL(wp) :: ALP011 , ALP111 , ALP211 + REAL(wp) :: ALP021 , ALP121 + REAL(wp) :: ALP031 + REAL(wp) :: ALP002 , ALP102 + REAL(wp) :: ALP012 + REAL(wp) :: ALP003 + + ! BETA parameters + REAL(wp) :: BET000 , BET100 , BET200 , BET300 , BET400 , BET500 + REAL(wp) :: BET010 , BET110 , BET210 , BET310 , BET410 + REAL(wp) :: BET020 , BET120 , BET220 , BET320 + REAL(wp) :: BET030 , BET130 , BET230 + REAL(wp) :: BET040 , BET140 + REAL(wp) :: BET050 + REAL(wp) :: BET001 , BET101 , BET201 , BET301 + REAL(wp) :: BET011 , BET111 , BET211 + REAL(wp) :: BET021 , BET121 + REAL(wp) :: BET031 + REAL(wp) :: BET002 , BET102 + REAL(wp) :: BET012 + REAL(wp) :: BET003 + + ! PEN parameters + REAL(wp) :: PEN000 , PEN100 , PEN200 , PEN300 , PEN400 + REAL(wp) :: PEN010 , PEN110 , PEN210 , PEN310 + REAL(wp) :: PEN020 , PEN120 , PEN220 + REAL(wp) :: PEN030 , PEN130 + REAL(wp) :: PEN040 + REAL(wp) :: PEN001 , PEN101 , PEN201 + REAL(wp) :: PEN011 , PEN111 + REAL(wp) :: PEN021 + REAL(wp) :: PEN002 , PEN102 + REAL(wp) :: PEN012 + + ! ALPHA_PEN parameters + REAL(wp) :: APE000 , APE100 , APE200 , APE300 + REAL(wp) :: APE010 , APE110 , APE210 + REAL(wp) :: APE020 , APE120 + REAL(wp) :: APE030 + REAL(wp) :: APE001 , APE101 + REAL(wp) :: APE011 + REAL(wp) :: APE002 + + ! BETA_PEN parameters + REAL(wp) :: BPE000 , BPE100 , BPE200 , BPE300 + REAL(wp) :: BPE010 , BPE110 , BPE210 + REAL(wp) :: BPE020 , BPE120 + REAL(wp) :: BPE030 + REAL(wp) :: BPE001 , BPE101 + REAL(wp) :: BPE011 + REAL(wp) :: BPE002 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: eosbn2.F90 15136 2021-07-23 10:07:28Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE eos_insitu( pts, prd, pdep ) + !! + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] + !! + CALL eos_insitu_t( pts, is_tile(pts), prd, is_tile(prd), pdep, is_tile(pdep) ) + END SUBROUTINE eos_insitu + + SUBROUTINE eos_insitu_t( pts, ktts, prd, ktrd, pdep, ktdep ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_insitu *** + !! + !! ** Purpose : Compute the in situ density (ratio rho/rho0) from + !! potential temperature and salinity using an equation of state + !! selected in the nameos namelist + !! + !! ** Method : prd(t,s,z) = ( rho(t,s,z) - rho0 ) / rho0 + !! with prd in situ density anomaly no units + !! t TEOS10: CT or EOS80: PT Celsius + !! s TEOS10: SA or EOS80: SP TEOS10: g/kg or EOS80: psu + !! z depth meters + !! rho in situ density kg/m^3 + !! rho0 reference density kg/m^3 + !! + !! ln_teos10 : polynomial TEOS-10 equation of state is used for rho(t,s,z). + !! Check value: rho = 1028.21993233072 kg/m^3 for z=3000 dbar, ct=3 Celsius, sa=35.5 g/kg + !! + !! ln_eos80 : polynomial EOS-80 equation of state is used for rho(t,s,z). + !! Check value: rho = 1028.35011066567 kg/m^3 for z=3000 dbar, pt=3 Celsius, sp=35.5 psu + !! + !! ln_seos : simplified equation of state + !! prd(t,s,z) = ( -a0*(1+lambda/2*(T-T0)+mu*z+nu*(S-S0))*(T-T0) + b0*(S-S0) ) / rho0 + !! linear case function of T only: rn_alpha<>0, other coefficients = 0 + !! linear eos function of T and S: rn_alpha and rn_beta<>0, other coefficients=0 + !! Vallis like equation: use default values of coefficients + !! + !! ** Action : compute prd , the in situ density (no units) + !! + !! References : Roquet et al, Ocean Modelling, in preparation (2014) + !! Vallis, Atmospheric and Oceanic Fluid Dynamics, 2006 + !! TEOS-10 Manual, 2010 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ktts, ktrd, ktdep + REAL(dp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-] + REAL(wp), DIMENSION(A2D_T(ktdep),JPK ), INTENT(in ) :: pdep ! depth [m] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zt, zh, ztm! local scalars + REAL(dp) :: zs! local scalars + REAL(wp) :: zn1, zn2! - - + REAL(dp) :: zn, zn0, zn3! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos-insitu') + ! + SELECT CASE( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + ! + zh = pdep(ji,jj,jk) * r1_Z0 ! depth + zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ztm = tmask(ji,jj,jk) ! tmask + ! + zn3 = EOS013*zt & + & + EOS103*zs+EOS003 + ! + zn2 = (EOS022*zt & + & + EOS112*zs+EOS012)*zt & + & + (EOS202*zs+EOS102)*zs+EOS002 + ! + zn1 = (((EOS041*zt & + & + EOS131*zs+EOS031)*zt & + & + (EOS221*zs+EOS121)*zs+EOS021)*zt & + & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & + & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 + ! + zn0 = (((((EOS060*zt & + & + EOS150*zs+EOS050)*zt & + & + (EOS240*zs+EOS140)*zs+EOS040)*zt & + & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & + & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & + & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & + & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + prd(ji,jj,jk) = ( zn * r1_rho0 - 1._wp ) * ztm ! density anomaly (masked) + ! + END_3D + ! + CASE( np_seos ) !== simplified EOS ==! + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + zt = pts (ji,jj,jk,jp_tem) - 10._wp + zs = pts (ji,jj,jk,jp_sal) - 35._wp + zh = pdep (ji,jj,jk) + ztm = tmask(ji,jj,jk) + ! + zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt & + & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs & + & - rn_nu * zt * zs + ! + prd(ji,jj,jk) = zn * r1_rho0 * ztm ! density anomaly (masked) + END_3D + ! + END SELECT + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=REAL(prd,dp), clinfo1=' eos-insitu : ' ) + ! + IF( ln_timing ) CALL timing_stop('eos-insitu') + ! + END SUBROUTINE eos_insitu_t + + + SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) + !! + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] + REAL(dp), DIMENSION(:,:,:) , INTENT( out) :: prhop ! potential density (surface referenced) + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] + !! + CALL eos_insitu_pot_t( pts, is_tile(pts), prd, is_tile(prd), prhop, is_tile(prhop), pdep, is_tile(pdep) ) + END SUBROUTINE eos_insitu_pot + + + SUBROUTINE eos_insitu_pot_t( pts, ktts, prd, ktrd, prhop, ktrhop, pdep, ktdep ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_insitu_pot *** + !! + !! ** Purpose : Compute the in situ density (ratio rho/rho0) and the + !! potential volumic mass (Kg/m3) from potential temperature and + !! salinity fields using an equation of state selected in the + !! namelist. + !! + !! ** Action : - prd , the in situ density (no units) + !! - prhop, the potential volumic mass (Kg/m3) + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ktts, ktrd, ktrhop, ktdep + REAL(dp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-] + REAL(dp), DIMENSION(A2D_T(ktrhop),JPK ), INTENT( out) :: prhop ! potential density (surface referenced) + REAL(wp), DIMENSION(A2D_T(ktdep) ,JPK ), INTENT(in ) :: pdep ! depth [m] + ! + INTEGER :: ji, jj, jk, jsmp ! dummy loop indices + INTEGER :: jdof + REAL(wp) :: zt, zh, zstemp, ztm! local scalars + REAL(dp) :: zs! local scalars + REAL(wp) :: zn1, zn2, zn3! - - + REAL(dp) :: zn, zn0! - - + REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos-pot') + ! + SELECT CASE ( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + ! Stochastic equation of state + IF ( ln_sto_eos ) THEN + ALLOCATE(zn0_sto(1:2*nn_sto_eos)) + ALLOCATE(zn_sto(1:2*nn_sto_eos)) + ALLOCATE(zsign(1:2*nn_sto_eos)) + DO jsmp = 1, 2*nn_sto_eos, 2 + zsign(jsmp) = 1._wp + zsign(jsmp+1) = -1._wp + END DO + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + ! + ! compute density (2*nn_sto_eos) times: + ! (1) for t+dt, s+ds (with the random TS fluctutation computed in sto_pts) + ! (2) for t-dt, s-ds (with the opposite fluctuation) + DO jsmp = 1, nn_sto_eos*2 + jdof = (jsmp + 1) / 2 + zh = pdep(ji,jj,jk) * r1_Z0 ! depth + zt = (pts (ji,jj,jk,jp_tem) + pts_ran(ji,jj,jk,jp_tem,jdof) * zsign(jsmp)) * r1_T0 ! temperature + zstemp = pts (ji,jj,jk,jp_sal) + pts_ran(ji,jj,jk,jp_sal,jdof) * zsign(jsmp) + zs = SQRT( ABS( zstemp + rdeltaS ) * r1_S0 ) ! square root salinity + ztm = tmask(ji,jj,jk) ! tmask + ! + zn3 = EOS013*zt & + & + EOS103*zs+EOS003 + ! + zn2 = (EOS022*zt & + & + EOS112*zs+EOS012)*zt & + & + (EOS202*zs+EOS102)*zs+EOS002 + ! + zn1 = (((EOS041*zt & + & + EOS131*zs+EOS031)*zt & + & + (EOS221*zs+EOS121)*zs+EOS021)*zt & + & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & + & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 + ! + zn0_sto(jsmp) = (((((EOS060*zt & + & + EOS150*zs+EOS050)*zt & + & + (EOS240*zs+EOS140)*zs+EOS040)*zt & + & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & + & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & + & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & + & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 + ! + zn_sto(jsmp) = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0_sto(jsmp) + END DO + ! + ! compute stochastic density as the mean of the (2*nn_sto_eos) densities + prhop(ji,jj,jk) = 0._wp ; prd(ji,jj,jk) = 0._wp + DO jsmp = 1, nn_sto_eos*2 + prhop(ji,jj,jk) = prhop(ji,jj,jk) + zn0_sto(jsmp) ! potential density referenced at the surface + ! + prd(ji,jj,jk) = prd(ji,jj,jk) + ( zn_sto(jsmp) * r1_rho0 - 1._wp ) ! density anomaly (masked) + END DO + prhop(ji,jj,jk) = 0.5_wp * prhop(ji,jj,jk) * ztm / nn_sto_eos + prd (ji,jj,jk) = 0.5_wp * prd (ji,jj,jk) * ztm / nn_sto_eos + END_3D + DEALLOCATE(zn0_sto,zn_sto,zsign) + ! Non-stochastic equation of state + ELSE + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + ! + zh = pdep(ji,jj,jk) * r1_Z0 ! depth + zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ztm = tmask(ji,jj,jk) ! tmask + ! + zn3 = EOS013*zt & + & + EOS103*zs+EOS003 + ! + zn2 = (EOS022*zt & + & + EOS112*zs+EOS012)*zt & + & + (EOS202*zs+EOS102)*zs+EOS002 + ! + zn1 = (((EOS041*zt & + & + EOS131*zs+EOS031)*zt & + & + (EOS221*zs+EOS121)*zs+EOS021)*zt & + & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & + & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 + ! + zn0 = (((((EOS060*zt & + & + EOS150*zs+EOS050)*zt & + & + (EOS240*zs+EOS140)*zs+EOS040)*zt & + & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & + & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & + & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & + & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + prhop(ji,jj,jk) = zn0 * ztm ! potential density referenced at the surface + ! + prd(ji,jj,jk) = ( zn * r1_rho0 - 1._wp ) * ztm ! density anomaly (masked) + END_3D + ENDIF + + CASE( np_seos ) !== simplified EOS ==! + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + zt = pts (ji,jj,jk,jp_tem) - 10._wp + zs = pts (ji,jj,jk,jp_sal) - 35._wp + zh = pdep (ji,jj,jk) + ztm = tmask(ji,jj,jk) + ! ! potential density referenced at the surface + zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt & + & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs & + & - rn_nu * zt * zs + prhop(ji,jj,jk) = ( rho0 + zn ) * ztm + ! ! density anomaly (masked) + zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh + prd(ji,jj,jk) = zn * r1_rho0 * ztm + ! + END_3D + ! + END SELECT + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=REAL(prd,dp), clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ' ) + ! + IF( ln_timing ) CALL timing_stop('eos-pot') + ! + END SUBROUTINE eos_insitu_pot_t + + + SUBROUTINE eos_insitu_2d( pts, pdep, prd ) + !! + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(:,:) , INTENT( out) :: prd ! in situ density + !! + CALL eos_insitu_2d_t( pts, is_tile(pts), pdep, is_tile(pdep), prd, is_tile(prd) ) + END SUBROUTINE eos_insitu_2d + + + SUBROUTINE eos_insitu_2d_t( pts, ktts, pdep, ktdep, prd, ktrd ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_insitu_2d *** + !! + !! ** Purpose : Compute the in situ density (ratio rho/rho0) from + !! potential temperature and salinity using an equation of state + !! selected in the nameos namelist. * 2D field case + !! + !! ** Action : - prd , the in situ density (no units) (unmasked) + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ktts, ktdep, ktrd + REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(A2D_T(ktrd) ), INTENT( out) :: prd ! in situ density + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zt , zh , zs ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos2d') + ! + prd(:,:) = 0._wp + ! + SELECT CASE( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zh = pdep(ji,jj) * r1_Z0 ! depth + zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ! + zn3 = EOS013*zt & + & + EOS103*zs+EOS003 + ! + zn2 = (EOS022*zt & + & + EOS112*zs+EOS012)*zt & + & + (EOS202*zs+EOS102)*zs+EOS002 + ! + zn1 = (((EOS041*zt & + & + EOS131*zs+EOS031)*zt & + & + (EOS221*zs+EOS121)*zs+EOS021)*zt & + & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & + & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 + ! + zn0 = (((((EOS060*zt & + & + EOS150*zs+EOS050)*zt & + & + (EOS240*zs+EOS140)*zs+EOS040)*zt & + & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & + & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & + & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & + & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + prd(ji,jj) = zn * r1_rho0 - 1._wp ! unmasked in situ density anomaly + ! + END_2D + ! + CASE( np_seos ) !== simplified EOS ==! + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zt = pts (ji,jj,jp_tem) - 10._wp + zs = pts (ji,jj,jp_sal) - 35._wp + zh = pdep (ji,jj) ! depth at the partial step level + ! + zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt & + & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs & + & - rn_nu * zt * zs + ! + prd(ji,jj) = zn * r1_rho0 ! unmasked in situ density anomaly + ! + END_2D + ! + END SELECT + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=REAL(prd,dp), clinfo1=' eos2d: ' ) + ! + IF( ln_timing ) CALL timing_stop('eos2d') + ! + END SUBROUTINE eos_insitu_2d_t + + + SUBROUTINE eos_insitu_pot_2d( pts, prhop ) + !! + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(:,:) , INTENT( out) :: prhop ! potential density (surface referenced) + !! + CALL eos_insitu_pot_2d_t( pts, is_tile(pts), prhop, is_tile(prhop) ) + END SUBROUTINE eos_insitu_pot_2d + + + SUBROUTINE eos_insitu_pot_2d_t( pts, ktts, prhop, ktrhop ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_insitu_pot *** + !! + !! ** Purpose : Compute the in situ density (ratio rho/rho0) and the + !! potential volumic mass (Kg/m3) from potential temperature and + !! salinity fields using an equation of state selected in the + !! namelist. + !! + !! ** Action : + !! - prhop, the potential volumic mass (Kg/m3) + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: ktts, ktrhop + REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(A2D_T(ktrhop) ), INTENT( out) :: prhop ! potential density (surface referenced) + ! + INTEGER :: ji, jj, jk, jsmp ! dummy loop indices + INTEGER :: jdof + REAL(wp) :: zt , zh , zstemp, zs , ztm ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - + REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos-pot') + ! + SELECT CASE ( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ztm = tmask(ji,jj,1) ! tmask + ! + zn0 = (((((EOS060*zt & + & + EOS150*zs+EOS050)*zt & + & + (EOS240*zs+EOS140)*zs+EOS040)*zt & + & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & + & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & + & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & + & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 + ! + ! + prhop(ji,jj) = zn0 * ztm ! potential density referenced at the surface + ! + END_2D + + CASE( np_seos ) !== simplified EOS ==! + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zt = pts (ji,jj,jp_tem) - 10._wp + zs = pts (ji,jj,jp_sal) - 35._wp + ztm = tmask(ji,jj,1) + ! ! potential density referenced at the surface + zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt & + & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs & + & - rn_nu * zt * zs + prhop(ji,jj) = ( rho0 + zn ) * ztm + ! + END_2D + ! + END SELECT + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=REAL(prhop,dp), clinfo1=' pot: ', kdim=1 ) + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=REAL(prhop,dp), clinfo1=' eos-pot: ' ) + ! + IF( ln_timing ) CALL timing_stop('eos-pot') + ! + END SUBROUTINE eos_insitu_pot_2d_t + + + SUBROUTINE rab_3d( pts, pab, Kmm ) + !! + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION(:,:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio + !! + CALL rab_3d_t( pts, is_tile(pts), pab, is_tile(pab), Kmm ) + END SUBROUTINE rab_3d + + + SUBROUTINE rab_3d_t( pts, ktts, pab, ktab, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE rab_3d *** + !! + !! ** Purpose : Calculates thermal/haline expansion ratio at T-points + !! + !! ** Method : calculates alpha / beta at T-points + !! + !! ** Action : - pab : thermal/haline expansion ratio at T-points + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + INTEGER , INTENT(in ) :: ktts, ktab + REAL(dp), DIMENSION(A2D_T(ktts),JPK,JPTS), INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zt , zh , zs , ztm ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('rab_3d') + ! + SELECT CASE ( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + ! + zh = gdept(ji,jj,jk,Kmm) * r1_Z0 ! depth + zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ztm = tmask(ji,jj,jk) ! tmask + ! + ! alpha + zn3 = ALP003 + ! + zn2 = ALP012*zt + ALP102*zs+ALP002 + ! + zn1 = ((ALP031*zt & + & + ALP121*zs+ALP021)*zt & + & + (ALP211*zs+ALP111)*zs+ALP011)*zt & + & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 + ! + zn0 = ((((ALP050*zt & + & + ALP140*zs+ALP040)*zt & + & + (ALP230*zs+ALP130)*zs+ALP030)*zt & + & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & + & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & + & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + pab(ji,jj,jk,jp_tem) = zn * r1_rho0 * ztm + ! + ! beta + zn3 = BET003 + ! + zn2 = BET012*zt + BET102*zs+BET002 + ! + zn1 = ((BET031*zt & + & + BET121*zs+BET021)*zt & + & + (BET211*zs+BET111)*zs+BET011)*zt & + & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 + ! + zn0 = ((((BET050*zt & + & + BET140*zs+BET040)*zt & + & + (BET230*zs+BET130)*zs+BET030)*zt & + & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & + & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & + & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + pab(ji,jj,jk,jp_sal) = zn / zs * r1_rho0 * ztm + ! + END_3D + ! + CASE( np_seos ) !== simplified EOS ==! + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + zt = pts (ji,jj,jk,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) + zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) + zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point + ztm = tmask(ji,jj,jk) ! land/sea bottom mask = surf. mask + ! + zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs + pab(ji,jj,jk,jp_tem) = zn * r1_rho0 * ztm ! alpha + ! + zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt + pab(ji,jj,jk,jp_sal) = zn * r1_rho0 * ztm ! beta + ! + END_3D + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for neos = ', neos + CALL ctl_stop( 'rab_3d:', ctmp1 ) + ! + END SELECT + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=REAL(pab(:,:,:,jp_tem),dp), clinfo1=' rab_3d_t: ', & + & tab3d_2=REAL(pab(:,:,:,jp_sal),dp), clinfo2=' rab_3d_s : ' ) + ! + IF( ln_timing ) CALL timing_stop('rab_3d') + ! + END SUBROUTINE rab_3d_t + + + SUBROUTINE rab_2d( pts, pdep, pab, Kmm ) + !! + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio + !! + CALL rab_2d_t(pts, is_tile(pts), pdep, is_tile(pdep), pab, is_tile(pab), Kmm) + END SUBROUTINE rab_2d + + + SUBROUTINE rab_2d_t( pts, ktts, pdep, ktdep, pab, ktab, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE rab_2d *** + !! + !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked) + !! + !! ** Action : - pab : thermal/haline expansion ratio at T-points + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + INTEGER , INTENT(in ) :: ktts, ktdep, ktab + REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(A2D_T(ktab),JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zt , zh , zs ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('rab_2d') + ! + pab(:,:,:) = 0._wp + ! + SELECT CASE ( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zh = pdep(ji,jj) * r1_Z0 ! depth + zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ! + ! alpha + zn3 = ALP003 + ! + zn2 = ALP012*zt + ALP102*zs+ALP002 + ! + zn1 = ((ALP031*zt & + & + ALP121*zs+ALP021)*zt & + & + (ALP211*zs+ALP111)*zs+ALP011)*zt & + & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 + ! + zn0 = ((((ALP050*zt & + & + ALP140*zs+ALP040)*zt & + & + (ALP230*zs+ALP130)*zs+ALP030)*zt & + & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & + & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & + & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + pab(ji,jj,jp_tem) = zn * r1_rho0 + ! + ! beta + zn3 = BET003 + ! + zn2 = BET012*zt + BET102*zs+BET002 + ! + zn1 = ((BET031*zt & + & + BET121*zs+BET021)*zt & + & + (BET211*zs+BET111)*zs+BET011)*zt & + & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 + ! + zn0 = ((((BET050*zt & + & + BET140*zs+BET040)*zt & + & + (BET230*zs+BET130)*zs+BET030)*zt & + & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & + & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & + & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + pab(ji,jj,jp_sal) = zn / zs * r1_rho0 + ! + ! + END_2D + ! + CASE( np_seos ) !== simplified EOS ==! + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zt = pts (ji,jj,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) + zs = pts (ji,jj,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) + zh = pdep (ji,jj) ! depth at the partial step level + ! + zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs + pab(ji,jj,jp_tem) = zn * r1_rho0 ! alpha + ! + zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt + pab(ji,jj,jp_sal) = zn * r1_rho0 ! beta + ! + END_2D + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for neos = ', neos + CALL ctl_stop( 'rab_2d:', ctmp1 ) + ! + END SELECT + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=REAL(pab(:,:,jp_tem),dp), clinfo1=' rab_2d_t: ', & + & tab2d_2=REAL(pab(:,:,jp_sal),dp), clinfo2=' rab_2d_s : ' ) + ! + IF( ln_timing ) CALL timing_stop('rab_2d') + ! + END SUBROUTINE rab_2d_t + + + SUBROUTINE rab_0d( pts, pdep, pab, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE rab_0d *** + !! + !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked) + !! + !! ** Action : - pab : thermal/haline expansion ratio at T-points + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), DIMENSION(jpts) , INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio + ! + REAL(wp) :: zt , zh , zs ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('rab_0d') + ! + pab(:) = 0._wp + ! + SELECT CASE ( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + ! + zh = pdep * r1_Z0 ! depth + zt = pts (jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ! + ! alpha + zn3 = ALP003 + ! + zn2 = ALP012*zt + ALP102*zs+ALP002 + ! + zn1 = ((ALP031*zt & + & + ALP121*zs+ALP021)*zt & + & + (ALP211*zs+ALP111)*zs+ALP011)*zt & + & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 + ! + zn0 = ((((ALP050*zt & + & + ALP140*zs+ALP040)*zt & + & + (ALP230*zs+ALP130)*zs+ALP030)*zt & + & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & + & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & + & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + pab(jp_tem) = zn * r1_rho0 + ! + ! beta + zn3 = BET003 + ! + zn2 = BET012*zt + BET102*zs+BET002 + ! + zn1 = ((BET031*zt & + & + BET121*zs+BET021)*zt & + & + (BET211*zs+BET111)*zs+BET011)*zt & + & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 + ! + zn0 = ((((BET050*zt & + & + BET140*zs+BET040)*zt & + & + (BET230*zs+BET130)*zs+BET030)*zt & + & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & + & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & + & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 + ! + zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 + ! + pab(jp_sal) = zn / zs * r1_rho0 + ! + ! + ! + CASE( np_seos ) !== simplified EOS ==! + ! + zt = pts(jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) + zs = pts(jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) + zh = pdep ! depth at the partial step level + ! + zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs + pab(jp_tem) = zn * r1_rho0 ! alpha + ! + zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt + pab(jp_sal) = zn * r1_rho0 ! beta + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for neos = ', neos + CALL ctl_stop( 'rab_0d:', ctmp1 ) + ! + END SELECT + ! + IF( ln_timing ) CALL timing_stop('rab_0d') + ! + END SUBROUTINE rab_0d + + + SUBROUTINE bn2( pts, pab, pn2, Kmm ) + !! + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] + REAL(wp), DIMENSION(:,:,:,:) , INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] + !! + CALL bn2_t( pts, pab, is_tile(pab), pn2, is_tile(pn2), Kmm ) + END SUBROUTINE bn2 + + + SUBROUTINE bn2_t( pts, pab, ktab, pn2, ktn2, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bn2 *** + !! + !! ** Purpose : Compute the local Brunt-Vaisala frequency at the + !! time-step of the input arguments + !! + !! ** Method : pn2 = grav * (alpha dk[T] + beta dk[S] ) / e3w + !! where alpha and beta are given in pab, and computed on T-points. + !! N.B. N^2 is set one for all to zero at jk=1 in istate module. + !! + !! ** Action : pn2 : square of the brunt-vaisala frequency at w-point + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + INTEGER , INTENT(in ) :: ktab, ktn2 + REAL(dp), DIMENSION(jpi,jpj, jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] + REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] + REAL(wp), DIMENSION(A2D_T(ktn2),JPK ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zaw, zbw, zrw ! local scalars + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('bn2') + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpkm1 ) ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F90 + zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) & + & / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) ) + ! + zaw = pab(ji,jj,jk,jp_tem) * (1. - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw + zbw = pab(ji,jj,jk,jp_sal) * (1. - zrw) + pab(ji,jj,jk-1,jp_sal) * zrw + ! + pn2(ji,jj,jk) = grav * ( zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) & + & - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ) & + & / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) + END_3D + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=REAL(pn2,dp), clinfo1=' bn2 : ' ) + ! + IF( ln_timing ) CALL timing_stop('bn2') + ! + END SUBROUTINE bn2_t + + + FUNCTION eos_pt_from_ct( ctmp, psal ) RESULT( ptmp ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_pt_from_ct *** + !! + !! ** Purpose : Compute pot.temp. from cons. temp. [Celsius] + !! + !! ** Method : rational approximation (5/3th order) of TEOS-10 algorithm + !! checkvalue: pt=20.02391895 Celsius for sa=35.7g/kg, ct=20degC + !! + !! Reference : TEOS-10, UNESCO + !! Rational approximation to TEOS10 algorithm (rms error on WOA13 values: 4.0e-5 degC) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: ctmp ! Cons. Temp [Celsius] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] + ! Leave result array automatic rather than making explicitly allocated + REAL(wp), DIMENSION(jpi,jpj) :: ptmp ! potential temperature [Celsius] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zt , zs , ztm ! local scalars + REAL(wp) :: zn , zd ! local scalars + REAL(wp) :: zdeltaS , z1_S0 , z1_T0 + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos_pt_from_ct') + ! + zdeltaS = 5._wp + z1_S0 = 0.875_wp/35.16504_wp + z1_T0 = 1._wp/40._wp + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ! + zt = ctmp (ji,jj) * z1_T0 + zs = SQRT( ABS( psal(ji,jj) + zdeltaS ) * z1_S0 ) + ztm = tmask(ji,jj,1) + ! + zn = ((((-2.1385727895e-01_wp*zt & + & - 2.7674419971e-01_wp*zs+1.0728094330_wp)*zt & + & + (2.6366564313_wp*zs+3.3546960647_wp)*zs-7.8012209473_wp)*zt & + & + ((1.8835586562_wp*zs+7.3949191679_wp)*zs-3.3937395875_wp)*zs-5.6414948432_wp)*zt & + & + (((3.5737370589_wp*zs-1.5512427389e+01_wp)*zs+2.4625741105e+01_wp)*zs & + & +1.9912291000e+01_wp)*zs-3.2191146312e+01_wp)*zt & + & + ((((5.7153204649e-01_wp*zs-3.0943149543_wp)*zs+9.3052495181_wp)*zs & + & -9.4528934807_wp)*zs+3.1066408996_wp)*zs-4.3504021262e-01_wp + ! + zd = (2.0035003456_wp*zt & + & -3.4570358592e-01_wp*zs+5.6471810638_wp)*zt & + & + (1.5393993508_wp*zs-6.9394762624_wp)*zs+1.2750522650e+01_wp + ! + ptmp(ji,jj) = ( zt / z1_T0 + zn / zd ) * ztm + ! + END_2D + ! + IF( ln_timing ) CALL timing_stop('eos_pt_from_ct') + ! + END FUNCTION eos_pt_from_ct + + + SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) + !! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] + REAL(dp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] + REAL(wp), DIMENSION(:,:) , INTENT(out ) :: ptf ! freezing temperature [Celsius] + !! + CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep ) + END SUBROUTINE eos_fzp_2d + + + SUBROUTINE eos_fzp_2d_t( psal, ptf, kttf, pdep ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_fzp *** + !! + !! ** Purpose : Compute the freezing point temperature [Celsius] + !! + !! ** Method : UNESCO freezing point (ptf) in Celsius is given by + !! ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z + !! checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m + !! + !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kttf + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: psal ! salinity [psu] + REAL(dp), DIMENSION(jpi,jpj) , INTENT(in ), OPTIONAL :: pdep ! depth [m] + REAL(wp), DIMENSION(A2D_T(kttf)), INTENT(out ) :: ptf ! freezing temperature [Celsius] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zt, zs, z1_S0 ! local scalars + !!---------------------------------------------------------------------- + ! + SELECT CASE ( neos ) + ! + CASE ( np_teos10, np_seos ) !== CT,SA (TEOS-10 and S-EOS formulations) ==! + ! + z1_S0 = 1._wp / 35.16504_wp + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zs= SQRT( ABS( psal(ji,jj) ) * z1_S0 ) ! square root salinity + ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & + & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp + END_2D + ptf(:,:) = ptf(:,:) * psal(:,:) + ! + IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) + ! + CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==! + ! + ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) ) & + & - 2.154996e-4_wp * psal(:,:) ) * psal(:,:) + ! + IF( PRESENT( pdep ) ) ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for neos = ', neos + CALL ctl_stop( 'eos_fzp_2d:', ctmp1 ) + ! + END SELECT + ! + END SUBROUTINE eos_fzp_2d_t + + + SUBROUTINE eos_fzp_0d( psal, ptf, pdep ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_fzp *** + !! + !! ** Purpose : Compute the freezing point temperature [Celsius] + !! + !! ** Method : UNESCO freezing point (ptf) in Celsius is given by + !! ptf(t,z) = (-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s - 7.53e-4*z + !! checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m + !! + !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: psal ! salinity [psu] + REAL(wp), INTENT(in ), OPTIONAL :: pdep ! depth [m] + REAL(wp), INTENT(out) :: ptf ! freezing temperature [Celsius] + ! + REAL(wp) :: zs ! local scalars + !!---------------------------------------------------------------------- + ! + SELECT CASE ( neos ) + ! + CASE ( np_teos10, np_seos ) !== CT,SA (TEOS-10 and S-EOS formulations) ==! + ! + zs = SQRT( ABS( psal ) / 35.16504_wp ) ! square root salinity + ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & + & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp + ptf = ptf * psal + ! + IF( PRESENT( pdep ) ) ptf = ptf - 7.53e-4 * pdep + ! + CASE ( np_eos80 ) !== PT,SP (UNESCO formulation) ==! + ! + ptf = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal ) & + & - 2.154996e-4_wp * psal ) * psal + ! + IF( PRESENT( pdep ) ) ptf = ptf - 7.53e-4 * pdep + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for neos = ', neos + CALL ctl_stop( 'eos_fzp_0d:', ctmp1 ) + ! + END SELECT + ! + END SUBROUTINE eos_fzp_0d + + + SUBROUTINE eos_pen( pts, pab_pe, ppen, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_pen *** + !! + !! ** Purpose : Calculates nonlinear anomalies of alpha_PE, beta_PE and PE at T-points + !! + !! ** Method : PE is defined analytically as the vertical + !! primitive of EOS times -g integrated between 0 and z>0. + !! pen is the nonlinear bsq-PE anomaly: pen = ( PE - rho0 gz ) / rho0 gz - rd + !! = 1/z * /int_0^z rd dz - rd + !! where rd is the density anomaly (see eos_rhd function) + !! ab_pe are partial derivatives of PE anomaly with respect to T and S: + !! ab_pe(1) = - 1/(rho0 gz) * dPE/dT + drd/dT = - d(pen)/dT + !! ab_pe(2) = 1/(rho0 gz) * dPE/dS + drd/dS = d(pen)/dS + !! + !! ** Action : - pen : PE anomaly given at T-points + !! : - pab_pe : given at T-points + !! pab_pe(:,:,:,jp_tem) is alpha_pe + !! pab_pe(:,:,:,jp_sal) is beta_pe + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab_pe ! alpha_pe and beta_pe + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: ppen ! potential energy anomaly + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zt , zh , zs , ztm ! local scalars + REAL(wp) :: zn , zn0, zn1, zn2 ! - - + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('eos_pen') + ! + SELECT CASE ( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + ! + zh = gdept(ji,jj,jk,Kmm) * r1_Z0 ! depth + zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature + zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity + ztm = tmask(ji,jj,jk) ! tmask + ! + ! potential energy non-linear anomaly + zn2 = (PEN012)*zt & + & + PEN102*zs+PEN002 + ! + zn1 = ((PEN021)*zt & + & + PEN111*zs+PEN011)*zt & + & + (PEN201*zs+PEN101)*zs+PEN001 + ! + zn0 = ((((PEN040)*zt & + & + PEN130*zs+PEN030)*zt & + & + (PEN220*zs+PEN120)*zs+PEN020)*zt & + & + ((PEN310*zs+PEN210)*zs+PEN110)*zs+PEN010)*zt & + & + (((PEN400*zs+PEN300)*zs+PEN200)*zs+PEN100)*zs+PEN000 + ! + zn = ( zn2 * zh + zn1 ) * zh + zn0 + ! + ppen(ji,jj,jk) = zn * zh * r1_rho0 * ztm + ! + ! alphaPE non-linear anomaly + zn2 = APE002 + ! + zn1 = (APE011)*zt & + & + APE101*zs+APE001 + ! + zn0 = (((APE030)*zt & + & + APE120*zs+APE020)*zt & + & + (APE210*zs+APE110)*zs+APE010)*zt & + & + ((APE300*zs+APE200)*zs+APE100)*zs+APE000 + ! + zn = ( zn2 * zh + zn1 ) * zh + zn0 + ! + pab_pe(ji,jj,jk,jp_tem) = zn * zh * r1_rho0 * ztm + ! + ! betaPE non-linear anomaly + zn2 = BPE002 + ! + zn1 = (BPE011)*zt & + & + BPE101*zs+BPE001 + ! + zn0 = (((BPE030)*zt & + & + BPE120*zs+BPE020)*zt & + & + (BPE210*zs+BPE110)*zs+BPE010)*zt & + & + ((BPE300*zs+BPE200)*zs+BPE100)*zs+BPE000 + ! + zn = ( zn2 * zh + zn1 ) * zh + zn0 + ! + pab_pe(ji,jj,jk,jp_sal) = zn / zs * zh * r1_rho0 * ztm + ! + END_3D + ! + CASE( np_seos ) !== Vallis (2006) simplified EOS ==! + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + zt = pts(ji,jj,jk,jp_tem) - 10._wp ! temperature anomaly (t-T0) + zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) + zh = gdept(ji,jj,jk,Kmm) ! depth in meters at t-point + ztm = tmask(ji,jj,jk) ! tmask + zn = 0.5_wp * zh * r1_rho0 * ztm + ! ! Potential Energy + ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn + ! ! alphaPE + pab_pe(ji,jj,jk,jp_tem) = - rn_a0 * rn_mu1 * zn + pab_pe(ji,jj,jk,jp_sal) = rn_b0 * rn_mu2 * zn + ! + END_3D + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for neos = ', neos + CALL ctl_stop( 'eos_pen:', ctmp1 ) + ! + END SELECT + ! + IF( ln_timing ) CALL timing_stop('eos_pen') + ! + END SUBROUTINE eos_pen + + + SUBROUTINE eos_init + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_init *** + !! + !! ** Purpose : initializations for the equation of state + !! + !! ** Method : Read the namelist nameos and control the parameters + !!---------------------------------------------------------------------- + INTEGER :: ios ! local integer + INTEGER :: ioptio ! local integer + !! + NAMELIST/nameos/ ln_TEOS10, ln_EOS80, ln_SEOS, rn_a0, rn_b0, rn_lambda1, rn_mu1, & + & rn_lambda2, rn_mu2, rn_nu + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in reference namelist' ) + ! + READ ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nameos in configuration namelist' ) + IF(lwm) WRITE( numond, nameos ) + ! + rho0 = 1026._wp !: volumic mass of reference [kg/m3] + rcp = 3991.86795711963_wp !: heat capacity [J/K] + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'eos_init : equation of state' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) ' Namelist nameos : Chosen the Equation Of Seawater (EOS)' + WRITE(numout,*) ' TEOS-10 : rho=F(Conservative Temperature, Absolute Salinity, depth) ln_TEOS10 = ', ln_TEOS10 + WRITE(numout,*) ' EOS-80 : rho=F(Potential Temperature, Practical Salinity, depth) ln_EOS80 = ', ln_EOS80 + WRITE(numout,*) ' S-EOS : rho=F(Conservative Temperature, Absolute Salinity, depth) ln_SEOS = ', ln_SEOS + ENDIF + + ! Check options for equation of state & set neos based on logical flags + ioptio = 0 + IF( ln_TEOS10 ) THEN ; ioptio = ioptio+1 ; neos = np_teos10 ; ENDIF + IF( ln_EOS80 ) THEN ; ioptio = ioptio+1 ; neos = np_eos80 ; ENDIF + IF( ln_SEOS ) THEN ; ioptio = ioptio+1 ; neos = np_seos ; ENDIF + IF( ioptio /= 1 ) CALL ctl_stop("Exactly one equation of state option must be selected") + ! + SELECT CASE( neos ) ! check option + ! + CASE( np_teos10 ) !== polynomial TEOS-10 ==! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> use of TEOS-10 equation of state (cons. temp. and abs. salinity)' + ! + l_useCT = .TRUE. ! model temperature is Conservative temperature + ! + rdeltaS = 32._wp + r1_S0 = 0.875_wp/35.16504_wp + r1_T0 = 1._wp/40._wp + r1_Z0 = 1.e-4_wp + ! + EOS000 = 8.0189615746e+02_wp + EOS100 = 8.6672408165e+02_wp + EOS200 = -1.7864682637e+03_wp + EOS300 = 2.0375295546e+03_wp + EOS400 = -1.2849161071e+03_wp + EOS500 = 4.3227585684e+02_wp + EOS600 = -6.0579916612e+01_wp + EOS010 = 2.6010145068e+01_wp + EOS110 = -6.5281885265e+01_wp + EOS210 = 8.1770425108e+01_wp + EOS310 = -5.6888046321e+01_wp + EOS410 = 1.7681814114e+01_wp + EOS510 = -1.9193502195_wp + EOS020 = -3.7074170417e+01_wp + EOS120 = 6.1548258127e+01_wp + EOS220 = -6.0362551501e+01_wp + EOS320 = 2.9130021253e+01_wp + EOS420 = -5.4723692739_wp + EOS030 = 2.1661789529e+01_wp + EOS130 = -3.3449108469e+01_wp + EOS230 = 1.9717078466e+01_wp + EOS330 = -3.1742946532_wp + EOS040 = -8.3627885467_wp + EOS140 = 1.1311538584e+01_wp + EOS240 = -5.3563304045_wp + EOS050 = 5.4048723791e-01_wp + EOS150 = 4.8169980163e-01_wp + EOS060 = -1.9083568888e-01_wp + EOS001 = 1.9681925209e+01_wp + EOS101 = -4.2549998214e+01_wp + EOS201 = 5.0774768218e+01_wp + EOS301 = -3.0938076334e+01_wp + EOS401 = 6.6051753097_wp + EOS011 = -1.3336301113e+01_wp + EOS111 = -4.4870114575_wp + EOS211 = 5.0042598061_wp + EOS311 = -6.5399043664e-01_wp + EOS021 = 6.7080479603_wp + EOS121 = 3.5063081279_wp + EOS221 = -1.8795372996_wp + EOS031 = -2.4649669534_wp + EOS131 = -5.5077101279e-01_wp + EOS041 = 5.5927935970e-01_wp + EOS002 = 2.0660924175_wp + EOS102 = -4.9527603989_wp + EOS202 = 2.5019633244_wp + EOS012 = 2.0564311499_wp + EOS112 = -2.1311365518e-01_wp + EOS022 = -1.2419983026_wp + EOS003 = -2.3342758797e-02_wp + EOS103 = -1.8507636718e-02_wp + EOS013 = 3.7969820455e-01_wp + ! + ALP000 = -6.5025362670e-01_wp + ALP100 = 1.6320471316_wp + ALP200 = -2.0442606277_wp + ALP300 = 1.4222011580_wp + ALP400 = -4.4204535284e-01_wp + ALP500 = 4.7983755487e-02_wp + ALP010 = 1.8537085209_wp + ALP110 = -3.0774129064_wp + ALP210 = 3.0181275751_wp + ALP310 = -1.4565010626_wp + ALP410 = 2.7361846370e-01_wp + ALP020 = -1.6246342147_wp + ALP120 = 2.5086831352_wp + ALP220 = -1.4787808849_wp + ALP320 = 2.3807209899e-01_wp + ALP030 = 8.3627885467e-01_wp + ALP130 = -1.1311538584_wp + ALP230 = 5.3563304045e-01_wp + ALP040 = -6.7560904739e-02_wp + ALP140 = -6.0212475204e-02_wp + ALP050 = 2.8625353333e-02_wp + ALP001 = 3.3340752782e-01_wp + ALP101 = 1.1217528644e-01_wp + ALP201 = -1.2510649515e-01_wp + ALP301 = 1.6349760916e-02_wp + ALP011 = -3.3540239802e-01_wp + ALP111 = -1.7531540640e-01_wp + ALP211 = 9.3976864981e-02_wp + ALP021 = 1.8487252150e-01_wp + ALP121 = 4.1307825959e-02_wp + ALP031 = -5.5927935970e-02_wp + ALP002 = -5.1410778748e-02_wp + ALP102 = 5.3278413794e-03_wp + ALP012 = 6.2099915132e-02_wp + ALP003 = -9.4924551138e-03_wp + ! + BET000 = 1.0783203594e+01_wp + BET100 = -4.4452095908e+01_wp + BET200 = 7.6048755820e+01_wp + BET300 = -6.3944280668e+01_wp + BET400 = 2.6890441098e+01_wp + BET500 = -4.5221697773_wp + BET010 = -8.1219372432e-01_wp + BET110 = 2.0346663041_wp + BET210 = -2.1232895170_wp + BET310 = 8.7994140485e-01_wp + BET410 = -1.1939638360e-01_wp + BET020 = 7.6574242289e-01_wp + BET120 = -1.5019813020_wp + BET220 = 1.0872489522_wp + BET320 = -2.7233429080e-01_wp + BET030 = -4.1615152308e-01_wp + BET130 = 4.9061350869e-01_wp + BET230 = -1.1847737788e-01_wp + BET040 = 1.4073062708e-01_wp + BET140 = -1.3327978879e-01_wp + BET050 = 5.9929880134e-03_wp + BET001 = -5.2937873009e-01_wp + BET101 = 1.2634116779_wp + BET201 = -1.1547328025_wp + BET301 = 3.2870876279e-01_wp + BET011 = -5.5824407214e-02_wp + BET111 = 1.2451933313e-01_wp + BET211 = -2.4409539932e-02_wp + BET021 = 4.3623149752e-02_wp + BET121 = -4.6767901790e-02_wp + BET031 = -6.8523260060e-03_wp + BET002 = -6.1618945251e-02_wp + BET102 = 6.2255521644e-02_wp + BET012 = -2.6514181169e-03_wp + BET003 = -2.3025968587e-04_wp + ! + PEN000 = -9.8409626043_wp + PEN100 = 2.1274999107e+01_wp + PEN200 = -2.5387384109e+01_wp + PEN300 = 1.5469038167e+01_wp + PEN400 = -3.3025876549_wp + PEN010 = 6.6681505563_wp + PEN110 = 2.2435057288_wp + PEN210 = -2.5021299030_wp + PEN310 = 3.2699521832e-01_wp + PEN020 = -3.3540239802_wp + PEN120 = -1.7531540640_wp + PEN220 = 9.3976864981e-01_wp + PEN030 = 1.2324834767_wp + PEN130 = 2.7538550639e-01_wp + PEN040 = -2.7963967985e-01_wp + PEN001 = -1.3773949450_wp + PEN101 = 3.3018402659_wp + PEN201 = -1.6679755496_wp + PEN011 = -1.3709540999_wp + PEN111 = 1.4207577012e-01_wp + PEN021 = 8.2799886843e-01_wp + PEN002 = 1.7507069098e-02_wp + PEN102 = 1.3880727538e-02_wp + PEN012 = -2.8477365341e-01_wp + ! + APE000 = -1.6670376391e-01_wp + APE100 = -5.6087643219e-02_wp + APE200 = 6.2553247576e-02_wp + APE300 = -8.1748804580e-03_wp + APE010 = 1.6770119901e-01_wp + APE110 = 8.7657703198e-02_wp + APE210 = -4.6988432490e-02_wp + APE020 = -9.2436260751e-02_wp + APE120 = -2.0653912979e-02_wp + APE030 = 2.7963967985e-02_wp + APE001 = 3.4273852498e-02_wp + APE101 = -3.5518942529e-03_wp + APE011 = -4.1399943421e-02_wp + APE002 = 7.1193413354e-03_wp + ! + BPE000 = 2.6468936504e-01_wp + BPE100 = -6.3170583896e-01_wp + BPE200 = 5.7736640125e-01_wp + BPE300 = -1.6435438140e-01_wp + BPE010 = 2.7912203607e-02_wp + BPE110 = -6.2259666565e-02_wp + BPE210 = 1.2204769966e-02_wp + BPE020 = -2.1811574876e-02_wp + BPE120 = 2.3383950895e-02_wp + BPE030 = 3.4261630030e-03_wp + BPE001 = 4.1079296834e-02_wp + BPE101 = -4.1503681096e-02_wp + BPE011 = 1.7676120780e-03_wp + BPE002 = 1.7269476440e-04_wp + ! + CASE( np_eos80 ) !== polynomial EOS-80 formulation ==! + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> use of EOS-80 equation of state (pot. temp. and pract. salinity)' + ! + l_useCT = .FALSE. ! model temperature is Potential temperature + rdeltaS = 20._wp + r1_S0 = 1._wp/40._wp + r1_T0 = 1._wp/40._wp + r1_Z0 = 1.e-4_wp + ! + EOS000 = 9.5356891948e+02_wp + EOS100 = 1.7136499189e+02_wp + EOS200 = -3.7501039454e+02_wp + EOS300 = 5.1856810420e+02_wp + EOS400 = -3.7264470465e+02_wp + EOS500 = 1.4302533998e+02_wp + EOS600 = -2.2856621162e+01_wp + EOS010 = 1.0087518651e+01_wp + EOS110 = -1.3647741861e+01_wp + EOS210 = 8.8478359933_wp + EOS310 = -7.2329388377_wp + EOS410 = 1.4774410611_wp + EOS510 = 2.0036720553e-01_wp + EOS020 = -2.5579830599e+01_wp + EOS120 = 2.4043512327e+01_wp + EOS220 = -1.6807503990e+01_wp + EOS320 = 8.3811577084_wp + EOS420 = -1.9771060192_wp + EOS030 = 1.6846451198e+01_wp + EOS130 = -2.1482926901e+01_wp + EOS230 = 1.0108954054e+01_wp + EOS330 = -6.2675951440e-01_wp + EOS040 = -8.0812310102_wp + EOS140 = 1.0102374985e+01_wp + EOS240 = -4.8340368631_wp + EOS050 = 1.2079167803_wp + EOS150 = 1.1515380987e-01_wp + EOS060 = -2.4520288837e-01_wp + EOS001 = 1.0748601068e+01_wp + EOS101 = -1.7817043500e+01_wp + EOS201 = 2.2181366768e+01_wp + EOS301 = -1.6750916338e+01_wp + EOS401 = 4.1202230403_wp + EOS011 = -1.5852644587e+01_wp + EOS111 = -7.6639383522e-01_wp + EOS211 = 4.1144627302_wp + EOS311 = -6.6955877448e-01_wp + EOS021 = 9.9994861860_wp + EOS121 = -1.9467067787e-01_wp + EOS221 = -1.2177554330_wp + EOS031 = -3.4866102017_wp + EOS131 = 2.2229155620e-01_wp + EOS041 = 5.9503008642e-01_wp + EOS002 = 1.0375676547_wp + EOS102 = -3.4249470629_wp + EOS202 = 2.0542026429_wp + EOS012 = 2.1836324814_wp + EOS112 = -3.4453674320e-01_wp + EOS022 = -1.2548163097_wp + EOS003 = 1.8729078427e-02_wp + EOS103 = -5.7238495240e-02_wp + EOS013 = 3.8306136687e-01_wp + ! + ALP000 = -2.5218796628e-01_wp + ALP100 = 3.4119354654e-01_wp + ALP200 = -2.2119589983e-01_wp + ALP300 = 1.8082347094e-01_wp + ALP400 = -3.6936026529e-02_wp + ALP500 = -5.0091801383e-03_wp + ALP010 = 1.2789915300_wp + ALP110 = -1.2021756164_wp + ALP210 = 8.4037519952e-01_wp + ALP310 = -4.1905788542e-01_wp + ALP410 = 9.8855300959e-02_wp + ALP020 = -1.2634838399_wp + ALP120 = 1.6112195176_wp + ALP220 = -7.5817155402e-01_wp + ALP320 = 4.7006963580e-02_wp + ALP030 = 8.0812310102e-01_wp + ALP130 = -1.0102374985_wp + ALP230 = 4.8340368631e-01_wp + ALP040 = -1.5098959754e-01_wp + ALP140 = -1.4394226233e-02_wp + ALP050 = 3.6780433255e-02_wp + ALP001 = 3.9631611467e-01_wp + ALP101 = 1.9159845880e-02_wp + ALP201 = -1.0286156825e-01_wp + ALP301 = 1.6738969362e-02_wp + ALP011 = -4.9997430930e-01_wp + ALP111 = 9.7335338937e-03_wp + ALP211 = 6.0887771651e-02_wp + ALP021 = 2.6149576513e-01_wp + ALP121 = -1.6671866715e-02_wp + ALP031 = -5.9503008642e-02_wp + ALP002 = -5.4590812035e-02_wp + ALP102 = 8.6134185799e-03_wp + ALP012 = 6.2740815484e-02_wp + ALP003 = -9.5765341718e-03_wp + ! + BET000 = 2.1420623987_wp + BET100 = -9.3752598635_wp + BET200 = 1.9446303907e+01_wp + BET300 = -1.8632235232e+01_wp + BET400 = 8.9390837485_wp + BET500 = -1.7142465871_wp + BET010 = -1.7059677327e-01_wp + BET110 = 2.2119589983e-01_wp + BET210 = -2.7123520642e-01_wp + BET310 = 7.3872053057e-02_wp + BET410 = 1.2522950346e-02_wp + BET020 = 3.0054390409e-01_wp + BET120 = -4.2018759976e-01_wp + BET220 = 3.1429341406e-01_wp + BET320 = -9.8855300959e-02_wp + BET030 = -2.6853658626e-01_wp + BET130 = 2.5272385134e-01_wp + BET230 = -2.3503481790e-02_wp + BET040 = 1.2627968731e-01_wp + BET140 = -1.2085092158e-01_wp + BET050 = 1.4394226233e-03_wp + BET001 = -2.2271304375e-01_wp + BET101 = 5.5453416919e-01_wp + BET201 = -6.2815936268e-01_wp + BET301 = 2.0601115202e-01_wp + BET011 = -9.5799229402e-03_wp + BET111 = 1.0286156825e-01_wp + BET211 = -2.5108454043e-02_wp + BET021 = -2.4333834734e-03_wp + BET121 = -3.0443885826e-02_wp + BET031 = 2.7786444526e-03_wp + BET002 = -4.2811838287e-02_wp + BET102 = 5.1355066072e-02_wp + BET012 = -4.3067092900e-03_wp + BET003 = -7.1548119050e-04_wp + ! + PEN000 = -5.3743005340_wp + PEN100 = 8.9085217499_wp + PEN200 = -1.1090683384e+01_wp + PEN300 = 8.3754581690_wp + PEN400 = -2.0601115202_wp + PEN010 = 7.9263222935_wp + PEN110 = 3.8319691761e-01_wp + PEN210 = -2.0572313651_wp + PEN310 = 3.3477938724e-01_wp + PEN020 = -4.9997430930_wp + PEN120 = 9.7335338937e-02_wp + PEN220 = 6.0887771651e-01_wp + PEN030 = 1.7433051009_wp + PEN130 = -1.1114577810e-01_wp + PEN040 = -2.9751504321e-01_wp + PEN001 = -6.9171176978e-01_wp + PEN101 = 2.2832980419_wp + PEN201 = -1.3694684286_wp + PEN011 = -1.4557549876_wp + PEN111 = 2.2969116213e-01_wp + PEN021 = 8.3654420645e-01_wp + PEN002 = -1.4046808820e-02_wp + PEN102 = 4.2928871430e-02_wp + PEN012 = -2.8729602515e-01_wp + ! + APE000 = -1.9815805734e-01_wp + APE100 = -9.5799229402e-03_wp + APE200 = 5.1430784127e-02_wp + APE300 = -8.3694846809e-03_wp + APE010 = 2.4998715465e-01_wp + APE110 = -4.8667669469e-03_wp + APE210 = -3.0443885826e-02_wp + APE020 = -1.3074788257e-01_wp + APE120 = 8.3359333577e-03_wp + APE030 = 2.9751504321e-02_wp + APE001 = 3.6393874690e-02_wp + APE101 = -5.7422790533e-03_wp + APE011 = -4.1827210323e-02_wp + APE002 = 7.1824006288e-03_wp + ! + BPE000 = 1.1135652187e-01_wp + BPE100 = -2.7726708459e-01_wp + BPE200 = 3.1407968134e-01_wp + BPE300 = -1.0300557601e-01_wp + BPE010 = 4.7899614701e-03_wp + BPE110 = -5.1430784127e-02_wp + BPE210 = 1.2554227021e-02_wp + BPE020 = 1.2166917367e-03_wp + BPE120 = 1.5221942913e-02_wp + BPE030 = -1.3893222263e-03_wp + BPE001 = 2.8541225524e-02_wp + BPE101 = -3.4236710714e-02_wp + BPE011 = 2.8711395266e-03_wp + BPE002 = 5.3661089288e-04_wp + ! + CASE( np_seos ) !== Simplified EOS ==! + + r1_S0 = 0.875_wp/35.16504_wp ! Used to convert CT in potential temperature when using bulk formulae (eos_pt_from_ct) + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ==>>> use of simplified eos: ' + WRITE(numout,*) ' rhd(dT=T-10,dS=S-35,Z) = [-a0*(1+lambda1/2*dT+mu1*Z)*dT ' + WRITE(numout,*) ' + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS] / rho0' + WRITE(numout,*) ' with the following coefficients :' + WRITE(numout,*) ' thermal exp. coef. rn_a0 = ', rn_a0 + WRITE(numout,*) ' saline cont. coef. rn_b0 = ', rn_b0 + WRITE(numout,*) ' cabbeling coef. rn_lambda1 = ', rn_lambda1 + WRITE(numout,*) ' cabbeling coef. rn_lambda2 = ', rn_lambda2 + WRITE(numout,*) ' thermobar. coef. rn_mu1 = ', rn_mu1 + WRITE(numout,*) ' thermobar. coef. rn_mu2 = ', rn_mu2 + WRITE(numout,*) ' 2nd cabbel. coef. rn_nu = ', rn_nu + WRITE(numout,*) ' Caution: rn_beta0=0 incompatible with ddm parameterization ' + ENDIF + l_useCT = .TRUE. ! Use conservative temperature + ! + CASE DEFAULT !== ERROR in neos ==! + WRITE(ctmp1,*) ' bad flag value for neos = ', neos, '. You should never see this error' + CALL ctl_stop( ctmp1 ) + ! + END SELECT + ! + rho0_rcp = rho0 * rcp + r1_rho0 = 1._wp / rho0 + r1_rcp = 1._wp / rcp + r1_rho0_rcp = 1._wp / rho0_rcp + ! + IF(lwp) THEN + IF( l_useCT ) THEN + WRITE(numout,*) + WRITE(numout,*) ' ==>>> model uses Conservative Temperature' + WRITE(numout,*) ' Important: model must be initialized with CT and SA fields' + ELSE + WRITE(numout,*) + WRITE(numout,*) ' ==>>> model does not use Conservative Temperature' + ENDIF + ENDIF + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' Associated physical constant' + IF(lwp) WRITE(numout,*) ' volumic mass of reference rho0 = ', rho0 , ' kg/m^3' + IF(lwp) WRITE(numout,*) ' 1. / rho0 r1_rho0 = ', r1_rho0, ' m^3/kg' + IF(lwp) WRITE(numout,*) ' ocean specific heat rcp = ', rcp , ' J/Kelvin' + IF(lwp) WRITE(numout,*) ' rho0 * rcp rho0_rcp = ', rho0_rcp + IF(lwp) WRITE(numout,*) ' 1. / ( rho0 * rcp ) r1_rho0_rcp = ', r1_rho0_rcp + ! + END SUBROUTINE eos_init + + !!====================================================================== +END MODULE eosbn2 diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv.F90 new file mode 100644 index 0000000..817a368 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv.F90 @@ -0,0 +1,315 @@ +MODULE traadv + !!============================================================================== + !! *** MODULE traadv *** + !! Ocean active tracers: advection trend + !!============================================================================== + !! History : 2.0 ! 2005-11 (G. Madec) Original code + !! 3.3 ! 2010-09 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport + !! 3.6 ! 2011-06 (G. Madec) Addition of Mixed Layer Eddy parameterisation + !! 3.7 ! 2014-05 (G. Madec) Add 2nd/4th order cases for CEN and FCT schemes + !! - ! 2014-12 (G. Madec) suppression of cross land advection option + !! 3.6 ! 2015-06 (E. Clementi) Addition of Stokes drift in case of wave coupling + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv : compute ocean tracer advection trend + !! tra_adv_init : control the different options of advection scheme + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + USE domtile + USE domvvl ! variable vertical scale factors + USE sbcwave ! wave module + USE sbc_oce ! surface boundary condition: ocean + USE traadv_cen ! centered scheme (tra_adv_cen routine) + USE traadv_fct ! FCT scheme (tra_adv_fct routine) + USE traadv_mus ! MUSCL scheme (tra_adv_mus routine) + USE traadv_ubs ! UBS scheme (tra_adv_ubs routine) + USE traadv_qck ! QUICKEST scheme (tra_adv_qck routine) + USE tramle ! Mixed Layer Eddy transport (tra_mle_trp routine) + USE ldftra ! Eddy Induced transport (ldf_eiv_trp routine) + USE ldfslp ! Lateral diffusion: slopes of neutral surfaces + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE diaptr ! Poleward heat transport + ! + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE prtctl ! Print control + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv ! called by step.F90 + PUBLIC tra_adv_init ! called by nemogcm.F90 + + ! !!* Namelist namtra_adv * + LOGICAL :: ln_traadv_OFF ! no advection on T and S + LOGICAL :: ln_traadv_cen ! centered scheme flag + INTEGER :: nn_cen_h, nn_cen_v ! =2/4 : horizontal and vertical choices of the order of CEN scheme + LOGICAL :: ln_traadv_fct ! FCT scheme flag + INTEGER :: nn_fct_h, nn_fct_v ! =2/4 : horizontal and vertical choices of the order of FCT scheme + LOGICAL :: ln_traadv_mus ! MUSCL scheme flag + LOGICAL :: ln_mus_ups ! use upstream scheme in vivcinity of river mouths + LOGICAL :: ln_traadv_ubs ! UBS scheme flag + INTEGER :: nn_ubs_v ! =2/4 : vertical choice of the order of UBS scheme + LOGICAL :: ln_traadv_qck ! QUICKEST scheme flag + + INTEGER, PUBLIC :: nadv ! choice of the type of advection scheme + ! ! associated indices: + INTEGER, PARAMETER, PUBLIC :: np_NO_adv = 0 ! no T-S advection + INTEGER, PARAMETER, PUBLIC :: np_CEN = 1 ! 2nd/4th order centered scheme + INTEGER, PARAMETER, PUBLIC :: np_FCT = 2 ! 2nd/4th order Flux Corrected Transport scheme + INTEGER, PARAMETER, PUBLIC :: np_MUS = 3 ! MUSCL scheme + INTEGER, PARAMETER, PUBLIC :: np_UBS = 4 ! 3rd order Upstream Biased Scheme + INTEGER, PARAMETER, PUBLIC :: np_QCK = 5 ! QUICK scheme + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv.F90 15073 2021-07-02 14:20:14Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv( kt, Kbb, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv *** + !! + !! ** Purpose : compute the ocean tracer advection trend. + !! + !! ** Method : - Update (uu(:,:,:,Krhs),vv(:,:,:,Krhs)) with the advection term following nadv + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step index + INTEGER , INTENT(in) :: Kbb, Kmm, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk ! dummy loop index + ! TEMP: [tiling] This change not necessary and can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zuu, zww ! 3D workspace + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zvv + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds + ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + LOGICAL :: lskip + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_adv') + ! + lskip = .FALSE. + + ! TEMP: [tiling] These changes not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + ALLOCATE( zuu(jpi,jpj,jpk), zvv(jpi,jpj,jpk), zww(jpi,jpj,jpk) ) + ENDIF + + ! TEMP: [tiling] These changes not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + IF( ln_tile .AND. nadv == np_FCT ) THEN + IF( ntile == 1 ) THEN + CALL dom_tile_stop( ldhold=.TRUE. ) + ELSE + lskip = .TRUE. + ENDIF + ENDIF + IF( .NOT. lskip ) THEN + ! !== effective transport ==! + IF( ln_wave .AND. ln_sdw ) THEN + DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) + zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * ( uu(ji,jj,jk,Kmm) + usd(ji,jj,jk) ) + zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * ( vv(ji,jj,jk,Kmm) + vsd(ji,jj,jk) ) + END_3D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + zww(ji,jj,jk) = e1e2t(ji,jj) * ( ww(ji,jj,jk) + wsd(ji,jj,jk) ) + END_3D + ELSE + DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) + zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) ! eulerian transport only + zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) + END_3D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + zww(ji,jj,jk) = e1e2t(ji,jj) * ww(ji,jj,jk) + END_3D + ENDIF + ! + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections + DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) + zuu(ji,jj,jk) = zuu(ji,jj,jk) + un_td(ji,jj,jk) + zvv(ji,jj,jk) = zvv(ji,jj,jk) + vn_td(ji,jj,jk) + END_3D + ENDIF + ! + DO_2D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + zuu(ji,jj,jpk) = 0._wp ! no transport trough the bottom + zvv(ji,jj,jpk) = 0._dp + zww(ji,jj,jpk) = 0._wp + END_2D + ! + IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad ) & + & CALL ldf_eiv_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm, Krhs ) ! add the eiv transport (if necessary) + ! + IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm ) ! add the mle transport (if necessary) + ! + ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + CALL iom_put( "uocetr_eff", zuu ) ! output effective transport + CALL iom_put( "vocetr_eff", zvv ) + CALL iom_put( "wocetr_eff", zww ) + ENDIF + ! +!!gm ??? + ! TEMP: [tiling] This copy-in not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + CALL dia_ptr( kt, Kmm, REAL(zvv(A2D(nn_hls),:),wp) ) ! diagnose the effective MSF +!!gm ??? + ! + + IF( l_trdtra ) THEN !* Save ta and sa trends + ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) + ENDIF + ! + SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! + ! + CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order + CALL tra_adv_cen ( kt, nit000, 'TRA', zuu, REAL(zvv,wp), zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v ) + CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order + CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, REAL(zvv,wp), zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) + CASE ( np_MUS ) ! MUSCL + CALL tra_adv_mus( kt, nit000, 'TRA', rDt, zuu, REAL(zvv,wp), zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) + CASE ( np_UBS ) ! UBS + CALL tra_adv_ubs ( kt, nit000, 'TRA', rDt, zuu, REAL(zvv,wp), zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v ) + CASE ( np_QCK ) ! QUICKEST + CALL tra_adv_qck ( kt, nit000, 'TRA', rDt, zuu, REAL(zvv,wp), zww, Kbb, Kmm, pts, jpts, Krhs ) + ! + END SELECT + ! + IF( l_trdtra ) THEN ! save the advective trends for further diagnostics + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = pts(:,:,jk,jp_tem,Krhs) - ztrdt(:,:,jk) + ztrds(:,:,jk) = pts(:,:,jk,jp_sal,Krhs) - ztrds(:,:,jk) + END DO + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_totad, ztrdt ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_totad, ztrds ) + DEALLOCATE( ztrdt, ztrds ) + ENDIF + + ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + IF( ln_tile .AND. .NOT. l_istiled ) CALL dom_tile_start( ldhold=.TRUE. ) + ENDIF + ! ! print mean trends (used for debugging) + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv - Ta: ', mask1=tmask, & + & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + + ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only for the full domain + DEALLOCATE( zuu, zvv, zww ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop( 'tra_adv' ) + ! + END SUBROUTINE tra_adv + + + SUBROUTINE tra_adv_init + !!--------------------------------------------------------------------- + !! *** ROUTINE tra_adv_init *** + !! + !! ** Purpose : Control the consistency between namelist options for + !! tracer advection schemes and set nadv + !!---------------------------------------------------------------------- + INTEGER :: ioptio, ios ! Local integers + ! + NAMELIST/namtra_adv/ ln_traadv_OFF, & ! No advection + & ln_traadv_cen , nn_cen_h, nn_cen_v, & ! CEN + & ln_traadv_fct , nn_fct_h, nn_fct_v, & ! FCT + & ln_traadv_mus , ln_mus_ups, & ! MUSCL + & ln_traadv_ubs , nn_ubs_v, & ! UBS + & ln_traadv_qck ! QCK + !!---------------------------------------------------------------------- + ! + ! !== Namelist ==! + READ ( numnam_ref, namtra_adv, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_adv in reference namelist' ) + ! + READ ( numnam_cfg, namtra_adv, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_adv in configuration namelist' ) + IF(lwm) WRITE( numond, namtra_adv ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) + WRITE(numout,*) 'tra_adv_init : choice/control of the tracer advection scheme' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namtra_adv : chose a advection scheme for tracers' + WRITE(numout,*) ' No advection on T & S ln_traadv_OFF = ', ln_traadv_OFF + WRITE(numout,*) ' centered scheme ln_traadv_cen = ', ln_traadv_cen + WRITE(numout,*) ' horizontal 2nd/4th order nn_cen_h = ', nn_fct_h + WRITE(numout,*) ' vertical 2nd/4th order nn_cen_v = ', nn_fct_v + WRITE(numout,*) ' Flux Corrected Transport scheme ln_traadv_fct = ', ln_traadv_fct + WRITE(numout,*) ' horizontal 2nd/4th order nn_fct_h = ', nn_fct_h + WRITE(numout,*) ' vertical 2nd/4th order nn_fct_v = ', nn_fct_v + WRITE(numout,*) ' MUSCL scheme ln_traadv_mus = ', ln_traadv_mus + WRITE(numout,*) ' + upstream scheme near river mouths ln_mus_ups = ', ln_mus_ups + WRITE(numout,*) ' UBS scheme ln_traadv_ubs = ', ln_traadv_ubs + WRITE(numout,*) ' vertical 2nd/4th order nn_ubs_v = ', nn_ubs_v + WRITE(numout,*) ' QUICKEST scheme ln_traadv_qck = ', ln_traadv_qck + ENDIF + ! + ! !== Parameter control & set nadv ==! + ioptio = 0 + IF( ln_traadv_OFF ) THEN ; ioptio = ioptio + 1 ; nadv = np_NO_adv ; ENDIF + IF( ln_traadv_cen ) THEN ; ioptio = ioptio + 1 ; nadv = np_CEN ; ENDIF + IF( ln_traadv_fct ) THEN ; ioptio = ioptio + 1 ; nadv = np_FCT ; ENDIF + IF( ln_traadv_mus ) THEN ; ioptio = ioptio + 1 ; nadv = np_MUS ; ENDIF + IF( ln_traadv_ubs ) THEN ; ioptio = ioptio + 1 ; nadv = np_UBS ; ENDIF + IF( ln_traadv_qck ) THEN ; ioptio = ioptio + 1 ; nadv = np_QCK ; ENDIF + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'tra_adv_init: Choose ONE advection option in namelist namtra_adv' ) + ! + IF( ln_traadv_cen .AND. ( nn_cen_h /= 2 .AND. nn_cen_h /= 4 ) & ! Centered + .AND. ( nn_cen_v /= 2 .AND. nn_cen_v /= 4 ) ) THEN + CALL ctl_stop( 'tra_adv_init: CEN scheme, choose 2nd or 4th order' ) + ENDIF + IF( ln_traadv_fct .AND. ( nn_fct_h /= 2 .AND. nn_fct_h /= 4 ) & ! FCT + .AND. ( nn_fct_v /= 2 .AND. nn_fct_v /= 4 ) ) THEN + CALL ctl_stop( 'tra_adv_init: FCT scheme, choose 2nd or 4th order' ) + ENDIF + ! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + IF( ln_traadv_fct .AND. ln_tile ) THEN + CALL ctl_warn( 'tra_adv_init: FCT scheme does not yet work with tiling' ) + ENDIF + IF( ln_traadv_ubs .AND. ( nn_ubs_v /= 2 .AND. nn_ubs_v /= 4 ) ) THEN ! UBS + CALL ctl_stop( 'tra_adv_init: UBS scheme, choose 2nd or 4th order' ) + ENDIF + IF( ln_traadv_ubs .AND. nn_ubs_v == 4 ) THEN + CALL ctl_warn( 'tra_adv_init: UBS scheme, only 2nd FCT scheme available on the vertical. It will be used' ) + ENDIF + IF( ln_isfcav ) THEN ! ice-shelf cavities + IF( ln_traadv_cen .AND. nn_cen_v == 4 .OR. & ! NO 4th order with ISF + & ln_traadv_fct .AND. nn_fct_v == 4 ) CALL ctl_stop( 'tra_adv_init: 4th order COMPACT scheme not allowed with ISF' ) + ENDIF + ! + ! !== Print the choice ==! + IF(lwp) THEN + WRITE(numout,*) + SELECT CASE ( nadv ) + CASE( np_NO_adv ) ; WRITE(numout,*) ' ==>>> NO T-S advection' + CASE( np_CEN ) ; WRITE(numout,*) ' ==>>> CEN scheme is used. Horizontal order: ', nn_cen_h, & + & ' Vertical order: ', nn_cen_v + CASE( np_FCT ) ; WRITE(numout,*) ' ==>>> FCT scheme is used. Horizontal order: ', nn_fct_h, & + & ' Vertical order: ', nn_fct_v + CASE( np_MUS ) ; WRITE(numout,*) ' ==>>> MUSCL scheme is used' + CASE( np_UBS ) ; WRITE(numout,*) ' ==>>> UBS scheme is used' + CASE( np_QCK ) ; WRITE(numout,*) ' ==>>> QUICKEST scheme is used' + END SELECT + ENDIF + ! + CALL tra_mle_init !== initialisation of the Mixed Layer Eddy parametrisation (MLE) ==! + ! + END SUBROUTINE tra_adv_init + + !!====================================================================== +END MODULE traadv diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_cen.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_cen.F90 new file mode 100644 index 0000000..c17aeff --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_cen.F90 @@ -0,0 +1,196 @@ +MODULE traadv_cen + !!====================================================================== + !! *** MODULE traadv_cen *** + !! Ocean tracers: advective trend (2nd/4th order centered) + !!====================================================================== + !! History : 3.7 ! 2014-05 (G. Madec) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_cen : update the tracer trend with the advection trends using a centered or scheme (2nd or 4th order) + !! NB: on the vertical it is actually a 4th order COMPACT scheme which is used + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE eosbn2 ! equation of state + USE traadv_fct ! acces to routine interp_4th_cpt + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + ! + USE in_out_manager ! I/O manager + USE iom ! IOM library + USE trc_oce ! share passive tracers/Ocean variables + USE lib_mpp ! MPP library +#if defined key_loop_fusion + USE traadv_cen_lf ! centered scheme (tra_adv_cen routine - loop fusion version) +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_cen ! called by traadv.F90 + + REAL(wp) :: r1_6 = 1._wp / 6._wp ! =1/6 + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat/salt transport + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_cen.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_cen( kt, kit000, cdtype, pU, pV, pW, & + & Kmm, pt, kjpt, Krhs, kn_cen_h, kn_cen_v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_cen *** + !! + !! ** Purpose : Compute the now trend due to the advection of tracers + !! and add it to the general trend of passive tracer equations. + !! + !! ** Method : The advection is evaluated by a 2nd or 4th order scheme + !! using now fields (leap-frog scheme). + !! kn_cen_h = 2 ==>> 2nd order centered scheme on the horizontal + !! = 4 ==>> 4th order - - - - + !! kn_cen_v = 2 ==>> 2nd order centered scheme on the vertical + !! = 4 ==>> 4th order COMPACT scheme - - + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - poleward advective heat and salt transport (l_diaptr=T) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kn_cen_h ! =2/4 (2nd or 4th order scheme) + INTEGER , INTENT(in ) :: kn_cen_v ! =2/4 (2nd or 4th order scheme) + ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: ierr ! local integer + REAL(wp) :: zC2t_u, zC4t_u ! local scalars + REAL(wp) :: zC2t_v, zC4t_v ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zwy, zwz, ztu, ztv, ztw + !!---------------------------------------------------------------------- + ! +#if defined key_loop_fusion + CALL tra_adv_cen_lf ( kt, nit000, cdtype, pU, pV, pW, Kmm, pt, kjpt, Krhs, kn_cen_h, kn_cen_v ) +#else + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_adv_cen : centered advection scheme on ', cdtype, ' order h/v =', kn_cen_h,'/', kn_cen_v + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + ! ! set local switches + l_trd = .FALSE. + l_hst = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ENDIF + ! + ! + zwz(:,:, 1 ) = 0._wp ! surface & bottom vertical flux set to zero for all tracers + zwz(:,:,jpk) = 0._wp + ! + DO jn = 1, kjpt !== loop over the tracers ==! + ! + SELECT CASE( kn_cen_h ) !-- Horizontal fluxes --! + ! + CASE( 2 ) !* 2nd order centered + DO_3D( 1, 0, 1, 0, 1, jpkm1 ) + zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ) + zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) ) + END_3D + ! + CASE( 4 ) !* 4th order centered + ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero + ztv(:,:,jpk) = 0._wp + DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) ! masked gradient + ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) + ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) + END_3D + IF (nn_hls==1) CALL lbc_lnk( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp, ld4only= .TRUE. ) ! Lateral boundary cond. + ! + DO_3D( nn_hls-1, 0, nn_hls-1, 0, 1, jpkm1 ) ! Horizontal advective fluxes + zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! C2 interpolation of T at u- & v-points (x2) + zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) + ! ! C4 interpolation of T at u- & v-points (x2) + zC4t_u = zC2t_u + r1_6 * ( ztu(ji-1,jj,jk) - ztu(ji+1,jj,jk) ) + zC4t_v = zC2t_v + r1_6 * ( ztv(ji,jj-1,jk) - ztv(ji,jj+1,jk) ) + ! ! C4 fluxes + zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * zC4t_u + zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v + END_3D + IF (nn_hls==1) CALL lbc_lnk( 'traadv_cen', zwx, 'U', -1._wp , zwy, 'V', -1._wp ) + ! + CASE DEFAULT + CALL ctl_stop( 'traadv_cen: wrong value for nn_cen' ) + END SELECT + ! + SELECT CASE( kn_cen_v ) !-- Vertical fluxes --! (interior) + ! + CASE( 2 ) !* 2nd order centered + DO_3D( 0, 0, 0, 0, 2, jpk ) + zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) * wmask(ji,jj,jk) + END_3D + ! + CASE( 4 ) !* 4th order compact + CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! ztw = interpolated value of T at w-point + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + zwz(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) + END_3D + ! + END SELECT + ! + IF( ln_linssh ) THEN !* top value (linear free surf. only as zwz is multiplied by wmask) + IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) + DO_2D( 1, 1, 1, 1 ) + zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) + END_2D + ELSE ! no ice-shelf cavities (only ocean surface) + DO_2D( 1, 1, 1, 1 ) + zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) + END_2D + ENDIF + ENDIF + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- Divergence of advective fluxes --! + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) & + & - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & + & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & + & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + ! ! trend diagnostics + IF( l_trd ) THEN + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kmm) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kmm) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) ) + ENDIF + ! ! "Poleward" heat and salt transports + IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) + ! ! heat and salt transport + IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) ) + ! + END DO + ! +#endif + END SUBROUTINE tra_adv_cen + + !!====================================================================== +END MODULE traadv_cen diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_cen_lf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_cen_lf.F90 new file mode 100644 index 0000000..1ca56d6 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_cen_lf.F90 @@ -0,0 +1,188 @@ +MODULE traadv_cen_lf + !!====================================================================== + !! *** MODULE traadv_cen *** + !! Ocean tracers: advective trend (2nd/4th order centered) + !!====================================================================== + !! History : 3.7 ! 2014-05 (G. Madec) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_cen : update the tracer trend with the advection trends using a centered or scheme (2nd or 4th order) + !! NB: on the vertical it is actually a 4th order COMPACT scheme which is used + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE eosbn2 ! equation of state + USE traadv_fct ! acces to routine interp_4th_cpt + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + ! + USE in_out_manager ! I/O manager + USE iom ! IOM library + USE trc_oce ! share passive tracers/Ocean variables + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_cen_lf ! called by traadv.F90 + + REAL(wp) :: r1_6 = 1._wp / 6._wp ! =1/6 + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat/salt transport + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_cen.F90 14776 2021-04-30 12:33:41Z mocavero $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_cen_lf( kt, kit000, cdtype, pU, pV, pW, & + & Kmm, pt, kjpt, Krhs, kn_cen_h, kn_cen_v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_cen *** + !! + !! ** Purpose : Compute the now trend due to the advection of tracers + !! and add it to the general trend of passive tracer equations. + !! + !! ** Method : The advection is evaluated by a 2nd or 4th order scheme + !! using now fields (leap-frog scheme). + !! kn_cen_h = 2 ==>> 2nd order centered scheme on the horizontal + !! = 4 ==>> 4th order - - - - + !! kn_cen_v = 2 ==>> 2nd order centered scheme on the vertical + !! = 4 ==>> 4th order COMPACT scheme - - + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - poleward advective heat and salt transport (l_diaptr=T) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kn_cen_h ! =2/4 (2nd or 4th order scheme) + INTEGER , INTENT(in ) :: kn_cen_v ! =2/4 (2nd or 4th order scheme) + ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: ierr ! local integer + REAL(wp) :: zC2t_u, zC4t_u ! local scalars + REAL(wp) :: zC2t_v, zC4t_v ! - - + REAL(wp) :: ztu_im1, ztu_ip1 ! - - + REAL(wp) :: ztv_jm1, ztv_jp1 ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zwy, zwz, ztw + !!---------------------------------------------------------------------- + ! + IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_adv_cen : centered advection scheme on ', cdtype, ' order h/v =', kn_cen_h,'/', kn_cen_v + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ ' + ENDIF + ! ! set local switches + l_trd = .FALSE. + l_hst = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ENDIF + ! + ! + zwz(:,:, 1 ) = 0._wp ! surface & bottom vertical flux set to zero for all tracers + zwz(:,:,jpk) = 0._wp + ! + DO jn = 1, kjpt !== loop over the tracers ==! + ! + SELECT CASE( kn_cen_h ) !-- Horizontal fluxes --! + ! + CASE( 2 ) !* 2nd order centered + DO_3D( 1, 0, 1, 0, 1, jpkm1 ) + zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ) + zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) ) + END_3D + ! + CASE( 4 ) !* 4th order centered + DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! Horizontal advective fluxes + ztu_im1 = ( pt(ji,jj ,jk,jn,Kmm) - pt(ji-1,jj,jk,jn,Kmm) ) * umask(ji-1,jj,jk) + ztu_ip1 = ( pt(ji+2,jj ,jk,jn,Kmm) - pt(ji+1,jj,jk,jn,Kmm) ) * umask(ji+1,jj,jk) + ztv_jm1 = ( pt(ji,jj,jk,jn,Kmm) - pt(ji,jj-1,jk,jn,Kmm) ) * vmask(ji,jj-1,jk) + ztv_jp1 = ( pt(ji,jj+2,jk,jn,Kmm) - pt(ji,jj+1,jk,jn,Kmm) ) * vmask(ji,jj+1,jk) + ! + zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! C2 interpolation of T at u- & v-points (x2) + zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) + ! ! C4 interpolation of T at u- & v-points (x2) + zC4t_u = zC2t_u + r1_6 * ( ztu_im1 - ztu_ip1 ) + zC4t_v = zC2t_v + r1_6 * ( ztv_jm1 - ztv_jp1 ) + ! ! C4 fluxes + zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * zC4t_u + zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v + END_3D + ! + CASE DEFAULT + CALL ctl_stop( 'traadv_cen: wrong value for nn_cen' ) + END SELECT + ! + SELECT CASE( kn_cen_v ) !-- Vertical fluxes --! (interior) + ! + CASE( 2 ) !* 2nd order centered + DO_3D( 0, 0, 0, 0, 2, jpk ) + zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) * wmask(ji,jj,jk) + END_3D + ! + CASE( 4 ) !* 4th order compact + CALL interp_4th_cpt( CASTDP(pt(:,:,:,jn,Kmm)) , ztw ) ! ztw = interpolated value of T at w-point + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + zwz(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) + END_3D + ! + END SELECT + ! + IF( ln_linssh ) THEN !* top value (linear free surf. only as zwz is multiplied by wmask) + IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) + DO_2D( 1, 1, 1, 1 ) + zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) + END_2D + ELSE ! no ice-shelf cavities (only ocean surface) + DO_2D( 1, 1, 1, 1 ) + zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) + END_2D + ENDIF + ENDIF + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- Divergence of advective fluxes --! + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) & + & - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & + & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & + & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + ! ! trend diagnostics + IF( l_trd ) THEN + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, CASTDP(pt(:,:,:,jn,Kmm)) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, CASTDP(pt(:,:,:,jn,Kmm)) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, CASTDP(pt(:,:,:,jn,Kmm)) ) + ENDIF + ! ! "Poleward" heat and salt transports + IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) + ! ! heat and salt transport + IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) ) + ! + END DO + ! + END SUBROUTINE tra_adv_cen_lf + + !!====================================================================== +END MODULE traadv_cen_lf \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_fct.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_fct.F90 new file mode 100644 index 0000000..d7168df --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_fct.F90 @@ -0,0 +1,1011 @@ +MODULE traadv_fct + !!============================================================================== + !! *** MODULE traadv_fct *** + !! Ocean tracers: horizontal & vertical advective trend (2nd/4th order Flux Corrected Transport method) + !!============================================================================== + !! History : 3.7 ! 2015-09 (L. Debreu, G. Madec) original code (inspired from traadv_tvd.F90) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_fct : update the tracer trend with a 3D advective trends using a 2nd or 4th order FCT scheme + !! with sub-time-stepping in the vertical direction + !! nonosc : compute monotonic tracer fluxes by a non-oscillatory algorithm + !! interp_4th_cpt : 4th order compact scheme for the vertical component of the advection + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE trc_oce ! share passive tracers/Ocean variables + USE trd_oce ! trends: ocean variables + USE trdtra ! tracers trends + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + USE phycst , ONLY : rho0_rcp + USE zdf_oce , ONLY : ln_zad_Aimp + ! + USE in_out_manager ! I/O manager + USE iom ! + USE lib_mpp ! MPP library + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_fct ! called by traadv.F90 + PUBLIC interp_4th_cpt ! called by traadv_cen.F90 + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat/salt transport + REAL(wp) :: r1_6 = 1._wp / 6._wp ! =1/6 + + ! ! tridiag solver associated indices: + INTEGER, PARAMETER :: np_NH = 0 ! Neumann homogeneous boundary condition + INTEGER, PARAMETER :: np_CEN2 = 1 ! 2nd order centered boundary condition + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_fct.F90 14857 2021-05-12 16:47:25Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_fct( kt, kit000, cdtype, p2dt, pU, pV, pW, & + & Kbb, Kmm, pt, kjpt, Krhs, kn_fct_h, kn_fct_v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_fct *** + !! + !! ** Purpose : Compute the now trend due to total advection of tracers + !! and add it to the general trend of tracer equations + !! + !! ** Method : - 2nd or 4th FCT scheme on the horizontal direction + !! (choice through the value of kn_fct) + !! - on the vertical the 4th order is a compact scheme + !! - corrected flux (monotonic correction) + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostics (l_trdtra=T) + !! - poleward advective heat and salt transport (ln_diaptr=T) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kn_fct_h ! order of the FCT scheme (=2 or 4) + INTEGER , INTENT(in ) :: kn_fct_v ! order of the FCT scheme (=2 or 4) + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra ! local scalar + REAL(wp) :: zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u ! - - + REAL(wp) :: zfm_ui, zfm_vj, zfm_wk, zC2t_v, zC4t_v ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwz, ztu, ztv, zltu, zltv, ztw + REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zwy + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zwinf, zwdia, zwsup + LOGICAL :: ll_zAimp ! flag to apply adaptive implicit vertical advection + !!---------------------------------------------------------------------- + ! +#if defined key_loop_fusion + CALL tra_adv_fct_lf ( kt, nit000, cdtype, p2dt, pU, pV, pW, Kbb, Kmm, pt, kjpt, Krhs, kn_fct_h, kn_fct_v ) +#else + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_adv_fct : FCT advection scheme on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + l_trd = .FALSE. ! set local switches + l_hst = .FALSE. + l_ptr = .FALSE. + ll_zAimp = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ! + ENDIF + + !! -- init to 0 + zwi(:,:,:) = 0._wp + zwx(:,:,:) = 0._wp + zwy(:,:,:) = 0._wp + zwz(:,:,:) = 0._wp + ztu(:,:,:) = 0._wp + ztv(:,:,:) = 0._wp + zltu(:,:,:) = 0._wp + zltv(:,:,:) = 0._wp + ztw(:,:,:) = 0._wp + ! + IF( l_trd .OR. l_hst ) THEN + ALLOCATE( ztrdx(A2D(nn_hls),jpk), ztrdy(A2D(nn_hls),jpk), ztrdz(A2D(nn_hls),jpk) ) + ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp + ENDIF + ! + IF( l_ptr ) THEN + ALLOCATE( zptry(A2D(nn_hls),jpk) ) + zptry(:,:,:) = 0._wp + ENDIF + ! + ! If adaptive vertical advection, check if it is needed on this PE at this time + IF( ln_zad_Aimp ) THEN + IF( MAXVAL( ABS( wi(A2D(1),:) ) ) > 0._wp ) ll_zAimp = .TRUE. + END IF + ! If active adaptive vertical advection, build tridiagonal matrix + IF( ll_zAimp ) THEN + ALLOCATE(zwdia(A2D(nn_hls),jpk), zwinf(A2D(nn_hls),jpk), zwsup(A2D(nn_hls),jpk)) + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + zwdia(ji,jj,jk) = 1._wp + p2dt * ( MAX( wi(ji,jj,jk) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) & + & / e3t(ji,jj,jk,Krhs) + zwinf(ji,jj,jk) = p2dt * MIN( wi(ji,jj,jk ) , 0._wp ) / e3t(ji,jj,jk,Krhs) + zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / e3t(ji,jj,jk,Krhs) + END_3D + END IF + ! + DO jn = 1, kjpt !== loop over the tracers ==! + ! + ! !== upstream advection with initial mass fluxes & intermediate update ==! + ! !* upstream tracer flux in the i and j direction + DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) + ! upstream scheme + zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) + zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) + zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) + zfm_vj = pV(ji,jj,jk) - ABS( pV(ji,jj,jk) ) + zwx(ji,jj,jk) = 0.5 * ( zfp_ui * pt(ji,jj,jk,jn,Kbb) + zfm_ui * pt(ji+1,jj ,jk,jn,Kbb) ) + zwy(ji,jj,jk) = 0.5 * ( zfp_vj * pt(ji,jj,jk,jn,Kbb) + zfm_vj * pt(ji ,jj+1,jk,jn,Kbb) ) + END_3D + ! !* upstream tracer flux in the k direction *! + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Interior value ( multiplied by wmask) + zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) + zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) + zwz(ji,jj,jk) = 0.5 * ( zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb) ) * wmask(ji,jj,jk) + END_3D + IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as zwz has been w-masked) + IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface + END_2D + ELSE ! no cavities: only at the ocean surface + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) + END_2D + ENDIF + ENDIF + ! + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) !* trend and after field with monotonic scheme + ! ! total intermediate advective trends + ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & + & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & + & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) + ! ! update and guess with monotonic sheme + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra & + & / e3t(ji,jj,jk,Kmm ) * tmask(ji,jj,jk) + zwi(ji,jj,jk) = ( e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) + p2dt * ztra ) & + & / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) + END_3D + + IF ( ll_zAimp ) THEN + CALL tridia_solver( zwdia, zwsup, zwinf, zwi, zwi , 0 ) + ! + ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Interior value ( multiplied by wmask) + zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) + zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) + ztw(ji,jj,jk) = 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) + zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! update vertical fluxes + END_3D + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + ! + END IF + ! + IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes) + ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:) + END IF + ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) + IF( l_ptr ) zptry(:,:,:) = zwy(:,:,:) + ! + ! !== anti-diffusive flux : high order minus low order ==! + ! + SELECT CASE( kn_fct_h ) !* horizontal anti-diffusive fluxes + ! + CASE( 2 ) !- 2nd order centered + DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) + zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj,jk,jn,Kmm) ) - zwx(ji,jj,jk) + zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj+1,jk,jn,Kmm) ) - zwy(ji,jj,jk) + END_3D + ! + CASE( 4 ) !- 4th order centered + zltu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero + zltv(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 ! Laplacian + DO_2D( 1, 0, 1, 0 ) ! 1st derivative (gradient) + ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) + ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) + END_2D + DO_2D( 0, 0, 0, 0 ) ! 2nd derivative * 1/ 6 + zltu(ji,jj,jk) = ( ztu(ji,jj,jk) + ztu(ji-1,jj,jk) ) * r1_6 + zltv(ji,jj,jk) = ( ztv(ji,jj,jk) + ztv(ji,jj-1,jk) ) * r1_6 + END_2D + END DO + ! NOTE [ comm_cleanup ] : need to change sign to ensure halo 1 - halo 2 compatibility + CALL lbc_lnk( 'traadv_fct', zltu, 'T', -1.0_wp , zltv, 'T', -1.0_wp, ld4only= .TRUE. ) ! Lateral boundary cond. (unchanged sgn) + ! + DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) + zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points + zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) + ! ! C4 minus upstream advective fluxes + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( zC2t_u + ( zltu(ji,jj,jk) - zltu(ji+1,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) - zwx(ji,jj,jk) + zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( zC2t_v + ( zltv(ji,jj,jk) - zltv(ji,jj+1,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) - zwy(ji,jj,jk) + END_3D + ! + CASE( 41 ) !- 4th order centered ==>> !!gm coding attempt need to be tested + ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero + ztv(:,:,jpk) = 0._wp + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) ! 1st derivative (gradient) + ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) + ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) + END_3D + IF (nn_hls==1) CALL lbc_lnk( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp, ld4only= .TRUE. ) ! Lateral boundary cond. (unchanged sgn) + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes + zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points (x2) + zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) + ! ! C4 interpolation of T at u- & v-points (x2) + zC4t_u = zC2t_u + r1_6 * ( ztu(ji-1,jj ,jk) - ztu(ji+1,jj ,jk) ) + zC4t_v = zC2t_v + r1_6 * ( ztv(ji ,jj-1,jk) - ztv(ji ,jj+1,jk) ) + ! ! C4 minus upstream advective fluxes + zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * zC4t_u - zwx(ji,jj,jk) + zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) + END_3D + IF (nn_hls==2) CALL lbc_lnk( 'traadv_fct', zwx, 'U', -1.0_dp , zwy, 'V', -1.0_dp ) ! Lateral boundary cond. (unchanged sgn) + ! + END SELECT + ! + SELECT CASE( kn_fct_v ) !* vertical anti-diffusive fluxes (w-masked interior values) + ! + CASE( 2 ) !- 2nd order centered + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + zwz(ji,jj,jk) = ( pW(ji,jj,jk) * 0.5_wp * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) & + & - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) + END_3D + ! + CASE( 4 ) !- 4th order COMPACT + CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! zwt = COMPACT interpolation of T at w-point + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + zwz(ji,jj,jk) = ( pW(ji,jj,jk) * ztw(ji,jj,jk) - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) + END_3D + ! + END SELECT + IF( ln_linssh ) THEN ! top ocean value: high order = upstream ==>> zwz=0 + zwz(:,:,1) = 0._wp ! only ocean surface as interior zwz values have been w-masked + ENDIF + ! + IF (nn_hls==1) THEN + CALL lbc_lnk( 'traadv_fct', zwx, 'U', -1.0_dp , zwy, 'V', -1.0_dp) + CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp , zwz, 'T', 1.0_wp ) + ELSE + CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp) + END IF + ! + IF ( ll_zAimp ) THEN + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) !* trend and after field with monotonic scheme + ! ! total intermediate advective trends + ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & + & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & + & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) + ztw(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) + END_3D + ! + CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) + ! + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Interior value ( multiplied by wmask) + zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) + zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) + zwz(ji,jj,jk) = zwz(ji,jj,jk) + 0.5 * e1e2t(ji,jj) * ( zfp_wk * ztw(ji,jj,jk) + zfm_wk * ztw(ji,jj,jk-1) ) * wmask(ji,jj,jk) + END_3D + END IF + ! + ! !== monotonicity algorithm ==! + ! + CALL nonosc( Kmm, pt(:,:,:,jn,Kbb), zwx, zwy, zwz, zwi, p2dt ) + ! + ! !== final trend with corrected fluxes ==! + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & + & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & + & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra / e3t(ji,jj,jk,Kmm) + zwi(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) + END_3D + ! + IF ( ll_zAimp ) THEN + ! + ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask) + zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) + zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) + ztw(ji,jj,jk) = - 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) + zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! Update vertical fluxes for trend diagnostic + END_3D + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + END IF + IF( l_trd .OR. l_hst ) THEN ! trend diagnostics // heat/salt transport + ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< add anti-diffusive fluxes + ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! to upstream fluxes + ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! + ! + IF( l_trd ) THEN ! trend diagnostics + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztrdx, pU, pt(:,:,:,jn,Kmm) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, ztrdy, pV, pt(:,:,:,jn,Kmm) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, ztrdz, pW, pt(:,:,:,jn,Kmm) ) + ENDIF + ! ! heat/salt transport + IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztrdx(:,:,:), ztrdy(:,:,:) ) + ! + ENDIF + IF( l_ptr ) THEN ! "Poleward" transports + zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< add anti-diffusive fluxes + CALL dia_ptr_hst( jn, 'adv', zptry(:,:,:) ) + ENDIF + ! + END DO ! end of tracer loop + ! + IF ( ll_zAimp ) THEN + DEALLOCATE( zwdia, zwinf, zwsup ) + ENDIF + IF( l_trd .OR. l_hst ) THEN + DEALLOCATE( ztrdx, ztrdy, ztrdz ) + ENDIF + IF( l_ptr ) THEN + DEALLOCATE( zptry ) + ENDIF + ! +#endif + END SUBROUTINE tra_adv_fct + + + SUBROUTINE nonosc( Kmm, pbef, paa, pbb, pcc, paft, p2dt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE nonosc *** + !! + !! ** Purpose : compute monotonic tracer fluxes from the upstream + !! scheme and the before field by a nonoscillatory algorithm + !! + !! ** Method : ... ??? + !! warning : pbef and paft must be masked, but the boundaries + !! conditions on the fluxes are not necessary zalezak (1979) + !! drange (1995) multi-dimensional forward-in-time and upstream- + !! in-space based differencing for fluid + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pbef ! before field + REAL(wp), DIMENSION(A2D(nn_hls) ,jpk), INTENT(in ) :: paft ! after field + REAL(wp), DIMENSION(A2D(nn_hls) ,jpk), INTENT(inout) :: pcc! monotonic fluxes in the 3 directions + REAL(dp), DIMENSION(A2D(nn_hls) ,jpk), INTENT(inout) :: paa, pbb! monotonic fluxes in the 3 directions + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikm1 ! local integer + REAL(dp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars + REAL(dp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - - + REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo, zbup, zbdo + !!---------------------------------------------------------------------- + ! + zbig = 1.e+40_dp + zrtrn = 1.e-15_dp + zbetup(:,:,:) = 0._dp ; zbetdo(:,:,:) = 0._dp + + ! Search local extrema + ! -------------------- + ! max/min of pbef & paft with large negative/positive value (-/+zbig) inside land + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) + zbup(ji,jj,jk) = MAX( pbef(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1._wp - tmask(ji,jj,jk) ), & + & paft(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1._wp - tmask(ji,jj,jk) ) ) + zbdo(ji,jj,jk) = MIN( pbef(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1._wp - tmask(ji,jj,jk) ), & + & paft(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1._wp - tmask(ji,jj,jk) ) ) + END_3D + + DO jk = 1, jpkm1 + ikm1 = MAX(jk-1,1) + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + + ! search maximum in neighbourhood + zup = MAX( zbup(ji ,jj ,jk ), & + & zbup(ji-1,jj ,jk ), zbup(ji+1,jj ,jk ), & + & zbup(ji ,jj-1,jk ), zbup(ji ,jj+1,jk ), & + & zbup(ji ,jj ,ikm1), zbup(ji ,jj ,jk+1) ) + + ! search minimum in neighbourhood + zdo = MIN( zbdo(ji ,jj ,jk ), & + & zbdo(ji-1,jj ,jk ), zbdo(ji+1,jj ,jk ), & + & zbdo(ji ,jj-1,jk ), zbdo(ji ,jj+1,jk ), & + & zbdo(ji ,jj ,ikm1), zbdo(ji ,jj ,jk+1) ) + + ! positive part of the flux + zpos = MAX( 0., paa(ji-1,jj ,jk ) ) - MIN( 0., paa(ji ,jj ,jk ) ) & + & + MAX( 0., pbb(ji ,jj-1,jk ) ) - MIN( 0., pbb(ji ,jj ,jk ) ) & + & + MAX( 0., pcc(ji ,jj ,jk+1) ) - MIN( 0., pcc(ji ,jj ,jk ) ) + + ! negative part of the flux + zneg = MAX( 0., paa(ji ,jj ,jk ) ) - MIN( 0., paa(ji-1,jj ,jk ) ) & + & + MAX( 0., pbb(ji ,jj ,jk ) ) - MIN( 0., pbb(ji ,jj-1,jk ) ) & + & + MAX( 0., pcc(ji ,jj ,jk ) ) - MIN( 0., pcc(ji ,jj ,jk+1) ) + + ! up & down beta terms + zbt = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) / p2dt + zbetup(ji,jj,jk) = ( zup - paft(ji,jj,jk) ) / ( zpos + zrtrn ) * zbt + zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zdo ) / ( zneg + zrtrn ) * zbt + END_2D + END DO + IF (nn_hls==1) CALL lbc_lnk( 'traadv_fct', zbetup, 'T', 1.0_dp , zbetdo, 'T', 1.0_dp, ld4only= .TRUE. ) ! lateral boundary cond. (unchanged sign) + + ! 3. monotonic flux in the i & j direction (paa & pbb) + ! ---------------------------------------- + DO_3D( 1, 0, 1, 0, 1, jpkm1 ) + zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) + zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) + zcu = ( 0.5 + SIGN( 0.5_wp , paa(ji,jj,jk) ) ) + paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu ) + + zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) + zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) + zcv = ( 0.5 + SIGN( 0.5_wp , pbb(ji,jj,jk) ) ) + pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) + + ! monotonic flux in the k direction, i.e. pcc + ! ------------------------------------------- + za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) + zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) + zc = ( 0.5 + SIGN( 0.5_wp , pcc(ji,jj,jk+1) ) ) + pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) + END_3D + ! + END SUBROUTINE nonosc + + + SUBROUTINE interp_4th_cpt_org( pt_in, pt_out ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp_4th_cpt_org *** + !! + !! ** Purpose : Compute the interpolation of tracer at w-point + !! + !! ** Method : 4th order compact interpolation + !!---------------------------------------------------------------------- + REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pt_in ! now tracer fields + REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT( out) :: pt_out ! now tracer field interpolated at w-pts + ! + INTEGER :: ji, jj, jk ! dummy loop integers + REAL(wp),DIMENSION(jpi,jpj,jpk) :: zwd, zwi, zws, zwrm, zwt + !!---------------------------------------------------------------------- + + DO_3D( 1, 1, 1, 1, 3, jpkm1 ) !== build the three diagonal matrix ==! + zwd (ji,jj,jk) = 4._wp + zwi (ji,jj,jk) = 1._wp + zws (ji,jj,jk) = 1._wp + zwrm(ji,jj,jk) = 3._wp * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) + ! + IF( tmask(ji,jj,jk+1) == 0._wp) THEN ! Switch to second order centered at bottom + zwd (ji,jj,jk) = 1._wp + zwi (ji,jj,jk) = 0._wp + zws (ji,jj,jk) = 0._wp + zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) + ENDIF + END_3D + ! + jk = 2 ! Switch to second order centered at top + DO_2D( 1, 1, 1, 1 ) + zwd (ji,jj,jk) = 1._wp + zwi (ji,jj,jk) = 0._wp + zws (ji,jj,jk) = 0._wp + zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) + END_2D + ! + ! !== tridiagonal solve ==! + DO_2D( 1, 1, 1, 1 ) ! first recurrence + zwt(ji,jj,2) = zwd(ji,jj,2) + END_2D + DO_3D( 1, 1, 1, 1, 3, jpkm1 ) + zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) + END_3D + ! + DO_2D( 1, 1, 1, 1 ) ! second recurrence: Zk = Yk - Ik / Tk-1 Zk-1 + pt_out(ji,jj,2) = zwrm(ji,jj,2) + END_2D + DO_3D( 1, 1, 1, 1, 3, jpkm1 ) + pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) + END_3D + + DO_2D( 1, 1, 1, 1 ) ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk + pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) + END_2D + DO_3DS( 1, 1, 1, 1, jpk-2, 2, -1 ) + pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) + END_3D + ! + END SUBROUTINE interp_4th_cpt_org + + + SUBROUTINE interp_4th_cpt( pt_in, pt_out ) + !!---------------------------------------------------------------------- + !! *** ROUTINE interp_4th_cpt *** + !! + !! ** Purpose : Compute the interpolation of tracer at w-point + !! + !! ** Method : 4th order compact interpolation + !!---------------------------------------------------------------------- + REAL(dp),DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pt_in ! field at t-point + REAL(wp),DIMENSION(A2D(nn_hls) ,jpk), INTENT( out) :: pt_out ! field interpolated at w-point + ! + INTEGER :: ji, jj, jk ! dummy loop integers + INTEGER :: ikt, ikb ! local integers + REAL(wp),DIMENSION(A2D(nn_hls),jpk) :: zwd, zwi, zws, zwrm, zwt + !!---------------------------------------------------------------------- + ! + ! !== build the three diagonal matrix & the RHS ==! + ! + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 3, jpkm1 ) ! interior (from jk=3 to jpk-1) + zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp ! diagonal + zwi (ji,jj,jk) = wmask(ji,jj,jk) ! lower diagonal + zws (ji,jj,jk) = wmask(ji,jj,jk) ! upper diagonal + zwrm(ji,jj,jk) = 3._wp * wmask(ji,jj,jk) & ! RHS + & * ( pt_in(ji,jj,jk) + pt_in(ji,jj,jk-1) ) + END_3D + ! +!!gm +! SELECT CASE( kbc ) !* boundary condition +! CASE( np_NH ) ! Neumann homogeneous at top & bottom +! CASE( np_CEN2 ) ! 2nd order centered at top & bottom +! END SELECT +!!gm + ! + IF ( ln_isfcav ) THEN ! set level two values which may not be set in ISF case + zwd(:,:,2) = 1._wp ; zwi(:,:,2) = 0._wp ; zws(:,:,2) = 0._wp ; zwrm(:,:,2) = 0._wp + END IF + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! 2nd order centered at top & bottom + ikt = mikt(ji,jj) + 1 ! w-point below the 1st wet point + ikb = MAX(mbkt(ji,jj), 2) ! - above the last wet point + ! + zwd (ji,jj,ikt) = 1._wp ! top + zwi (ji,jj,ikt) = 0._wp + zws (ji,jj,ikt) = 0._wp + zwrm(ji,jj,ikt) = 0.5_wp * ( pt_in(ji,jj,ikt-1) + pt_in(ji,jj,ikt) ) + ! + zwd (ji,jj,ikb) = 1._wp ! bottom + zwi (ji,jj,ikb) = 0._wp + zws (ji,jj,ikb) = 0._wp + zwrm(ji,jj,ikb) = 0.5_wp * ( pt_in(ji,jj,ikb-1) + pt_in(ji,jj,ikb) ) + END_2D + ! + ! !== tridiagonal solver ==! + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 + zwt(ji,jj,2) = zwd(ji,jj,2) + END_2D + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 3, jpkm1 ) + zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) + END_3D + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 + pt_out(ji,jj,2) = zwrm(ji,jj,2) + END_2D + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 3, jpkm1 ) + pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) + END_3D + + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk + pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) + END_2D + DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpk-2, 2, -1 ) + pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) + END_3D + ! + END SUBROUTINE interp_4th_cpt + + + SUBROUTINE tridia_solver( pD, pU, pL, pRHS, pt_out , klev ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tridia_solver *** + !! + !! ** Purpose : solve a symmetric 3diagonal system + !! + !! ** Method : solve M.t_out = RHS(t) where M is a tri diagonal matrix ( jpk*jpk ) + !! + !! ( D_1 U_1 0 0 0 )( t_1 ) ( RHS_1 ) + !! ( L_2 D_2 U_2 0 0 )( t_2 ) ( RHS_2 ) + !! ( 0 L_3 D_3 U_3 0 )( t_3 ) = ( RHS_3 ) + !! ( ... )( ... ) ( ... ) + !! ( 0 0 0 L_k D_k )( t_k ) ( RHS_k ) + !! + !! M is decomposed in the product of an upper and lower triangular matrix. + !! The tri-diagonals matrix is given as input 3D arrays: pD, pU, pL + !! (i.e. the Diagonal, the Upper diagonal, and the Lower diagonal). + !! The solution is pta. + !! The 3d array zwt is used as a work space array. + !!---------------------------------------------------------------------- + REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pD, pU, pL ! 3-diagonal matrix + REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pRHS ! Right-Hand-Side + REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT( out) :: pt_out !!gm field at level=F(klev) + INTEGER , INTENT(in ) :: klev ! =1 pt_out at w-level + ! ! =0 pt at t-level + INTEGER :: ji, jj, jk ! dummy loop integers + INTEGER :: kstart ! local indices + REAL(wp),DIMENSION(A2D(nn_hls),jpk) :: zwt ! 3D work array + !!---------------------------------------------------------------------- + ! + kstart = 1 + klev + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 + zwt(ji,jj,kstart) = pD(ji,jj,kstart) + END_2D + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, kstart+1, jpkm1 ) + zwt(ji,jj,jk) = pD(ji,jj,jk) - pL(ji,jj,jk) * pU(ji,jj,jk-1) /zwt(ji,jj,jk-1) + END_3D + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 + pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) + END_2D + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, kstart+1, jpkm1 ) + pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) + END_3D + + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk + pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) + END_2D + DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpk-2, kstart, -1 ) + pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - pU(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) + END_3D + ! + END SUBROUTINE tridia_solver + +#if defined key_loop_fusion +#define tracer_flux_i(out,zfp,zfm,ji,jj,jk) \ + zfp = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) ; \ + zfm = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) ; \ + out = 0.5 * ( zfp * pt(ji,jj,jk,jn,Kbb) + zfm * pt(ji+1,jj,jk,jn,Kbb) ) + +#define tracer_flux_j(out,zfp,zfm,ji,jj,jk) \ + zfp = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) ; \ + zfm = pV(ji,jj,jk) - ABS( pV(ji,jj,jk) ) ; \ + out = 0.5 * ( zfp * pt(ji,jj,jk,jn,Kbb) + zfm * pt(ji,jj+1,jk,jn,Kbb) ) + + SUBROUTINE tra_adv_fct_lf( kt, kit000, cdtype, p2dt, pU, pV, pW, & + & Kbb, Kmm, pt, kjpt, Krhs, kn_fct_h, kn_fct_v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_fct *** + !! + !! ** Purpose : Compute the now trend due to total advection of tracers + !! and add it to the general trend of tracer equations + !! + !! ** Method : - 2nd or 4th FCT scheme on the horizontal direction + !! (choice through the value of kn_fct) + !! - on the vertical the 4th order is a compact scheme + !! - corrected flux (monotonic correction) + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostics (l_trdtra=T) + !! - poleward advective heat and salt transport (ln_diaptr=T) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kn_fct_h ! order of the FCT scheme (=2 or 4) + INTEGER , INTENT(in ) :: kn_fct_v ! order of the FCT scheme (=2 or 4) + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra ! local scalar + REAL(wp) :: zwx_im1, zfp_ui, zfp_ui_m1, zfp_vj, zfp_vj_m1, zfp_wk, zC2t_u, zC4t_u ! - - + REAL(wp) :: zwy_jm1, zfm_ui, zfm_ui_m1, zfm_vj, zfm_vj_m1, zfm_wk, zC2t_v, zC4t_v ! - - + REAL(wp) :: ztu, ztv, ztu_im1, ztu_ip1, ztv_jm1, ztv_jp1 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwi, zwx_3d, zwy_3d, zwz, ztw, zltu_3d, zltv_3d + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zwinf, zwdia, zwsup + LOGICAL :: ll_zAimp ! flag to apply adaptive implicit vertical advection + !!---------------------------------------------------------------------- + ! + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_adv_fct_lf : FCT advection scheme on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + !! -- init to 0 + zwx_3d(:,:,:) = 0._wp + zwy_3d(:,:,:) = 0._wp + zwz(:,:,:) = 0._wp + zwi(:,:,:) = 0._wp + ! + l_trd = .FALSE. ! set local switches + l_hst = .FALSE. + l_ptr = .FALSE. + ll_zAimp = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ! + IF( l_trd .OR. l_hst ) THEN + ALLOCATE( ztrdx(jpi,jpj,jpk), ztrdy(jpi,jpj,jpk), ztrdz(jpi,jpj,jpk) ) + ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp + ENDIF + ! + IF( l_ptr ) THEN + ALLOCATE( zptry(jpi,jpj,jpk) ) + zptry(:,:,:) = 0._wp + ENDIF + ! + ! If adaptive vertical advection, check if it is needed on this PE at this time + IF( ln_zad_Aimp ) THEN + IF( MAXVAL( ABS( wi(:,:,:) ) ) > 0._wp ) ll_zAimp = .TRUE. + END IF + ! If active adaptive vertical advection, build tridiagonal matrix + IF( ll_zAimp ) THEN + ALLOCATE(zwdia(jpi,jpj,jpk), zwinf(jpi,jpj,jpk),zwsup(jpi,jpj,jpk)) + DO_3D( 1, 1, 1, 1, 1, jpkm1 ) + zwdia(ji,jj,jk) = 1._wp + p2dt * ( MAX( wi(ji,jj,jk) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) & + & / e3t(ji,jj,jk,Krhs) + zwinf(ji,jj,jk) = p2dt * MIN( wi(ji,jj,jk ) , 0._wp ) / e3t(ji,jj,jk,Krhs) + zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / e3t(ji,jj,jk,Krhs) + END_3D + END IF + ! + DO jn = 1, kjpt !== loop over the tracers ==! + ! + ! !== upstream advection with initial mass fluxes & intermediate update ==! + ! !* upstream tracer flux in the k direction *! + DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! Interior value ( multiplied by wmask) + zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) + zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) + zwz(ji,jj,jk) = 0.5 * ( zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb) ) * wmask(ji,jj,jk) + END_3D + IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as zwz has been w-masked) + IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface + DO_2D( 1, 1, 1, 1 ) + zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface + END_2D + ELSE ! no cavities: only at the ocean surface + DO_2D( 1, 1, 1, 1 ) + zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) + END_2D + ENDIF + ENDIF + ! + ! !* upstream tracer flux in the i and j direction + DO jk = 1, jpkm1 + DO jj = 1, jpj-1 + tracer_flux_i(zwx_3d(1,jj,jk),zfp_ui,zfm_ui,1,jj,jk) + tracer_flux_j(zwy_3d(1,jj,jk),zfp_vj,zfm_vj,1,jj,jk) + END DO + DO ji = 1, jpi-1 + tracer_flux_i(zwx_3d(ji,1,jk),zfp_ui,zfm_ui,ji,1,jk) + tracer_flux_j(zwy_3d(ji,1,jk),zfp_vj,zfm_vj,ji,1,jk) + END DO + DO_2D( 1, 1, 1, 1 ) + tracer_flux_i(zwx_3d(ji,jj,jk),zfp_ui,zfm_ui,ji,jj,jk) + tracer_flux_i(zwx_im1,zfp_ui_m1,zfm_ui_m1,ji-1,jj,jk) + tracer_flux_j(zwy_3d(ji,jj,jk),zfp_vj,zfm_vj,ji,jj,jk) + tracer_flux_j(zwy_jm1,zfp_vj_m1,zfm_vj_m1,ji,jj-1,jk) + ztra = - ( zwx_3d(ji,jj,jk) - zwx_im1 + zwy_3d(ji,jj,jk) - zwy_jm1 + zwz(ji,jj,jk) - zwz(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) + ! ! update and guess with monotonic sheme + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra & + & / e3t(ji,jj,jk,Kmm ) * tmask(ji,jj,jk) + zwi(ji,jj,jk) = ( e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) + p2dt * ztra ) & + & / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) + END_2D + END DO + + IF ( ll_zAimp ) THEN + CALL tridia_solver( zwdia, zwsup, zwinf, zwi, zwi , 0 ) + ! + ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; + DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! Interior value ( multiplied by wmask) + zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) + zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) + ztw(ji,jj,jk) = 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) + zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! update vertical fluxes + END_3D + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + ! + END IF + ! + IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes) + ztrdx(:,:,:) = zwx_3d(:,:,:) ; ztrdy(:,:,:) = zwy_3d(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:) + END IF + ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) + IF( l_ptr ) zptry(:,:,:) = zwy_3d(:,:,:) + ! + ! !== anti-diffusive flux : high order minus low order ==! + ! + SELECT CASE( kn_fct_h ) !* horizontal anti-diffusive fluxes + ! + CASE( 2 ) !- 2nd order centered + DO_3D( 2, 1, 2, 1, 1, jpkm1 ) + zwx_3d(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj,jk,jn,Kmm) ) - zwx_3d(ji,jj,jk) + zwy_3d(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj+1,jk,jn,Kmm) ) - zwy_3d(ji,jj,jk) + END_3D + ! + CASE( 4 ) !- 4th order centered + zltu_3d(:,:,jpk) = 0._wp ! Bottom value : flux set to zero + zltv_3d(:,:,jpk) = 0._wp + ! ! Laplacian + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! 2nd derivative * 1/ 6 + ! ! 1st derivative (gradient) + ztu = ( pt(ji+1,jj,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) + ztu_im1 = ( pt(ji,jj,jk,jn,Kmm) - pt(ji-1,jj,jk,jn,Kmm) ) * umask(ji-1,jj,jk) + ztv = ( pt(ji,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) + ztv_jm1 = ( pt(ji,jj,jk,jn,Kmm) - pt(ji,jj-1,jk,jn,Kmm) ) * vmask(ji,jj-1,jk) + ! ! 2nd derivative * 1/ 6 + zltu_3d(ji,jj,jk) = ( ztu + ztu_im1 ) * r1_6 + zltv_3d(ji,jj,jk) = ( ztv + ztv_jm1 ) * r1_6 + END_2D + END DO + ! NOTE [ comm_cleanup ] : need to change sign to ensure halo 1 - halo 2 compatibility + CALL lbc_lnk( 'traadv_fct', zltu_3d, 'T', -1.0_wp , zltv_3d, 'T', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) + ! + DO_3D( 2, 1, 2, 1, 1, jpkm1 ) + zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points + zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) + ! ! C4 minus upstream advective fluxes + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zwx_3d(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( zC2t_u + ( zltu_3d(ji,jj,jk) - zltu_3d(ji+1,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) - zwx_3d(ji,jj,jk) + zwy_3d(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( zC2t_v + ( zltv_3d(ji,jj,jk) - zltv_3d(ji,jj+1,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) - zwy_3d(ji,jj,jk) + END_3D + ! + CASE( 41 ) !- 4th order centered ==>> !!gm coding attempt need to be tested + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes + ztu_im1 = ( pt(ji ,jj ,jk,jn,Kmm) - pt(ji-1,jj,jk,jn,Kmm) ) * umask(ji-1,jj,jk) + ztu_ip1 = ( pt(ji+2,jj ,jk,jn,Kmm) - pt(ji+1,jj,jk,jn,Kmm) ) * umask(ji+1,jj,jk) + + ztv_jm1 = ( pt(ji,jj ,jk,jn,Kmm) - pt(ji,jj-1,jk,jn,Kmm) ) * vmask(ji,jj-1,jk) + ztv_jp1 = ( pt(ji,jj+2,jk,jn,Kmm) - pt(ji,jj+1,jk,jn,Kmm) ) * vmask(ji,jj+1,jk) + zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points (x2) + zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) + ! ! C4 interpolation of T at u- & v-points (x2) + zC4t_u = zC2t_u + r1_6 * ( ztu_im1 - ztu_ip1 ) + zC4t_v = zC2t_v + r1_6 * ( ztv_jm1 - ztv_jp1 ) + ! ! C4 minus upstream advective fluxes + zwx_3d(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * zC4t_u - zwx_3d(ji,jj,jk) + zwy_3d(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy_3d(ji,jj,jk) + END_3D + CALL lbc_lnk( 'traadv_fct', zwx_3d, 'U', -1.0_wp , zwy_3d, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) + ! + END SELECT + ! + SELECT CASE( kn_fct_v ) !* vertical anti-diffusive fluxes (w-masked interior values) + ! + CASE( 2 ) !- 2nd order centered + DO_3D( 1, 1, 1, 1, 2, jpkm1 ) + zwz(ji,jj,jk) = ( pW(ji,jj,jk) * 0.5_wp * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) & + & - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) + END_3D + ! + CASE( 4 ) !- 4th order COMPACT + CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! zwt = COMPACT interpolation of T at w-point + DO_3D( 1, 1, 1, 1, 2, jpkm1 ) + zwz(ji,jj,jk) = ( pW(ji,jj,jk) * ztw(ji,jj,jk) - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) + END_3D + ! + END SELECT + IF( ln_linssh ) THEN ! top ocean value: high order = upstream ==>> zwz=0 + zwz(:,:,1) = 0._wp ! only ocean surface as interior zwz values have been w-masked + ENDIF + ! + CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp) + ! + IF ( ll_zAimp ) THEN + DO_3D( 1, 1, 1, 1, 1, jpkm1 ) !* trend and after field with monotonic scheme + ! ! total intermediate advective trends + ztra = - ( zwx_3d(ji,jj,jk) - zwx_3d(ji-1,jj ,jk ) & + & + zwy_3d(ji,jj,jk) - zwy_3d(ji ,jj-1,jk ) & + & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) + ztw(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) + END_3D + ! + CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) + ! + DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! Interior value ( multiplied by wmask) + zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) + zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) + zwz(ji,jj,jk) = zwz(ji,jj,jk) + 0.5 * e1e2t(ji,jj) * ( zfp_wk * ztw(ji,jj,jk) + zfm_wk * ztw(ji,jj,jk-1) ) * wmask(ji,jj,jk) + END_3D + END IF + ! + ! !== monotonicity algorithm ==! + ! + CALL nonosc( Kmm, pt(:,:,:,jn,Kbb), zwx_3d, zwy_3d, zwz, zwi, p2dt ) + ! + ! !== final trend with corrected fluxes ==! + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + ztra = - ( zwx_3d(ji,jj,jk) - zwx_3d(ji-1,jj ,jk ) & + & + zwy_3d(ji,jj,jk) - zwy_3d(ji ,jj-1,jk ) & + & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra / e3t(ji,jj,jk,Kmm) + zwi(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) + END_3D + ! + IF ( ll_zAimp ) THEN + ! + ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask) + zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) + zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) + ztw(ji,jj,jk) = - 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) + zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! Update vertical fluxes for trend diagnostic + END_3D + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + END IF + ! NOT TESTED - NEED l_trd OR l_hst TRUE + IF( l_trd .OR. l_hst ) THEN ! trend diagnostics // heat/salt transport + ztrdx(:,:,:) = ztrdx(:,:,:) + zwx_3d(:,:,:) ! <<< add anti-diffusive fluxes + ztrdy(:,:,:) = ztrdy(:,:,:) + zwy_3d(:,:,:) ! to upstream fluxes + ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! + ! + IF( l_trd ) THEN ! trend diagnostics + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztrdx, pU, pt(:,:,:,jn,Kmm) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, ztrdy, pV, pt(:,:,:,jn,Kmm) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, ztrdz, pW, pt(:,:,:,jn,Kmm) ) + ENDIF + ! ! heat/salt transport + IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztrdx(:,:,:), ztrdy(:,:,:) ) + ! + ENDIF + ! NOT TESTED - NEED l_ptr TRUE + IF( l_ptr ) THEN ! "Poleward" transports + zptry(:,:,:) = zptry(:,:,:) + zwy_3d(:,:,:) ! <<< add anti-diffusive fluxes + CALL dia_ptr_hst( jn, 'adv', zptry(:,:,:) ) + ENDIF + ! + END DO ! end of tracer loop + ! + IF ( ll_zAimp ) THEN + DEALLOCATE( zwdia, zwinf, zwsup ) + ENDIF + IF( l_trd .OR. l_hst ) THEN + DEALLOCATE( ztrdx, ztrdy, ztrdz ) + ENDIF + IF( l_ptr ) THEN + DEALLOCATE( zptry ) + ENDIF + ! + END SUBROUTINE tra_adv_fct_lf +#endif + !!====================================================================== +END MODULE traadv_fct diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_mus.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_mus.F90 new file mode 100644 index 0000000..51c28b6 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_mus.F90 @@ -0,0 +1,245 @@ +MODULE traadv_mus + !!====================================================================== + !! *** MODULE traadv_mus *** + !! Ocean tracers: horizontal & vertical advective trend + !!====================================================================== + !! History : ! 2000-06 (A.Estublier) for passive tracers + !! ! 2001-08 (E.Durand, G.Madec) adapted for T & S + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.2 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport + !! 3.4 ! 2012-06 (P. Oddo, M. Vichi) include the upstream where needed + !! 3.7 ! 2015-09 (G. Madec) add the ice-shelf cavities boundary condition + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_mus : update the tracer trend with the horizontal + !! and vertical advection trends using MUSCL scheme + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE trc_oce ! share passive tracers/Ocean variables + USE dom_oce ! ocean space and time domain + USE trd_oce ! trends: ocean variables + USE trdtra ! tracers trends manager + USE sbcrnf ! river runoffs + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + + ! + USE iom ! XIOS library + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_mus ! routine called by traadv.F90 + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits + ! ! and in closed seas (orca 2 and 1 configurations) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xind !: mixed upstream/centered index + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat/salt transport + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_mus.F90 15139 2021-07-23 12:52:21Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_mus( kt, kit000, cdtype, p2dt, pU, pV, pW, & + & Kbb, Kmm, pt, kjpt, Krhs, ld_msc_ups ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_mus *** + !! + !! ** Purpose : Compute the now trend due to total advection of tracers + !! using a MUSCL scheme (Monotone Upstream-centered Scheme for + !! Conservation Laws) and add it to the general tracer trend. + !! + !! ** Method : MUSCL scheme plus centered scheme at ocean boundaries + !! ld_msc_ups=T : + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - poleward advective heat and salt transport (ln_diaptr=T) + !! + !! References : Estubier, A., and M. Levy, Notes Techn. Pole de Modelisation + !! IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + LOGICAL , INTENT(in ) :: ld_msc_ups ! use upstream scheme within muscl + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: ierr ! local integer + REAL(wp) :: zu, z0u, zzwx, zw , zalpha ! local scalars + REAL(wp) :: zv, z0v, zzwy, z0w ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zslpx ! 3D workspace + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zslpy ! - - + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_adv : MUSCL advection scheme on ', cdtype + IF(lwp) WRITE(numout,*) ' : mixed up-stream ', ld_msc_ups + IF(lwp) WRITE(numout,*) '~~~~~~~' + IF(lwp) WRITE(numout,*) + ! + ! Upstream / MUSCL scheme indicator + ! + ALLOCATE( xind(jpi,jpj,jpk), STAT=ierr ) + xind(:,:,:) = 1._wp ! set equal to 1 where up-stream is not needed + ! + IF( ld_msc_ups ) THEN ! define the upstream indicator (if asked) + ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) + upsmsk(:,:) = 0._wp ! not upstream by default + ! + DO jk = 1, jpkm1 + xind(:,:,jk) = 1._wp & ! =>1 where up-stream is not needed + & - MAX ( rnfmsk(:,:) * rnfmsk_z(jk), & ! =>0 near runoff mouths (& closed sea outflows) + & upsmsk(:,:) ) * tmask(:,:,jk) ! =>0 in some user defined area + END DO + ENDIF + ! + ENDIF + ! + l_trd = .FALSE. + l_hst = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ENDIF + ! + DO jn = 1, kjpt !== loop over the tracers ==! + ! + ! !* Horizontal advective fluxes + ! + ! !-- first guess of the slopes + zwx(:,:,jpk) = 0._wp ! bottom values + zwy(:,:,jpk) = 0._wp + DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) + zwx(ji,jj,jk) = umask(ji,jj,jk) * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) + zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( pt(ji,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) + END_3D + ! !-- Slopes of tracer + zslpx(:,:,jpk) = 0._wp ! bottom values + zslpy(:,:,jpk) = 0._wp + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji-1,jj ,jk) ) & + & * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji-1,jj ,jk) ) ) + zslpy(ji,jj,jk) = ( zwy(ji,jj,jk) + zwy(ji ,jj-1,jk) ) & + & * ( 0.25 + SIGN( 0.25_wp, zwy(ji,jj,jk) * zwy(ji ,jj-1,jk) ) ) + END_3D + ! + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) !-- Slopes limitation + zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji ,jj,jk) ), & + & 2.*ABS( zwx (ji-1,jj,jk) ), & + & 2.*ABS( zwx (ji ,jj,jk) ) ) + zslpy(ji,jj,jk) = SIGN( 1.0_wp, zslpy(ji,jj,jk) ) * MIN( ABS( zslpy(ji,jj ,jk) ), & + & 2.*ABS( zwy (ji,jj-1,jk) ), & + & 2.*ABS( zwy (ji,jj ,jk) ) ) + END_3D + ! NOTE [ comm_cleanup ] : need to change sign to ensure halo 1 - halo 2 compatibility + IF ( nn_hls==1 ) CALL lbc_lnk( 'traadv_mus', zslpx, 'T', -1.0_wp , zslpy, 'T', -1.0_wp ) ! lateral boundary conditions (changed sign) + ! + DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !-- MUSCL horizontal advective fluxes + ! MUSCL fluxes + z0u = SIGN( 0.5_wp, pU(ji,jj,jk) ) + zalpha = 0.5 - z0u + zu = z0u - 0.5 * pU(ji,jj,jk) * p2dt * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) + zzwx = pt(ji+1,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj,jk) + zzwy = pt(ji ,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji ,jj,jk) + zwx(ji,jj,jk) = pU(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) + ! + z0v = SIGN( 0.5_wp, pV(ji,jj,jk) ) + zalpha = 0.5 - z0v + zv = z0v - 0.5 * pV(ji,jj,jk) * p2dt * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) + zzwx = pt(ji,jj+1,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1,jk) + zzwy = pt(ji,jj ,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj ,jk) + zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) + END_3D + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- Tracer advective trend + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & + & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + ! ! trend diagnostics + IF( l_trd ) THEN + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kbb) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kbb) ) + END IF + ! ! "Poleward" heat and salt transports + IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) + ! ! heat transport + IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', zwx(:,:,:), zwy(:,:,:) ) + ! + ! !* Vertical advective fluxes + ! + ! !-- first guess of the slopes + zwx(:,:, 1 ) = 0._wp ! surface & bottom boundary conditions + zwx(:,:,jpk) = 0._wp + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! interior values + zwx(ji,jj,jk) = tmask(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) + END_3D + ! !-- Slopes of tracer + zslpx(:,:,1) = 0._wp ! surface values + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) ) & + & * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) + END_3D + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !-- Slopes limitation + zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji,jj,jk ) ), & + & 2.*ABS( zwx (ji,jj,jk+1) ), & + & 2.*ABS( zwx (ji,jj,jk ) ) ) + END_3D + DO_3D( 0, 0, 0, 0, 1, jpk-2 ) !-- vertical advective flux + z0w = SIGN( 0.5_wp, pW(ji,jj,jk+1) ) + zalpha = 0.5 + z0w + zw = z0w - 0.5 * pW(ji,jj,jk+1) * p2dt * r1_e1e2t(ji,jj) / e3w(ji,jj,jk+1,Kmm) + zzwx = pt(ji,jj,jk+1,jn,Kbb) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1) + zzwy = pt(ji,jj,jk ,jn,Kbb) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk ) + zwx(ji,jj,jk+1) = pW(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) * wmask(ji,jj,jk) + END_3D + IF( ln_linssh ) THEN ! top values, linear free surface only + IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) + DO_2D( 0, 0, 0, 0 ) + zwx(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) + END_2D + ELSE ! no cavities: only at the ocean surface + DO_2D( 0, 0, 0, 0 ) + zwx(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) + END_2D + ENDIF + ENDIF + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- vertical advective trend + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + ! ! send trends for diagnostic + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwx, pW, pt(:,:,:,jn,Kbb) ) + ! + END DO ! end of tracer loop + ! + END SUBROUTINE tra_adv_mus + + !!====================================================================== +END MODULE traadv_mus \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_qck.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_qck.F90 new file mode 100644 index 0000000..b1e5783 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_qck.F90 @@ -0,0 +1,407 @@ +MODULE traadv_qck + !!============================================================================== + !! *** MODULE traadv_qck *** + !! Ocean tracers: horizontal & vertical advective trend + !!============================================================================== + !! History : 3.0 ! 2008-07 (G. Reffray) Original code + !! 3.3 ! 2010-05 (C.Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_qck : update the tracer trend with the horizontal advection + !! trends using a 3rd order finite difference scheme + !! tra_adv_qck_i : apply QUICK scheme in i-direction + !! tra_adv_qck_j : apply QUICK scheme in j-direction + !! tra_adv_cen2_k : 2nd centered scheme for the vertical advection + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE trc_oce ! share passive tracers/Ocean variables + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE diaptr ! poleward transport diagnostics + USE iom + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) +#if defined key_loop_fusion + USE traadv_qck_lf ! QCK scheme (tra_adv_qck routine - loop fusion version) +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_qck ! routine called by step.F90 + + REAL(wp) :: r1_6 = 1./ 6. ! 1/6 ratio + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_qck.F90 14978 2021-06-11 13:21:08Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_qck ( kt, kit000, cdtype, p2dt, pU, pV, pW, Kbb, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_qck *** + !! + !! ** Purpose : Compute the now trend due to the advection of tracers + !! and add it to the general trend of passive tracer equations. + !! + !! ** Method : The advection is evaluated by a third order scheme + !! For a positive velocity u : u(i)>0 + !! |--FU--|--FC--|--FD--|------| + !! i-1 i i+1 i+2 + !! + !! For a negative velocity u : u(i)<0 + !! |------|--FD--|--FC--|--FU--| + !! i-1 i i+1 i+2 + !! where FU is the second upwind point + !! FD is the first douwning point + !! FC is the central point (or the first upwind point) + !! + !! Flux(i) = u(i) * { 0.5(FC+FD) -0.5C(i)(FD-FC) -((1-C(i))/6)(FU+FD-2FC) } + !! with C(i)=|u(i)|dx(i)/dt (=Courant number) + !! + !! dt = 2*rdtra and the scalar values are tb and sb + !! + !! On the vertical, the simple centered scheme used pt(:,:,:,:,Kmm) + !! + !! The fluxes are bounded by the ULTIMATE limiter to + !! guarantee the monotonicity of the solution and to + !! prevent the appearance of spurious numerical oscillations + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - poleward advective heat and salt transport (ln_diaptr=T) + !! + !! ** Reference : Leonard (1979, 1991) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + !!---------------------------------------------------------------------- + ! +#if defined key_loop_fusion + CALL tra_adv_qck_lf ( kt, kit000, cdtype, p2dt, pU, pV, pW, Kbb, Kmm, pt, kjpt, Krhs ) +#else + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_adv_qck : 3rd order quickest advection scheme on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) + ENDIF + ! + l_trd = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + ENDIF + ! + ! ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme + CALL tra_adv_qck_i( kt, cdtype, p2dt, pU, Kbb, Kmm, pt, kjpt, Krhs ) + CALL tra_adv_qck_j( kt, cdtype, p2dt, pV, Kbb, Kmm, pt, kjpt, Krhs ) + + ! ! vertical fluxes are computed with the 2nd order centered scheme + CALL tra_adv_cen2_k( kt, cdtype, pW, Kmm, pt, kjpt, Krhs ) + ! +#endif + END SUBROUTINE tra_adv_qck + + + SUBROUTINE tra_adv_qck_i( kt, cdtype, p2dt, pU, Kbb, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU ! i-velocity components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zfu, zfc, zfd + !---------------------------------------------------------------------- + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + zfu(:,:,:) = 0._wp ; zfc(:,:,:) = 0._wp + zfd(:,:,:) = 0._wp ; zwx(:,:,:) = 0._wp + ! +!!gm why not using a SHIFT instruction... + DO_3D( nn_hls-1, nn_hls-1, 0, 0, 1, jpkm1 ) !--- Computation of the ustream and downstream value of the tracer and the mask + zfc(ji,jj,jk) = pt(ji-1,jj,jk,jn,Kbb) ! Upstream in the x-direction for the tracer + zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb) ! Downstream in the x-direction for the tracer + END_3D + IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, ld4only= .TRUE. ) ! Lateral boundary conditions + + ! + ! Horizontal advective fluxes + ! --------------------------- + DO_3D( nn_hls-1, 0, 0, 0, 1, jpkm1 ) + zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk) ! FU in the x-direction for T + END_3D + ! + DO_3D( nn_hls-1, 0, 0, 0, 1, jpkm1 ) + zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) + zwx(ji,jj,jk) = ABS( pU(ji,jj,jk) ) * p2dt / zdx ! (0 0 : zdir = 1 otherwise zdir = 0 + !--- If the second ustream point is a land point + !--- the flux is computed by the 1st order UPWIND scheme + zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk) + zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) + zwx(ji,jj,jk) = zwx(ji,jj,jk) * pU(ji,jj,jk) + END_3D + ! + ! Computation of the trend + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + ! horizontal advective trends + ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) + !--- add it to the general tracer trends + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra + END_3D + ! ! trend diagnostics + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kmm) ) + ! + END DO + ! + END SUBROUTINE tra_adv_qck_i + + + SUBROUTINE tra_adv_qck_j( kt, cdtype, p2dt, pV, Kbb, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pV ! j-velocity components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zfu, zfc, zfd ! 3D workspace + !---------------------------------------------------------------------- + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + zfu(:,:,:) = 0.0 ; zfc(:,:,:) = 0.0 + zfd(:,:,:) = 0.0 ; zwy(:,:,:) = 0.0 + ! + !--- Computation of the ustream and downstream value of the tracer and the mask + DO_3D( 0, 0, nn_hls-1, nn_hls-1, 1, jpkm1 ) + ! Upstream in the x-direction for the tracer + zfc(ji,jj,jk) = pt(ji,jj-1,jk,jn,Kbb) + ! Downstream in the x-direction for the tracer + zfd(ji,jj,jk) = pt(ji,jj+1,jk,jn,Kbb) + END_3D + + IF (nn_hls==1) CALL lbc_lnk( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, ld4only= .TRUE. ) ! Lateral boundary conditions + + ! Correct zfd on northfold after lbc_lnk; see #2640 + IF( nn_hls == 1 .AND. l_IdoNFold .AND. ntej == Nje0 ) THEN + DO jk = 1, jpkm1 + WHERE( tmask_i(ntsi:ntei,ntej:jpj) == 0._wp ) zfd(ntsi:ntei,ntej:jpj,jk) = zfc(ntsi:ntei,ntej:jpj,jk) + END DO + ENDIF + ! + ! Horizontal advective fluxes + ! --------------------------- + ! + DO_3D( 0, 0, nn_hls-1, 0, 1, jpkm1 ) + zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk) ! FU in the x-direction for T + END_3D + ! + DO_3D( 0, 0, nn_hls-1, 0, 1, jpkm1 ) + zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) + zwy(ji,jj,jk) = ABS( pV(ji,jj,jk) ) * p2dt / zdx ! (0 0 : zdir = 1 otherwise zdir = 0 + !--- If the second ustream point is a land point + !--- the flux is computed by the 1st order UPWIND scheme + zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk) + zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) + zwy(ji,jj,jk) = zwy(ji,jj,jk) * pV(ji,jj,jk) + END_3D + ! + ! Computation of the trend + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + ! horizontal advective trends + ztra = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) + !--- add it to the general tracer trends + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra + END_3D + ! ! trend diagnostics + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kmm) ) + ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) + IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) + ! + END DO + ! + END SUBROUTINE tra_adv_qck_j + + + SUBROUTINE tra_adv_cen2_k( kt, cdtype, pW, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwz ! 3D workspace + !!---------------------------------------------------------------------- + ! + zwz(:,:, 1 ) = 0._wp ! surface & bottom values set to zero for all tracers + zwz(:,:,jpk) = 0._wp + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + ! + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* Interior point (w-masked 2nd order centered flux) + zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kmm) + pt(ji,jj,jk,jn,Kmm) ) * wmask(ji,jj,jk) + END_3D + IF( ln_linssh ) THEN !* top value (only in linear free surf. as zwz is multiplied by wmask) + IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) + DO_2D( 0, 0, 0, 0 ) + zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) ! linear free surface + END_2D + ELSE ! no ocean cavities (only ocean surface) + DO_2D( 0, 0, 0, 0 ) + zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) + END_2D + ENDIF + ENDIF + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Tracer flux divergence added to the general trend ==! + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + ! ! Send trends for diagnostic + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) ) + ! + END DO + ! + END SUBROUTINE tra_adv_cen2_k + + + SUBROUTINE quickest( pfu, pfd, pfc, puc ) + !!---------------------------------------------------------------------- + !! + !! ** Purpose : Computation of advective flux with Quickest scheme + !! + !! ** Method : + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfu ! second upwind point + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfd ! first douwning point + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point) + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcoef1, zcoef2, zcoef3 ! local scalars + REAL(wp) :: zc, zcurv, zfho ! - - + !---------------------------------------------------------------------- + ! + DO_3D( 1, 0, 1, 0, 1, jpkm1 ) + zc = puc(ji,jj,jk) ! Courant number + zcurv = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) + zcoef1 = 0.5 * ( pfc(ji,jj,jk) + pfd(ji,jj,jk) ) + zcoef2 = 0.5 * zc * ( pfd(ji,jj,jk) - pfc(ji,jj,jk) ) + zcoef3 = ( 1. - ( zc * zc ) ) * r1_6 * zcurv + zfho = zcoef1 - zcoef2 - zcoef3 ! phi_f QUICKEST + ! + zcoef1 = pfd(ji,jj,jk) - pfu(ji,jj,jk) + zcoef2 = ABS( zcoef1 ) + zcoef3 = ABS( zcurv ) + IF( zcoef3 >= zcoef2 ) THEN + zfho = pfc(ji,jj,jk) + ELSE + zcoef3 = pfu(ji,jj,jk) + ( ( pfc(ji,jj,jk) - pfu(ji,jj,jk) ) / MAX( zc, 1.e-9 ) ) ! phi_REF + IF( zcoef1 >= 0. ) THEN + zfho = MAX( pfc(ji,jj,jk), zfho ) + zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) ) + ELSE + zfho = MIN( pfc(ji,jj,jk), zfho ) + zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) ) + ENDIF + ENDIF + puc(ji,jj,jk) = zfho + END_3D + ! + END SUBROUTINE quickest + + !!====================================================================== +END MODULE traadv_qck \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_qck_lf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_qck_lf.F90 new file mode 100644 index 0000000..b0f10a9 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_qck_lf.F90 @@ -0,0 +1,375 @@ +MODULE traadv_qck_lf + !!============================================================================== + !! *** MODULE traadv_qck *** + !! Ocean tracers: horizontal & vertical advective trend + !!============================================================================== + !! History : 3.0 ! 2008-07 (G. Reffray) Original code + !! 3.3 ! 2010-05 (C.Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_qck : update the tracer trend with the horizontal advection + !! trends using a 3rd order finite difference scheme + !! tra_adv_qck_i : apply QUICK scheme in i-direction + !! tra_adv_qck_j : apply QUICK scheme in j-direction + !! tra_adv_cen2_k : 2nd centered scheme for the vertical advection + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE trc_oce ! share passive tracers/Ocean variables + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE diaptr ! poleward transport diagnostics + USE iom + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_qck_lf ! routine called by step.F90 + + REAL(wp) :: r1_6 = 1./ 6. ! 1/6 ratio + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_qck.F90 14776 2021-04-30 12:33:41Z mocavero $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_qck_lf ( kt, kit000, cdtype, p2dt, pU, pV, pW, Kbb, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_qck *** + !! + !! ** Purpose : Compute the now trend due to the advection of tracers + !! and add it to the general trend of passive tracer equations. + !! + !! ** Method : The advection is evaluated by a third order scheme + !! For a positive velocity u : u(i)>0 + !! |--FU--|--FC--|--FD--|------| + !! i-1 i i+1 i+2 + !! + !! For a negative velocity u : u(i)<0 + !! |------|--FD--|--FC--|--FU--| + !! i-1 i i+1 i+2 + !! where FU is the second upwind point + !! FD is the first douwning point + !! FC is the central point (or the first upwind point) + !! + !! Flux(i) = u(i) * { 0.5(FC+FD) -0.5C(i)(FD-FC) -((1-C(i))/6)(FU+FD-2FC) } + !! with C(i)=|u(i)|dx(i)/dt (=Courant number) + !! + !! dt = 2*rdtra and the scalar values are tb and sb + !! + !! On the vertical, the simple centered scheme used pt(:,:,:,:,Kmm) + !! + !! The fluxes are bounded by the ULTIMATE limiter to + !! guarantee the monotonicity of the solution and to + !! prevent the appearance of spurious numerical oscillations + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - poleward advective heat and salt transport (ln_diaptr=T) + !! + !! ** Reference : Leonard (1979, 1991) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + !!---------------------------------------------------------------------- + ! + IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_adv_qck : 3rd order quickest advection scheme on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) + ENDIF + ! + l_trd = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + ENDIF + ! + ! ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme + CALL tra_adv_qck_i_lf( kt, cdtype, p2dt, pU, Kbb, Kmm, pt, kjpt, Krhs ) + CALL tra_adv_qck_j_lf( kt, cdtype, p2dt, pV, Kbb, Kmm, pt, kjpt, Krhs ) + + ! ! vertical fluxes are computed with the 2nd order centered scheme + CALL tra_adv_cen2_k_lf( kt, cdtype, pW, Kmm, pt, kjpt, Krhs ) + ! + END SUBROUTINE tra_adv_qck_lf + + + SUBROUTINE tra_adv_qck_i_lf( kt, cdtype, p2dt, pU, Kbb, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU ! i-velocity components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars + REAL(wp) :: zzfc, zzfd, zzfu, zzfu_ip1 ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zfu, zfc, zfd + !---------------------------------------------------------------------- + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + zfu(:,:,:) = 0._wp ; zfc(:,:,:) = 0._wp + zfd(:,:,:) = 0._wp ; zwx(:,:,:) = 0._wp + ! +!!gm why not using a SHIFT instruction... + DO_3D( 1, 0, 0, 0, 1, jpkm1 ) !--- Computation of the ustream and downstream value of the tracer and the mask + zzfc = pt(ji-1,jj,jk,jn,Kbb) ! Upstream in the x-direction for the tracer + zzfd = pt(ji+2,jj,jk,jn,Kbb) ! Downstream in the x-direction for the tracer + ! + ! Horizontal advective fluxes + ! --------------------------- + zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zfu(ji,jj,jk) = zdir * zzfc + ( 1. - zdir ) * zzfd ! FU in the x-direction for T + ! + zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) + zwx(ji,jj,jk) = ABS( pU(ji,jj,jk) ) * p2dt / zdx ! (0 0 : zdir = 1 otherwise zdir = 0 + !--- If the second ustream point is a land point + !--- the flux is computed by the 1st order UPWIND scheme + zmsk = zdir * zzfu + ( 1. - zdir ) * zzfu_ip1 + zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) + zwx(ji,jj,jk) = zwx(ji,jj,jk) * pU(ji,jj,jk) + END_3D + ! + ! Computation of the trend + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + ! horizontal advective trends + ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) + !--- add it to the general tracer trends + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra + END_3D + ! ! trend diagnostics + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, CASTDP(pt(:,:,:,jn,Kmm)) ) + ! + END DO + ! + END SUBROUTINE tra_adv_qck_i_lf + + + SUBROUTINE tra_adv_qck_j_lf( kt, cdtype, p2dt, pV, Kbb, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pV ! j-velocity components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars + REAL(wp) :: zzfc, zzfd, zzfu, zzfu_jp1 ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zfu, zfc, zfd ! 3D workspace + !---------------------------------------------------------------------- + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + zfu(:,:,:) = 0.0 ; zfc(:,:,:) = 0.0 + zfd(:,:,:) = 0.0 ; zwy(:,:,:) = 0.0 + ! + !--- Computation of the ustream and downstream value of the tracer and the mask + DO_3D( 0, 0, 1, 0, 1, jpkm1 ) + ! Upstream in the x-direction for the tracer + zzfc = pt(ji,jj-1,jk,jn,Kbb) + ! Downstream in the x-direction for the tracer + zzfd = pt(ji,jj+2,jk,jn,Kbb) + ! + ! Horizontal advective fluxes + ! --------------------------- + ! + zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zfu(ji,jj,jk) = zdir * zzfc + ( 1. - zdir ) * zzfd ! FU in the x-direction for T + ! + zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 + zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) + zwy(ji,jj,jk) = ABS( pV(ji,jj,jk) ) * p2dt / zdx ! (0 0 : zdir = 1 otherwise zdir = 0 + !--- If the second ustream point is a land point + !--- the flux is computed by the 1st order UPWIND scheme + zmsk = zdir * zzfu + ( 1. - zdir ) * zzfu_jp1 + zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) + zwy(ji,jj,jk) = zwy(ji,jj,jk) * pV(ji,jj,jk) + END_3D + ! + ! Computation of the trend + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + ! horizontal advective trends + ztra = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) + !--- add it to the general tracer trends + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra + END_3D + ! ! trend diagnostics + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, CASTDP(pt(:,:,:,jn,Kmm)) ) + ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) + IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) + ! + END DO + ! + END SUBROUTINE tra_adv_qck_j_lf + + + SUBROUTINE tra_adv_cen2_k_lf( kt, cdtype, pW, Kmm, pt, kjpt, Krhs ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwz ! 3D workspace + !!---------------------------------------------------------------------- + ! + zwz(:,:, 1 ) = 0._wp ! surface & bottom values set to zero for all tracers + zwz(:,:,jpk) = 0._wp + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + ! + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) !* Interior point (w-masked 2nd order centered flux) + zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kmm) + pt(ji,jj,jk,jn,Kmm) ) * wmask(ji,jj,jk) + END_3D + IF( ln_linssh ) THEN !* top value (only in linear free surf. as zwz is multiplied by wmask) + IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) + DO_2D( 0, 0, 0, 0 ) + zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) ! linear free surface + END_2D + ELSE ! no ocean cavities (only ocean surface) + DO_2D( 0, 0, 0, 0 ) + zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) + END_2D + ENDIF + ENDIF + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Tracer flux divergence added to the general trend ==! + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + ! ! Send trends for diagnostic + IF( l_trd ) CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, CASTDP(pt(:,:,:,jn,Kmm)) ) + ! + END DO + ! + END SUBROUTINE tra_adv_cen2_k_lf + + + SUBROUTINE quickest( pfu, pfd, pfc, puc ) + !!---------------------------------------------------------------------- + !! + !! ** Purpose : Computation of advective flux with Quickest scheme + !! + !! ** Method : + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfu ! second upwind point + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfd ! first douwning point + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point) + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcoef1, zcoef2, zcoef3 ! local scalars + REAL(wp) :: zc, zcurv, zfho ! - - + !---------------------------------------------------------------------- + ! + DO_3D( 2, 2, 2, 2, 1, jpkm1 ) + zc = puc(ji,jj,jk) ! Courant number + zcurv = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) + zcoef1 = 0.5 * ( pfc(ji,jj,jk) + pfd(ji,jj,jk) ) + zcoef2 = 0.5 * zc * ( pfd(ji,jj,jk) - pfc(ji,jj,jk) ) + zcoef3 = ( 1. - ( zc * zc ) ) * r1_6 * zcurv + zfho = zcoef1 - zcoef2 - zcoef3 ! phi_f QUICKEST + ! + zcoef1 = pfd(ji,jj,jk) - pfu(ji,jj,jk) + zcoef2 = ABS( zcoef1 ) + zcoef3 = ABS( zcurv ) + IF( zcoef3 >= zcoef2 ) THEN + zfho = pfc(ji,jj,jk) + ELSE + zcoef3 = pfu(ji,jj,jk) + ( ( pfc(ji,jj,jk) - pfu(ji,jj,jk) ) / MAX( zc, 1.e-9 ) ) ! phi_REF + IF( zcoef1 >= 0. ) THEN + zfho = MAX( pfc(ji,jj,jk), zfho ) + zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) ) + ELSE + zfho = MIN( pfc(ji,jj,jk), zfho ) + zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) ) + ENDIF + ENDIF + puc(ji,jj,jk) = zfho + END_3D + ! + END SUBROUTINE quickest + + !!====================================================================== +END MODULE traadv_qck_lf \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_ubs.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_ubs.F90 new file mode 100644 index 0000000..fbab7c3 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_ubs.F90 @@ -0,0 +1,361 @@ +MODULE traadv_ubs + !!============================================================================== + !! *** MODULE traadv_ubs *** + !! Ocean active tracers: horizontal & vertical advective trend + !!============================================================================== + !! History : 1.0 ! 2006-08 (L. Debreu, R. Benshila) Original code + !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_ubs : update the tracer trend with the horizontal + !! advection trends using a third order biaised scheme + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE trc_oce ! share passive tracers/Ocean variables + USE trd_oce ! trends: ocean variables + USE traadv_fct ! acces to routine interp_4th_cpt + USE trdtra ! trends manager: tracers + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + ! + USE iom ! I/O library + USE in_out_manager ! I/O manager + USE lib_mpp ! massively parallel library + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) +#if defined key_loop_fusion + USE traadv_ubs_lf ! UBS scheme (tra_adv_ubs routine - loop fusion version) +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_ubs ! routine called by traadv module + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat transport + + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_ubs.F90 14922 2021-05-28 13:25:33Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_ubs( kt, kit000, cdtype, p2dt, pU, pV, pW, & + & Kbb, Kmm, pt, kjpt, Krhs, kn_ubs_v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_ubs *** + !! + !! ** Purpose : Compute the now trend due to the advection of tracers + !! and add it to the general trend of passive tracer equations. + !! + !! ** Method : The 3rd order Upstream Biased Scheme (UBS) is based on an + !! upstream-biased parabolic interpolation (Shchepetkin and McWilliams 2005) + !! It is only used in the horizontal direction. + !! For example the i-component of the advective fluxes are given by : + !! ! e2u e3u un ( mi(Tn) - zltu(i ) ) if un(i) >= 0 + !! ztu = ! or + !! ! e2u e3u un ( mi(Tn) - zltu(i+1) ) if un(i) < 0 + !! where zltu is the second derivative of the before temperature field: + !! zltu = 1/e3t di[ e2u e3u / e1u di[Tb] ] + !! This results in a dissipatively dominant (i.e. hyper-diffusive) + !! truncation error. The overall performance of the advection scheme + !! is similar to that reported in (Farrow and Stevens, 1995). + !! For stability reasons, the first term of the fluxes which corresponds + !! to a second order centered scheme is evaluated using the now velocity + !! (centered in time) while the second term which is the diffusive part + !! of the scheme, is evaluated using the before velocity (forward in time). + !! Note that UBS is not positive. Do not use it on passive tracers. + !! On the vertical, the advection is evaluated using a FCT scheme, + !! as the UBS have been found to be too diffusive. + !! kn_ubs_v argument controles whether the FCT is based on + !! a 2nd order centrered scheme (kn_ubs_v=2) or on a 4th order compact + !! scheme (kn_ubs_v=4). + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - poleward advective heat and salt transport (ln_diaptr=T) + !! + !! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404. + !! Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731�1741. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kn_ubs_v ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra, zbtr, zcoef ! local scalars + REAL(wp) :: zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk ! - - + REAL(wp) :: zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace + !!---------------------------------------------------------------------- + ! +#if defined key_loop_fusion + CALL tra_adv_ubs_lf ( kt, kit000, cdtype, p2dt, pU, pV, pW, Kbb, Kmm, pt, kjpt, Krhs, kn_ubs_v ) +#else + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_adv_ubs : horizontal UBS advection scheme on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + l_trd = .FALSE. + l_hst = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ENDIF + ! + ztw (:,:, 1 ) = 0._wp ! surface & bottom value : set to zero for all tracers + zltu(:,:,jpk) = 0._wp ; zltv(:,:,jpk) = 0._wp + ztw (:,:,jpk) = 0._wp ; zti (:,:,jpk) = 0._wp + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + ! + DO jk = 1, jpkm1 !== horizontal laplacian of before tracer ==! + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) ! First derivative (masked gradient) + zeeu = e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk) + zeev = e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk) + ztu(ji,jj,jk) = zeeu * ( pt(ji+1,jj ,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) + ztv(ji,jj,jk) = zeev * ( pt(ji ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) + END_2D + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! Second derivative (divergence) + zcoef = 1._wp / ( 6._wp * e3t(ji,jj,jk,Kmm) ) + zltu(ji,jj,jk) = ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) * zcoef + zltv(ji,jj,jk) = ( ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) * zcoef + END_2D + ! + END DO + IF (nn_hls==1) CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_wp, zltv, 'T', 1.0_wp, ld4only= .TRUE. ) ! Lateral boundary cond. (unchanged sgn) + ! + DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== Horizontal advective fluxes ==! (UBS) + zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) ! upstream transport (x2) + zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) + zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) + zfm_vj = pV(ji,jj,jk) - ABS( pV(ji,jj,jk) ) + ! ! 2nd order centered advective fluxes (x2) + zcenut = pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ) + zcenvt = pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) ) + ! ! UBS advective fluxes + ztu(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) ) + ztv(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) ) + END_3D + ! + DO_3D( 0, 0, 0, 0, 1, jpk ) + zltu(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) ! store the initial trends before its update + END_3D + ! + DO jk = 1, jpkm1 !== add the horizontal advective trend ==! + DO_2D( 0, 0, 0, 0 ) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) & + & - ( ztu(ji,jj,jk) - ztu(ji-1,jj ,jk) & + & + ztv(ji,jj,jk) - ztv(ji ,jj-1,jk) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_2D + ! + END DO + ! + DO_3D( 0, 0, 0, 0, 1, jpk ) + zltu(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltu(ji,jj,jk) ! Horizontal advective trend used in vertical 2nd order FCT case + END_3D ! and/or in trend diagnostic (l_trd=T) + ! + IF( l_trd ) THEN ! trend diagnostics + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztu, pU, pt(:,:,:,jn,Kmm) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, ztv, pV, pt(:,:,:,jn,Kmm) ) + END IF + ! + ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) + IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', ztv(:,:,:) ) + ! ! heati/salt transport + IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztu(:,:,:), ztv(:,:,:) ) + ! + ! + ! !== vertical advective trend ==! + ! + SELECT CASE( kn_ubs_v ) ! select the vertical advection scheme + ! + CASE( 2 ) ! 2nd order FCT + ! + IF( l_trd ) THEN + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) ! store pt(:,:,:,:,Krhs) if trend diag. + END_3D + ENDIF + ! + ! !* upstream advection with initial mass fluxes & intermediate update ==! + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) + zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) + ztw(ji,jj,jk) = 0.5_wp * ( zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb) ) * wmask(ji,jj,jk) + END_3D + IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as ztw has been w-masked) + IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface + DO_2D( 0, 0, 0, 0 ) + ztw(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface + END_2D + ELSE ! no cavities: only at the ocean surface + DO_2D( 0, 0, 0, 0 ) + ztw(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) + END_2D + ENDIF + ENDIF + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme + ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztak + zti(ji,jj,jk) = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) + END_3D + ! + ! !* anti-diffusive flux : high order minus low order + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + ztw(ji,jj,jk) = ( 0.5_wp * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) & + & - ztw(ji,jj,jk) ) * wmask(ji,jj,jk) + END_3D + ! ! top ocean value: high order == upstream ==>> zwz=0 + IF( ln_linssh ) ztw(:,:, 1 ) = 0._wp ! only ocean surface as interior zwz values have been w-masked + ! + CALL nonosc_z( Kmm, pt(:,:,:,jn,Kbb), ztw, zti, p2dt ) ! monotonicity algorithm + ! + CASE( 4 ) ! 4th order COMPACT + CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! 4th order compact interpolation of T at w-point + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + ztw(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) + END_3D + IF( ln_linssh ) THEN + DO_2D( 0, 0, 0, 0 ) + ztw(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) !!gm ISF & 4th COMPACT doesn't work + END_2D + ENDIF + ! + END SELECT + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! final trend with corrected fluxes + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + ! + IF( l_trd ) THEN ! vertical advective trend diagnostics + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w]) + zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltv(ji,jj,jk) & + & + pt(ji,jj,jk,jn,Kmm) * ( pW(ji,jj,jk) - pW(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zltv ) + ENDIF + ! + END DO + ! +#endif + END SUBROUTINE tra_adv_ubs + + + SUBROUTINE nonosc_z( Kmm, pbef, pcc, paft, p2dt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE nonosc_z *** + !! + !! ** Purpose : compute monotonic tracer fluxes from the upstream + !! scheme and the before field by a nonoscillatory algorithm + !! + !! ** Method : ... ??? + !! warning : pbef and paft must be masked, but the boundaries + !! conditions on the fluxes are not necessary zalezak (1979) + !! drange (1995) multi-dimensional forward-in-time and upstream- + !! in-space based differencing for fluid + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), INTENT(in ) :: p2dt ! tracer time-step + REAL(dp), DIMENSION(jpi,jpj,jpk) :: pbef ! before field + REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: paft ! after field + REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: pcc ! monotonic flux in the k direction + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikm1 ! local integer + REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo ! 3D workspace + !!---------------------------------------------------------------------- + ! + zbig = 1.e+20_wp + zrtrn = 1.e-15_wp + zbetup(:,:,:) = 0._wp ; zbetdo(:,:,:) = 0._wp + ! + ! Search local extrema + ! -------------------- + ! ! large negative value (-zbig) inside land + DO_3D( 0, 0, 0, 0, 1, jpk ) + pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1.e0 - tmask(ji,jj,jk) ) + paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1.e0 - tmask(ji,jj,jk) ) + END_3D + ! + DO jk = 1, jpkm1 ! search maximum in neighbourhood + ikm1 = MAX(jk-1,1) + DO_2D( 0, 0, 0, 0 ) + zbetup(ji,jj,jk) = MAX( pbef(ji ,jj ,jk ), paft(ji ,jj ,jk ), & + & pbef(ji ,jj ,ikm1), pbef(ji ,jj ,jk+1), & + & paft(ji ,jj ,ikm1), paft(ji ,jj ,jk+1) ) + END_2D + END DO + ! ! large positive value (+zbig) inside land + DO_3D( 0, 0, 0, 0, 1, jpk ) + pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1.e0 - tmask(ji,jj,jk) ) + paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1.e0 - tmask(ji,jj,jk) ) + END_3D + ! + DO jk = 1, jpkm1 ! search minimum in neighbourhood + ikm1 = MAX(jk-1,1) + DO_2D( 0, 0, 0, 0 ) + zbetdo(ji,jj,jk) = MIN( pbef(ji ,jj ,jk ), paft(ji ,jj ,jk ), & + & pbef(ji ,jj ,ikm1), pbef(ji ,jj ,jk+1), & + & paft(ji ,jj ,ikm1), paft(ji ,jj ,jk+1) ) + END_2D + END DO + ! ! restore masked values to zero + DO_3D( 0, 0, 0, 0, 1, jpk ) + pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) + paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) + END_3D + ! + ! Positive and negative part of fluxes and beta terms + ! --------------------------------------------------- + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + ! positive & negative part of the flux + zpos = MAX( 0., pcc(ji ,jj ,jk+1) ) - MIN( 0., pcc(ji ,jj ,jk ) ) + zneg = MAX( 0., pcc(ji ,jj ,jk ) ) - MIN( 0., pcc(ji ,jj ,jk+1) ) + ! up & down beta terms + zbt = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) / p2dt + zbetup(ji,jj,jk) = ( zbetup(ji,jj,jk) - paft(ji,jj,jk) ) / (zpos+zrtrn) * zbt + zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zbetdo(ji,jj,jk) ) / (zneg+zrtrn) * zbt + END_3D + ! + ! monotonic flux in the k direction, i.e. pcc + ! ------------------------------------------- + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + za = MIN( 1., zbetdo(ji,jj,jk), zbetup(ji,jj,jk-1) ) + zb = MIN( 1., zbetup(ji,jj,jk), zbetdo(ji,jj,jk-1) ) + zc = 0.5 * ( 1.e0 + SIGN( 1.0_wp, pcc(ji,jj,jk) ) ) + pcc(ji,jj,jk) = pcc(ji,jj,jk) * ( zc * za + ( 1.e0 - zc) * zb ) + END_3D + ! + END SUBROUTINE nonosc_z + + !!====================================================================== +END MODULE traadv_ubs diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_ubs_lf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_ubs_lf.F90 new file mode 100644 index 0000000..9bc7700 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traadv_ubs_lf.F90 @@ -0,0 +1,367 @@ +MODULE traadv_ubs_lf + !!============================================================================== + !! *** MODULE traadv_ubs *** + !! Ocean active tracers: horizontal & vertical advective trend + !!============================================================================== + !! History : 1.0 ! 2006-08 (L. Debreu, R. Benshila) Original code + !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_adv_ubs : update the tracer trend with the horizontal + !! advection trends using a third order biaised scheme + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE trc_oce ! share passive tracers/Ocean variables + USE trd_oce ! trends: ocean variables + USE traadv_fct ! acces to routine interp_4th_cpt + USE trdtra ! trends manager: tracers + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + ! + USE iom ! I/O library + USE in_out_manager ! I/O manager + USE lib_mpp ! massively parallel library + USE lbclnk ! ocean lateral boundary condition (or mpp link) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_adv_ubs_lf ! routine called by traadv module + + LOGICAL :: l_trd ! flag to compute trends + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat transport + + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traadv_ubs.F90 14776 2021-04-30 12:33:41Z mocavero $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_ubs_lf( kt, kit000, cdtype, p2dt, pU, pV, pW, & + & Kbb, Kmm, pt, kjpt, Krhs, kn_ubs_v ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv_ubs *** + !! + !! ** Purpose : Compute the now trend due to the advection of tracers + !! and add it to the general trend of passive tracer equations. + !! + !! ** Method : The 3rd order Upstream Biased Scheme (UBS) is based on an + !! upstream-biased parabolic interpolation (Shchepetkin and McWilliams 2005) + !! It is only used in the horizontal direction. + !! For example the i-component of the advective fluxes are given by : + !! ! e2u e3u un ( mi(Tn) - zltu(i ) ) if un(i) >= 0 + !! ztu = ! or + !! ! e2u e3u un ( mi(Tn) - zltu(i+1) ) if un(i) < 0 + !! where zltu is the second derivative of the before temperature field: + !! zltu = 1/e3t di[ e2u e3u / e1u di[Tb] ] + !! This results in a dissipatively dominant (i.e. hyper-diffusive) + !! truncation error. The overall performance of the advection scheme + !! is similar to that reported in (Farrow and Stevens, 1995). + !! For stability reasons, the first term of the fluxes which corresponds + !! to a second order centered scheme is evaluated using the now velocity + !! (centered in time) while the second term which is the diffusive part + !! of the scheme, is evaluated using the before velocity (forward in time). + !! Note that UBS is not positive. Do not use it on passive tracers. + !! On the vertical, the advection is evaluated using a FCT scheme, + !! as the UBS have been found to be too diffusive. + !! kn_ubs_v argument controles whether the FCT is based on + !! a 2nd order centrered scheme (kn_ubs_v=2) or on a 4th order compact + !! scheme (kn_ubs_v=4). + !! + !! ** Action : - update pt(:,:,:,:,Krhs) with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - poleward advective heat and salt transport (ln_diaptr=T) + !! + !! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404. + !! Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731�1741. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kn_ubs_v ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra, zbtr, zcoef, zcoef_ip1, zcoef_jp1 ! local scalars + REAL(wp) :: zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk ! - - + REAL(wp) :: zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn ! - - + REAL(wp) :: zeeu_im1, zeeu_ip1, zeev_jm1, zeev_jp1 + REAL(wp) :: zztu, zztu_im1, zztu_ip1 + REAL(wp) :: zztv, zztv_jm1, zztv_jp1 + REAL(wp) :: zzltu, zzltu_ip1, zzltv, zzltv_jp1 + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace + !!---------------------------------------------------------------------- + ! + IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_adv_ubs : horizontal UBS advection scheme on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + l_trd = .FALSE. + l_hst = .FALSE. + l_ptr = .FALSE. + IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ENDIF + ! + ztw (:,:, 1 ) = 0._wp ! surface & bottom value : set to zero for all tracers + zltu(:,:,jpk) = 0._wp ; zltv(:,:,jpk) = 0._wp + ztw (:,:,jpk) = 0._wp ; zti (:,:,jpk) = 0._wp + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + ! !== horizontal laplacian of before tracer ==! + DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! Second derivative (divergence) + ! First derivative (masked gradient) + zeeu_im1 = e2_e1u(ji-1,jj ) * e3u(ji-1,jj ,jk,Kmm) * umask(ji-1,jj ,jk) + zeeu = e2_e1u(ji ,jj ) * e3u(ji ,jj ,jk,Kmm) * umask(ji ,jj ,jk) + zeeu_ip1 = e2_e1u(ji+1,jj ) * e3u(ji+1,jj ,jk,Kmm) * umask(ji+1,jj ,jk) + zeev_jm1 = e1_e2v(ji ,jj-1) * e3v(ji ,jj-1,jk,Kmm) * vmask(ji ,jj-1,jk) + zeev = e1_e2v(ji ,jj ) * e3v(ji ,jj ,jk,Kmm) * vmask(ji ,jj ,jk) + zeev_jp1 = e1_e2v(ji ,jj+1) * e3v(ji ,jj+1,jk,Kmm) * vmask(ji ,jj+1,jk) + ! + zztu_im1 = zeeu_im1 * ( pt(ji ,jj,jk,jn,Kbb) - pt(ji-1,jj,jk,jn,Kbb) ) + zztu = zeeu * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji ,jj,jk,jn,Kbb) ) + zztu_ip1 = zeeu_ip1 * ( pt(ji+2,jj,jk,jn,Kbb) - pt(ji+1,jj,jk,jn,Kbb) ) + ! + zztv_jm1 = zeev_jm1 * ( pt(ji,jj ,jk,jn,Kbb) - pt(ji,jj-1,jk,jn,Kbb) ) + zztv = zeev * ( pt(ji,jj+1,jk,jn,Kbb) - pt(ji,jj ,jk,jn,Kbb) ) + zztv_jp1 = zeev_jp1 * ( pt(ji,jj+2,jk,jn,Kbb) - pt(ji,jj+1,jk,jn,Kbb) ) + ! Second derivative (divergence) + zcoef = 1._wp / ( 6._wp * e3t(ji ,jj ,jk,Kmm) ) + zcoef_ip1 = 1._wp / ( 6._wp * e3t(ji+1,jj ,jk,Kmm) ) + zcoef_jp1 = 1._wp / ( 6._wp * e3t(ji ,jj+1,jk,Kmm) ) + ! + zzltu = ( zztu - zztu_im1 ) * zcoef + zzltu_ip1 = ( zztu_ip1 - zztu ) * zcoef_ip1 + zzltv = ( zztv - zztv_jm1 ) * zcoef + zzltv_jp1 = ( zztv_jp1 - zztv ) * zcoef_jp1 + ! + ! !== Horizontal advective fluxes ==! (UBS) + zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) ! upstream transport (x2) + zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) + zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) + zfm_vj = pV(ji,jj,jk) - ABS( pV(ji,jj,jk) ) + ! ! 2nd order centered advective fluxes (x2) + zcenut = pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ) + zcenvt = pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) ) + ! ! UBS advective fluxes + ztu(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zzltu - zfm_ui * zzltu_ip1 ) + ztv(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zzltv - zfm_vj * zzltv_jp1 ) + END_3D + ! + DO_3D( 0, 0, 0, 0, 1, jpk ) + zltu(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) ! store the initial trends before its update + END_3D + ! + ! !== add the horizontal advective trend ==! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) & + & - ( ztu(ji,jj,jk) - ztu(ji-1,jj ,jk) & + & + ztv(ji,jj,jk) - ztv(ji ,jj-1,jk) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + ! + DO_3D( 0, 0, 0, 0, 1, jpk ) + zltu(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltu(ji,jj,jk) ! Horizontal advective trend used in vertical 2nd order FCT case + END_3D ! and/or in trend diagnostic (l_trd=T) + ! + IF( l_trd ) THEN ! trend diagnostics + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztu, pU, CASTDP(pt(:,:,:,jn,Kmm)) ) + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, ztv, pV, CASTDP(pt(:,:,:,jn,Kmm)) ) + END IF + ! + ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) + IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', ztv(:,:,:) ) + ! ! heati/salt transport + IF( l_hst ) CALL dia_ar5_hst( jn, 'adv', ztu(:,:,:), ztv(:,:,:) ) + ! + ! + ! !== vertical advective trend ==! + ! + SELECT CASE( kn_ubs_v ) ! select the vertical advection scheme + ! + CASE( 2 ) ! 2nd order FCT + ! + IF( l_trd ) THEN + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) ! store pt(:,:,:,:,Krhs) if trend diag. + END_3D + ENDIF + ! + ! !* upstream advection with initial mass fluxes & intermediate update ==! + DO_3D( 1, 1, 1, 1, 2, jpkm1 ) + zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) + zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) + ztw(ji,jj,jk) = 0.5_wp * ( zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb) ) * wmask(ji,jj,jk) + END_3D + IF( ln_linssh ) THEN ! top ocean value (only in linear free surface as ztw has been w-masked) + IF( ln_isfcav ) THEN ! top of the ice-shelf cavities and at the ocean surface + DO_2D( 1, 1, 1, 1 ) + ztw(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) ! linear free surface + END_2D + ELSE ! no cavities: only at the ocean surface + DO_2D( 1, 1, 1, 1 ) + ztw(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) + END_2D + ENDIF + ENDIF + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme + ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztak + zti(ji,jj,jk) = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) + END_3D + ! + ! !* anti-diffusive flux : high order minus low order + DO_3D( 1, 1, 1, 1, 2, jpkm1 ) + ztw(ji,jj,jk) = ( 0.5_wp * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) & + & - ztw(ji,jj,jk) ) * wmask(ji,jj,jk) + END_3D + ! ! top ocean value: high order == upstream ==>> zwz=0 + IF( ln_linssh ) ztw(:,:, 1 ) = 0._wp ! only ocean surface as interior zwz values have been w-masked + ! + CALL nonosc_z( Kmm, pt(:,:,:,jn,Kbb), ztw, zti, p2dt ) ! monotonicity algorithm + ! + CASE( 4 ) ! 4th order COMPACT + CALL interp_4th_cpt( CASTDP(pt(:,:,:,jn,Kmm)) , ztw ) ! 4th order compact interpolation of T at w-point + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + ztw(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) + END_3D + IF( ln_linssh ) THEN + DO_2D( 1, 1, 1, 1 ) + ztw(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) !!gm ISF & 4th COMPACT doesn't work + END_2D + ENDIF + ! + END SELECT + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! final trend with corrected fluxes + pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + ! + IF( l_trd ) THEN ! vertical advective trend diagnostics + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w]) + zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltv(ji,jj,jk) & + & + pt(ji,jj,jk,jn,Kmm) * ( pW(ji,jj,jk) - pW(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zltv ) + ENDIF + ! + END DO + ! + END SUBROUTINE tra_adv_ubs_lf + + + SUBROUTINE nonosc_z( Kmm, pbef, pcc, paft, p2dt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE nonosc_z *** + !! + !! ** Purpose : compute monotonic tracer fluxes from the upstream + !! scheme and the before field by a nonoscillatory algorithm + !! + !! ** Method : ... ??? + !! warning : pbef and paft must be masked, but the boundaries + !! conditions on the fluxes are not necessary zalezak (1979) + !! drange (1995) multi-dimensional forward-in-time and upstream- + !! in-space based differencing for fluid + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), INTENT(in ) :: p2dt ! tracer time-step + REAL(wp), DIMENSION(jpi,jpj,jpk) :: pbef ! before field + REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: paft ! after field + REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: pcc ! monotonic flux in the k direction + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikm1 ! local integer + REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo ! 3D workspace + !!---------------------------------------------------------------------- + ! + zbig = 1.e+20_wp + zrtrn = 1.e-15_wp + zbetup(:,:,:) = 0._wp ; zbetdo(:,:,:) = 0._wp + ! + ! Search local extrema + ! -------------------- + ! ! large negative value (-zbig) inside land + DO_3D( 0, 0, 0, 0, 1, jpk ) + pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1.e0 - tmask(ji,jj,jk) ) + paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1.e0 - tmask(ji,jj,jk) ) + END_3D + ! + DO jk = 1, jpkm1 ! search maximum in neighbourhood + ikm1 = MAX(jk-1,1) + DO_2D( 0, 0, 0, 0 ) + zbetup(ji,jj,jk) = MAX( pbef(ji ,jj ,jk ), paft(ji ,jj ,jk ), & + & pbef(ji ,jj ,ikm1), pbef(ji ,jj ,jk+1), & + & paft(ji ,jj ,ikm1), paft(ji ,jj ,jk+1) ) + END_2D + END DO + ! ! large positive value (+zbig) inside land + DO_3D( 0, 0, 0, 0, 1, jpk ) + pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1.e0 - tmask(ji,jj,jk) ) + paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1.e0 - tmask(ji,jj,jk) ) + END_3D + ! + DO jk = 1, jpkm1 ! search minimum in neighbourhood + ikm1 = MAX(jk-1,1) + DO_2D( 0, 0, 0, 0 ) + zbetdo(ji,jj,jk) = MIN( pbef(ji ,jj ,jk ), paft(ji ,jj ,jk ), & + & pbef(ji ,jj ,ikm1), pbef(ji ,jj ,jk+1), & + & paft(ji ,jj ,ikm1), paft(ji ,jj ,jk+1) ) + END_2D + END DO + ! ! restore masked values to zero + DO_3D( 0, 0, 0, 0, 1, jpk ) + pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) + paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) + END_3D + ! + ! Positive and negative part of fluxes and beta terms + ! --------------------------------------------------- + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + ! positive & negative part of the flux + zpos = MAX( 0., pcc(ji ,jj ,jk+1) ) - MIN( 0., pcc(ji ,jj ,jk ) ) + zneg = MAX( 0., pcc(ji ,jj ,jk ) ) - MIN( 0., pcc(ji ,jj ,jk+1) ) + ! up & down beta terms + zbt = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) / p2dt + zbetup(ji,jj,jk) = ( zbetup(ji,jj,jk) - paft(ji,jj,jk) ) / (zpos+zrtrn) * zbt + zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zbetdo(ji,jj,jk) ) / (zneg+zrtrn) * zbt + END_3D + ! + ! monotonic flux in the k direction, i.e. pcc + ! ------------------------------------------- + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + za = MIN( 1., zbetdo(ji,jj,jk), zbetup(ji,jj,jk-1) ) + zb = MIN( 1., zbetup(ji,jj,jk), zbetdo(ji,jj,jk-1) ) + zc = 0.5 * ( 1.e0 + SIGN( 1.0_wp, pcc(ji,jj,jk) ) ) + pcc(ji,jj,jk) = pcc(ji,jj,jk) * ( zc * za + ( 1.e0 - zc) * zb ) + END_3D + ! + END SUBROUTINE nonosc_z + + !!====================================================================== +END MODULE traadv_ubs_lf diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traatf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traatf.F90 new file mode 100644 index 0000000..a0e04e5 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traatf.F90 @@ -0,0 +1,385 @@ +MODULE traatf + !!====================================================================== + !! *** MODULE traatf *** + !! Ocean active tracers: Asselin time filtering for temperature and salinity + !!====================================================================== + !! History : OPA ! 1991-11 (G. Madec) Original code + !! 7.0 ! 1993-03 (M. Guyon) symetrical conditions + !! 8.0 ! 1996-02 (G. Madec & M. Imbard) opa release 8.0 + !! - ! 1996-04 (A. Weaver) Euler forward step + !! 8.2 ! 1999-02 (G. Madec, N. Grima) semi-implicit pressure grad. + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! - ! 2002-11 (C. Talandier, A-M Treguier) Open boundaries + !! - ! 2005-04 (C. Deltel) Add Asselin trend in the ML budget + !! 2.0 ! 2006-02 (L. Debreu, C. Mazauric) Agrif implementation + !! 3.0 ! 2008-06 (G. Madec) time stepping always done in trazdf + !! 3.1 ! 2009-02 (G. Madec, R. Benshila) re-introduce the vvl option + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) semi-implicit hpg with asselin filter + modified LF-RA + !! - ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename tranxt.F90 -> traatf.F90. Now only does time filtering. + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_atf : time filtering on tracers + !! tra_atf_fix : time filtering on tracers : fixed volume case + !! tra_atf_vvl : time filtering on tracers : variable volume case + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE sbc_oce ! surface boundary condition: ocean + USE sbcrnf ! river runoffs + USE isf_oce ! ice shelf melting + USE zdf_oce ! ocean vertical mixing + USE domvvl ! variable volume + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE traqsr ! penetrative solar radiation (needed for nksr) + USE phycst ! physical constant + USE ldftra ! lateral physics : tracers + USE ldfslp ! lateral physics : slopes + USE bdy_oce , ONLY : ln_bdy + USE bdytra ! open boundary condition (bdy_tra routine) + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE timing ! Timing +#if defined key_agrif + USE agrif_oce_interp +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_atf ! routine called by step.F90 + PUBLIC tra_atf_fix ! to be used in trcnxt + PUBLIC tra_atf_vvl ! to be used in trcnxt + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traatf.F90 15004 2021-06-16 10:33:18Z mathiot $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_atf( kt, Kbb, Kmm, Kaa, pts ) + !!---------------------------------------------------------------------- + !! *** ROUTINE traatf *** + !! + !! ** Purpose : Apply the boundary condition on the after temperature + !! and salinity fields and add the Asselin time filter on now fields. + !! + !! ** Method : At this stage of the computation, ta and sa are the + !! after temperature and salinity as the time stepping has + !! been performed in trazdf_imp or trazdf_exp module. + !! + !! - Apply lateral boundary conditions on (ta,sa) + !! at the local domain boundaries through lbc_lnk call, + !! at the one-way open boundaries (ln_bdy=T), + !! at the AGRIF zoom boundaries (lk_agrif=T) + !! + !! - Update lateral boundary conditions on AGRIF children + !! domains (lk_agrif=T) + !! + !! ** Action : - ts(Kmm) time filtered + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: zfact ! local scalars + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'tra_atf') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_atf : apply Asselin time filter to "now" fields' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + + ! Update after tracer on domain lateral boundaries + ! +#if defined key_agrif + CALL Agrif_tra ! AGRIF zoom boundaries +#endif + ! ! local domain boundaries (T-point, unchanged sign) + CALL lbc_lnk( 'traatf', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_dp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_dp ) + ! + IF( ln_bdy ) CALL bdy_tra( kt, Kbb, pts, Kaa ) ! BDY open boundaries + + ! trends computation initialisation + IF( l_trdtra ) THEN + ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = 0._wp + ztrds(:,:,:) = 0._wp + IF( ln_traldf_iso ) THEN ! diagnose the "pure" Kz diffusive trend + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_zdfp, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_zdfp, ztrds ) + ENDIF + ! total trend for the non-time-filtered variables. + zfact = 1.0 / rn_Dt + ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3t*T)/e3tn; e3tn cancel from pts(Kmm) terms + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa) / e3t(:,:,jk,Kmm) - pts(:,:,jk,jp_tem,Kmm)) * zfact + ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kaa)*e3t(:,:,jk,Kaa) / e3t(:,:,jk,Kmm) - pts(:,:,jk,jp_sal,Kmm)) * zfact + END DO + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_tot, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_tot, ztrds ) + IF( ln_linssh ) THEN ! linear sea surface height only + ! Store now fields before applying the Asselin filter + ! in order to calculate Asselin filter trend later. + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kmm) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Kmm) + ENDIF + ENDIF + + IF( l_1st_euler ) THEN ! Euler time-stepping + ! + IF (l_trdtra .AND. .NOT. ln_linssh ) THEN ! Zero Asselin filter contribution must be explicitly written out since for vvl + ! ! Asselin filter is output by tra_atf_vvl that is not called on this time step + ztrdt(:,:,:) = 0._wp + ztrds(:,:,:) = 0._wp + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_atf, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_atf, ztrds ) + END IF + ! + ELSE ! Leap-Frog + Asselin filter time stepping + ! + IF( ln_linssh ) THEN ; CALL tra_atf_fix( kt, Kbb, Kmm, Kaa, nit000, 'TRA', pts, jpts ) ! linear free surface + ELSE ; CALL tra_atf_vvl( kt, Kbb, Kmm, Kaa, nit000, rn_Dt, 'TRA', pts, sbc_tsc, sbc_tsc_b, jpts ) ! non-linear free surface + ENDIF + ! + CALL lbc_lnk( 'traatf', pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_dp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_dp ) + + ENDIF + ! + IF( l_trdtra .AND. ln_linssh ) THEN ! trend of the Asselin filter (tb filtered - tb)/dt + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kmm) - ztrdt(:,:,jk) ) * r1_Dt + ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kmm) - ztrds(:,:,jk) ) * r1_Dt + END DO + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_atf, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_atf, ztrds ) + END IF + IF( l_trdtra ) DEALLOCATE( ztrdt , ztrds ) + ! + ! ! control print + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kmm), clinfo1=' nxt - Tn: ', mask1=tmask, & + & tab3d_2=pts(:,:,:,jp_sal,Kmm), clinfo2= ' Sn: ', mask2=tmask ) + ! + IF( ln_timing ) CALL timing_stop('tra_atf') + ! + END SUBROUTINE tra_atf + + + SUBROUTINE tra_atf_fix( kt, Kbb, Kmm, Kaa, kit000, cdtype, pt, kjpt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_atf_fix *** + !! + !! ** Purpose : fixed volume: apply the Asselin time filter to the "now" field + !! + !! ** Method : - Apply a Asselin time filter on now fields. + !! + !! ** Action : - pt(Kmm) ready for the next time step + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztn, ztd ! local scalars + !!---------------------------------------------------------------------- + ! + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_atf_fix : time filtering', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + DO jn = 1, kjpt + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + ztn = pt(ji,jj,jk,jn,Kmm) + ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb) ! time laplacian on tracers + ! + pt(ji,jj,jk,jn,Kmm) = ztn + rn_atfp * ztd ! pt <-- filtered pt + END_3D + ! + END DO + ! + END SUBROUTINE tra_atf_fix + + + SUBROUTINE tra_atf_vvl( kt, Kbb, Kmm, Kaa, kit000, p2dt, cdtype, pt, psbc_tc, psbc_tc_b, kjpt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_atf_vvl *** + !! + !! ** Purpose : Time varying volume: apply the Asselin time filter + !! + !! ** Method : - Apply a thickness weighted Asselin time filter on now fields. + !! pt(Kmm) = ( e3t_Kmm*pt(Kmm) + rn_atfp*[ e3t_Kbb*pt(Kbb) - 2 e3t_Kmm*pt(Kmm) + e3t_Kaa*pt(Kaa) ] ) + !! /( e3t_Kmm + rn_atfp*[ e3t_Kbb - 2 e3t_Kmm + e3t_Kaa ] ) + !! + !! ** Action : - pt(Kmm) ready for the next time step + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + REAL(wp) , INTENT(in ) :: p2dt ! time-step + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields + REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content + REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content + ! + LOGICAL :: ll_traqsr, ll_rnf, ll_isf ! local logical + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: zfact, zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d ! local scalar + REAL(wp) :: zfact2, ze3t_b, ze3t_n, ze3t_a, ze3t_f, ze3t_d, zscale ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrd_atf + !!---------------------------------------------------------------------- + ! + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_atf_vvl : time filtering', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + IF( cdtype == 'TRA' ) THEN + ll_traqsr = ln_traqsr ! active tracers case and solar penetration + ll_rnf = ln_rnf ! active tracers case and river runoffs + ll_isf = ln_isf ! active tracers case and ice shelf melting + ELSE ! passive tracers case + ll_traqsr = .FALSE. ! NO solar penetration + ll_rnf = .FALSE. ! NO river runoffs ???? !!gm BUG ? + ll_isf = .FALSE. ! NO ice shelf melting/freezing !!gm BUG ?? + ENDIF + ! + IF( ( l_trdtra .AND. cdtype == 'TRA' ) .OR. ( l_trdtrc .AND. cdtype == 'TRC' ) ) THEN + ALLOCATE( ztrd_atf(jpi,jpj,jpk,kjpt) ) + ztrd_atf(:,:,:,:) = 0.0_wp + ENDIF + zfact = 1._wp / p2dt + zfact1 = rn_atfp * p2dt + zfact2 = zfact1 * r1_rho0 + DO jn = 1, kjpt + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + ze3t_b = e3t(ji,jj,jk,Kbb) + ze3t_n = e3t(ji,jj,jk,Kmm) + ze3t_a = e3t(ji,jj,jk,Kaa) + ! ! tracer content at Before, now and after + ztc_b = pt(ji,jj,jk,jn,Kbb) * ze3t_b + ztc_n = pt(ji,jj,jk,jn,Kmm) * ze3t_n + ztc_a = pt(ji,jj,jk,jn,Kaa) * ze3t_a + ! + ze3t_d = ze3t_a - 2. * ze3t_n + ze3t_b + ztc_d = ztc_a - 2. * ztc_n + ztc_b + ! + ze3t_f = ze3t_n + rn_atfp * ze3t_d + ztc_f = ztc_n + rn_atfp * ztc_d + ! + ! Add asselin correction on scale factors: + zscale = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) ) + ze3t_f = ze3t_f - zfact2 * zscale * ( emp_b(ji,jj) - emp(ji,jj) ) + IF ( ll_rnf ) ze3t_f = ze3t_f + zfact2 * zscale * ( rnf_b(ji,jj) - rnf(ji,jj) ) + IF ( ll_isf ) THEN + IF ( ln_isfcav_mlt ) ze3t_f = ze3t_f + zfact2 * zscale * ( fwfisf_cav_b(ji,jj) - fwfisf_cav(ji,jj) ) + IF ( ln_isfpar_mlt ) ze3t_f = ze3t_f + zfact2 * zscale * ( fwfisf_par_b(ji,jj) - fwfisf_par(ji,jj) ) + ENDIF + ! + IF( jk == mikt(ji,jj) ) THEN ! first level + ztc_f = ztc_f - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) + ENDIF + ! + ! solar penetration (temperature only) + IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr ) & + & ztc_f = ztc_f - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) ) + ! + ! + IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) ) & + & ztc_f = ztc_f - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) & + & * e3t(ji,jj,jk,Kmm) / h_rnf(ji,jj) + + ! + ! ice shelf + IF( ll_isf ) THEN + ! + ! melt in the cavity + IF ( ln_isfcav_mlt ) THEN + ! level fully include in the Losch_2008 ice shelf boundary layer + IF ( jk >= misfkt_cav(ji,jj) .AND. jk < misfkb_cav(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) ) & + & * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) + END IF + ! level partially include in Losch_2008 ice shelf boundary layer + IF ( jk == misfkb_cav(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) ) & + & * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) * rfrac_tbl_cav(ji,jj) + END IF + END IF + ! + ! parametrised melt (cavity closed) + IF ( ln_isfpar_mlt ) THEN + ! level fully include in the Losch_2008 ice shelf boundary layer + IF ( jk >= misfkt_par(ji,jj) .AND. jk < misfkb_par(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) ) & + & * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) + END IF + ! level partially include in Losch_2008 ice shelf boundary layer + IF ( jk == misfkb_par(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) ) & + & * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) * rfrac_tbl_par(ji,jj) + END IF + END IF + ! + ! ice sheet coupling correction + IF ( ln_isfcpl ) THEN + ! + ! at kt = nit000, risfcpl_vol_n = 0 and risfcpl_vol_b = risfcpl_vol so contribution nul + IF ( ln_rstart .AND. kt == nit000+1 ) THEN + ztc_f = ztc_f + zfact1 * risfcpl_tsc(ji,jj,jk,jn) * r1_e1e2t(ji,jj) + ! Shouldn't volume increment be spread according thanks to zscale ? + ze3t_f = ze3t_f - zfact1 * risfcpl_vol(ji,jj,jk ) * r1_e1e2t(ji,jj) + END IF + ! + END IF + ! + END IF + ! + ze3t_f = 1.e0 / ze3t_f + pt(ji,jj,jk,jn,Kmm) = ztc_f * ze3t_f ! time filtered "now" field + ! + IF( ( l_trdtra .and. cdtype == 'TRA' ) .OR. ( l_trdtrc .and. cdtype == 'TRC' ) ) THEN + ztrd_atf(ji,jj,jk,jn) = (ztc_f - ztc_n) * zfact/ze3t_n + ENDIF + ! + END_3D + ! + END DO + ! + IF( ( l_trdtra .AND. cdtype == 'TRA' ) .OR. ( l_trdtrc .AND. cdtype == 'TRC' ) ) THEN + IF( l_trdtra .AND. cdtype == 'TRA' ) THEN + CALL trd_tra( kt, Kmm, Kaa, cdtype, jp_tem, jptra_atf, ztrd_atf(:,:,:,jp_tem) ) + CALL trd_tra( kt, Kmm, Kaa, cdtype, jp_sal, jptra_atf, ztrd_atf(:,:,:,jp_sal) ) + ENDIF + IF( l_trdtrc .AND. cdtype == 'TRC' ) THEN + DO jn = 1, kjpt + CALL trd_tra( kt, Kmm, Kaa, cdtype, jn, jptra_atf, ztrd_atf(:,:,:,jn) ) + END DO + ENDIF + DEALLOCATE( ztrd_atf ) + ENDIF + ! + END SUBROUTINE tra_atf_vvl + + !!====================================================================== +END MODULE traatf diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traatf_qco.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traatf_qco.F90 new file mode 100644 index 0000000..0235627 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traatf_qco.F90 @@ -0,0 +1,369 @@ +MODULE traatf_qco + !!====================================================================== + !! *** MODULE traatf_qco *** + !! Ocean active tracers: Asselin time filtering for temperature and salinity + !!====================================================================== + !! History : OPA ! 1991-11 (G. Madec) Original code + !! 7.0 ! 1993-03 (M. Guyon) symetrical conditions + !! 8.0 ! 1996-02 (G. Madec & M. Imbard) opa release 8.0 + !! - ! 1996-04 (A. Weaver) Euler forward step + !! 8.2 ! 1999-02 (G. Madec, N. Grima) semi-implicit pressure grad. + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module + !! - ! 2002-11 (C. Talandier, A-M Treguier) Open boundaries + !! - ! 2005-04 (C. Deltel) Add Asselin trend in the ML budget + !! 2.0 ! 2006-02 (L. Debreu, C. Mazauric) Agrif implementation + !! 3.0 ! 2008-06 (G. Madec) time stepping always done in trazdf + !! 3.1 ! 2009-02 (G. Madec, R. Benshila) re-introduce the vvl option + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) semi-implicit hpg with asselin filter + modified LF-RA + !! - ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename tranxt.F90 -> traatfLF.F90. Now only does time filtering. + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_atf : time filtering on tracers + !! tra_atf_fix : time filtering on tracers : fixed volume case + !! tra_atf_vvl : time filtering on tracers : variable volume case + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE sbc_oce ! surface boundary condition: ocean + USE sbcrnf ! river runoffs + USE isf_oce ! ice shelf melting + USE zdf_oce ! ocean vertical mixing + USE domvvl ! variable volume + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE traqsr ! penetrative solar radiation (needed for nksr) + USE phycst ! physical constant + USE ldftra ! lateral physics : tracers + USE ldfslp ! lateral physics : slopes + USE bdy_oce , ONLY : ln_bdy + USE bdytra ! open boundary condition (bdy_tra routine) + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_atf_qco ! routine called by step.F90 + PUBLIC tra_atf_fix_lf ! to be used in trcnxt !!st WARNING discrepancy here interpol is used by PISCES + PUBLIC tra_atf_qco_lf ! to be used in trcnxt !!st WARNING discrepancy here interpol is used by PISCES + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traatf_qco.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_atf_qco( kt, Kbb, Kmm, Kaa, pts ) + !!---------------------------------------------------------------------- + !! *** ROUTINE traatfLF *** + !! + !! ** Purpose : Apply the boundary condition on the after temperature + !! and salinity fields and add the Asselin time filter on now fields. + !! + !! ** Method : At this stage of the computation, ta and sa are the + !! after temperature and salinity as the time stepping has + !! been performed in trazdf_imp or trazdf_exp module. + !! + !! - Apply lateral boundary conditions on (ta,sa) + !! at the local domain boundaries through lbc_lnk call, + !! at the one-way open boundaries (ln_bdy=T), + !! at the AGRIF zoom boundaries (lk_agrif=T) + !! + !! - Update lateral boundary conditions on AGRIF children + !! domains (lk_agrif=T) + !! + !! ** Action : - ts(Kmm) time filtered + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(dp) :: zfact ! local scalars + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'tra_atf_qco') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_atf_qco : apply Asselin time filter to "now" fields' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF +!!st Update after tracer on domain lateral boundaries as been removed outside + + ! trends computation initialisation + IF( l_trdtra ) THEN + ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,jpk) = 0._wp + ztrds(:,:,jpk) = 0._wp + IF( ln_traldf_iso ) THEN ! diagnose the "pure" Kz diffusive trend + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_zdfp, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_zdfp, ztrds ) + ENDIF + ! total trend for the non-time-filtered variables. + zfact = 1.0 / rn_Dt + ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3t*T)/e3tn; e3tn cancel from pts(Kmm) terms + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kaa) * (1._wp + r3t(:,:,Kaa) * tmask(:,:,jk))/(1._wp + r3t(:,:,Kmm) * tmask(:,:,jk)) & + & - pts(:,:,jk,jp_tem,Kmm) ) * zfact + ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kaa) * (1._wp + r3t(:,:,Kaa) * tmask(:,:,jk))/(1._wp + r3t(:,:,Kmm) * tmask(:,:,jk)) & + & - pts(:,:,jk,jp_sal,Kmm) ) * zfact + END DO + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_tot, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_tot, ztrds ) + IF( ln_linssh ) THEN ! linear sea surface height only + ! Store now fields before applying the Asselin filter + ! in order to calculate Asselin filter trend later. + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kmm) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Kmm) + ENDIF + ENDIF + + IF( l_1st_euler ) THEN ! Euler time-stepping + ! + IF (l_trdtra .AND. .NOT. ln_linssh ) THEN ! Zero Asselin filter contribution must be explicitly written out since for vvl + ! ! Asselin filter is output by tra_atf_vvl that is not called on this time step + ztrdt(:,:,:) = 0._wp + ztrds(:,:,:) = 0._wp + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_atf, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_atf, ztrds ) + END IF + ! + ELSE ! Leap-Frog + Asselin filter time stepping + ! + IF ( ln_linssh ) THEN ; CALL tra_atf_fix_lf( kt, Kbb, Kmm, Kaa, nit000, 'TRA', pts, jpts ) ! linear free surface + ELSE ; CALL tra_atf_qco_lf( kt, Kbb, Kmm, Kaa, nit000, rn_Dt, 'TRA', pts, sbc_tsc, sbc_tsc_b, jpts ) ! non-linear free surface + ENDIF + ! + CALL lbc_lnk( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1._dp, pts(:,:,:,jp_sal,Kmm) , 'T', 1._dp ) + ! + ENDIF + ! + IF( l_trdtra .AND. ln_linssh ) THEN ! trend of the Asselin filter (tb filtered - tb)/dt + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( pts(:,:,jk,jp_tem,Kmm) - ztrdt(:,:,jk) ) * r1_Dt + ztrds(:,:,jk) = ( pts(:,:,jk,jp_sal,Kmm) - ztrds(:,:,jk) ) * r1_Dt + END DO + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_tem, jptra_atf, ztrdt ) + CALL trd_tra( kt, Kmm, Kaa, 'TRA', jp_sal, jptra_atf, ztrds ) + END IF + IF( l_trdtra ) DEALLOCATE( ztrdt , ztrds ) + ! + ! ! control print + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kmm), clinfo1=' nxt - Tn: ', mask1=tmask, & + & tab3d_2=pts(:,:,:,jp_sal,Kmm), clinfo2= ' Sn: ', mask2=tmask ) + ! + IF( ln_timing ) CALL timing_stop('tra_atf_qco') + ! + END SUBROUTINE tra_atf_qco + + + SUBROUTINE tra_atf_fix_lf( kt, Kbb, Kmm, Kaa, kit000, cdtype, pt, kjpt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_atf_fix *** + !! + !! ** Purpose : fixed volume: apply the Asselin time filter to the "now" field + !! + !! ** Method : - Apply a Asselin time filter on now fields. + !! + !! ** Action : - pt(Kmm) ready for the next time step + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztn, ztd ! local scalars + !!---------------------------------------------------------------------- + ! + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_atf_fix_lf : time filtering', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + DO jn = 1, kjpt + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + ztn = pt(ji,jj,jk,jn,Kmm) + ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb) ! time laplacian on tracers + ! + pt(ji,jj,jk,jn,Kmm) = ztn + rn_atfp * ztd ! pt <-- filtered pt + END_3D + ! + END DO + ! + END SUBROUTINE tra_atf_fix_lf + + + SUBROUTINE tra_atf_qco_lf( kt, Kbb, Kmm, Kaa, kit000, p2dt, cdtype, pt, psbc_tc, psbc_tc_b, kjpt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_atf_vvl *** + !! + !! ** Purpose : Time varying volume: apply the Asselin time filter + !! + !! ** Method : - Apply a thickness weighted Asselin time filter on now fields. + !! pt(Kmm) = ( e3t_m*pt(Kmm) + rn_atfp*[ e3t_b*pt(Kbb) - 2 e3t_m*pt(Kmm) + e3t_a*pt(Kaa) ] ) + !! /( e3t_m + rn_atfp*[ e3t_b - 2 e3t_m + e3t_a ] ) + !! + !! ** Action : - pt(Kmm) ready for the next time step + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Kaa ! time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + REAL(wp) , INTENT(in ) :: p2dt ! time-step + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracer fields + REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc ! surface tracer content + REAL(wp), DIMENSION(jpi,jpj ,kjpt) , INTENT(in ) :: psbc_tc_b ! before surface tracer content + ! + LOGICAL :: ll_traqsr, ll_rnf, ll_isf ! local logical + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(dp) :: zfact, zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d ! local scalar + REAL(dp) :: zfact2, ze3t_b, ze3t_n, ze3t_a, ze3t_f ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztrd_atf + !!---------------------------------------------------------------------- + ! + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_atf_qco : time filtering', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + IF( cdtype == 'TRA' ) THEN + ll_traqsr = ln_traqsr ! active tracers case and solar penetration + ll_rnf = ln_rnf ! active tracers case and river runoffs + ll_isf = ln_isf ! active tracers case and ice shelf melting + ELSE ! passive tracers case + ll_traqsr = .FALSE. ! NO solar penetration + ll_rnf = .FALSE. ! NO river runoffs ???? !!gm BUG ? + ll_isf = .FALSE. ! NO ice shelf melting/freezing !!gm BUG ?? + ENDIF + ! + IF( ( l_trdtra .AND. cdtype == 'TRA' ) .OR. ( l_trdtrc .AND. cdtype == 'TRC' ) ) THEN + ALLOCATE( ztrd_atf(jpi,jpj,jpk,kjpt) ) + ztrd_atf(:,:,:,:) = 0.0_wp + ENDIF + zfact = 1._wp / p2dt + zfact1 = rn_atfp * p2dt + zfact2 = zfact1 * r1_rho0 + DO jn = 1, kjpt + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + ze3t_b = e3t(ji,jj,jk,Kbb) + ze3t_n = e3t(ji,jj,jk,Kmm) + ze3t_a = e3t(ji,jj,jk,Kaa) + ! ! tracer content at Before, now and after + ztc_b = pt(ji,jj,jk,jn,Kbb) * ze3t_b + ztc_n = pt(ji,jj,jk,jn,Kmm) * ze3t_n + ztc_a = pt(ji,jj,jk,jn,Kaa) * ze3t_a + ! + ztc_d = ztc_a - 2. * ztc_n + ztc_b + ! + ztc_f = ztc_n + rn_atfp * ztc_d + ! + ! Asselin correction on scale factors is done via ssh in r3t_f + ze3t_f = e3t_0(ji,jj,jk) * ( 1._wp + r3t_f(ji,jj) * tmask(ji,jj,jk) ) + + ! + IF( jk == mikt(ji,jj) ) THEN ! first level + ztc_f = ztc_f - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) + ENDIF + ! + ! solar penetration (temperature only) + IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr ) & + & ztc_f = ztc_f - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) ) + ! + ! + IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) ) & + & ztc_f = ztc_f - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) & + & * e3t(ji,jj,jk,Kmm) / h_rnf(ji,jj) + + ! + ! ice shelf + IF( ll_isf ) THEN + ! + ! melt in the cavity + IF ( ln_isfcav_mlt ) THEN + ! level fully include in the Losch_2008 ice shelf boundary layer + IF ( jk >= misfkt_cav(ji,jj) .AND. jk < misfkb_cav(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) ) & + & * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) + END IF + ! level partially include in Losch_2008 ice shelf boundary layer + IF ( jk == misfkb_cav(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) ) & + & * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) & + & * rfrac_tbl_cav(ji,jj) + END IF + END IF + ! + ! parametrised melt (cavity closed) + IF ( ln_isfpar_mlt ) THEN + ! level fully include in the Losch_2008 ice shelf boundary layer + IF ( jk >= misfkt_par(ji,jj) .AND. jk < misfkb_par(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) ) & + & * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) + END IF + ! level partially include in Losch_2008 ice shelf boundary layer + IF ( jk == misfkb_par(ji,jj) ) THEN + ztc_f = ztc_f - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) ) & + & * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) & + & * rfrac_tbl_par(ji,jj) + END IF + END IF + ! + ! ice sheet coupling correction + IF ( ln_isfcpl ) THEN + ! + ! at kt = nit000, risfcpl_vol_n = 0 and risfcpl_vol_b = risfcpl_vol so contribution nul + IF ( ln_rstart .AND. kt == nit000+1 ) THEN + ztc_f = ztc_f + zfact1 * risfcpl_tsc(ji,jj,jk,jn) * r1_e1e2t(ji,jj) + ! Shouldn't volume increment be spread according thanks to zscale ? + END IF + ! + END IF + ! + END IF + ! + ze3t_f = 1.e0 / ze3t_f + pt(ji,jj,jk,jn,Kmm) = ztc_f * ze3t_f ! time filtered "now" field + ! + IF( ( l_trdtra .and. cdtype == 'TRA' ) .OR. ( l_trdtrc .and. cdtype == 'TRC' ) ) THEN + ztrd_atf(ji,jj,jk,jn) = (ztc_f - ztc_n) * zfact/ze3t_n + ENDIF + ! + END_3D + ! + END DO + ! + IF( ( l_trdtra .AND. cdtype == 'TRA' ) .OR. ( l_trdtrc .AND. cdtype == 'TRC' ) ) THEN + IF( l_trdtra .AND. cdtype == 'TRA' ) THEN + CALL trd_tra( kt, Kmm, Kaa, cdtype, jp_tem, jptra_atf, ztrd_atf(:,:,:,jp_tem) ) + CALL trd_tra( kt, Kmm, Kaa, cdtype, jp_sal, jptra_atf, ztrd_atf(:,:,:,jp_sal) ) + ENDIF + IF( l_trdtrc .AND. cdtype == 'TRC' ) THEN + DO jn = 1, kjpt + CALL trd_tra( kt, Kmm, Kaa, cdtype, jn, jptra_atf, ztrd_atf(:,:,:,jn) ) + END DO + ENDIF + DEALLOCATE( ztrd_atf ) + ENDIF + ! + END SUBROUTINE tra_atf_qco_lf + + !!====================================================================== +END MODULE traatf_qco diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trabbc.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trabbc.F90 new file mode 100644 index 0000000..51d95cc --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trabbc.F90 @@ -0,0 +1,196 @@ +MODULE trabbc + !!============================================================================== + !! *** MODULE trabbc *** + !! Ocean active tracers: bottom boundary condition (geothermal heat flux) + !!============================================================================== + !! History : OPA ! 1999-10 (G. Madec) original code + !! NEMO 1.0 ! 2002-08 (G. Madec) free form + modules + !! - ! 2002-11 (A. Bozec) tra_bbc_init: original code + !! 3.3 ! 2010-10 (G. Madec) dynamical allocation + suppression of key_trabbc + !! - ! 2010-11 (G. Madec) use mbkt array (deepest ocean t-level) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_bbc : update the tracer trend at ocean bottom + !! tra_bbc_init : initialization of geothermal heat flux trend + !!---------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce ! domain: ocean + USE phycst ! physical constants + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + ! + USE in_out_manager ! I/O manager + USE iom ! xIOS + USE fldread ! read input fields + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing library + USE prtctl ! Print control + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_bbc ! routine called by step.F90 + PUBLIC tra_bbc_init ! routine called by opa.F90 + + ! !!* Namelist nambbc: bottom boundary condition * + LOGICAL, PUBLIC :: ln_trabbc !: Geothermal heat flux flag + INTEGER :: nn_geoflx ! Geothermal flux (=1:constant flux, =2:read in file ) + REAL(wp) :: rn_geoflx_cst ! Constant value of geothermal heat flux + + REAL(wp), PUBLIC , ALLOCATABLE, DIMENSION(:,:) :: qgh_trd0 ! geothermal heating trend + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_qgh ! structure of input qgh (file informations, fields read) + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trabbc.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_bbc( kt, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_bbc *** + !! + !! ** Purpose : Compute the bottom boundary contition on temperature + !! associated with geothermal heating and add it to the + !! general trend of temperature equations. + !! + !! ** Method : The geothermal heat flux set to its constant value of + !! 86.4 mW/m2 (Stein and Stein 1992, Huang 1999). + !! The temperature trend associated to this heat flux through the + !! ocean bottom can be computed once and is added to the temperature + !! trend juste above the bottom at each time step: + !! ta = ta + Qsf / (rho0 rcp e3T) for k= mbkt + !! Where Qsf is the geothermal heat flux. + !! + !! ** Action : - update the temperature trends with geothermal heating trend + !! - send the trend for further diagnostics (ln_trdtra=T) + !! + !! References : Stein, C. A., and S. Stein, 1992, Nature, 359, 123-129. + !! Emile-Geay and Madec, 2009, Ocean Science. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(in ) :: Kmm, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt ! 3D workspace + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_bbc') + ! + IF( l_trdtra ) THEN ! Save the input temperature trend + ALLOCATE( ztrdt(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) + ENDIF + ! ! Add the geothermal trend on temperature + DO_2D( 0, 0, 0, 0 ) + pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) = pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) & + & + qgh_trd0(ji,jj) / e3t(ji,jj,mbkt(ji,jj),Kmm) + END_2D + ! + IF( l_trdtra ) THEN ! Send the trend for diagnostics + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_bbc, ztrdt ) + DEALLOCATE( ztrdt ) + ENDIF + ! + CALL iom_put ( "hfgeou" , rho0_rcp * qgh_trd0(:,:) ) + + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbc - Ta: ', mask1=tmask, clinfo3='tra-ta' ) + + IF( ln_timing ) CALL timing_stop('tra_bbc') + ! + END SUBROUTINE tra_bbc + + + SUBROUTINE tra_bbc_init + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_bbc_init *** + !! + !! ** Purpose : Compute once for all the trend associated with geothermal + !! heating that will be applied at each time step at the + !! last ocean level + !! + !! ** Method : Read the nambbc namelist and check the parameters. + !! + !! ** Input : - Namlist nambbc + !! - NetCDF file : geothermal_heating.nc ( if necessary ) + !! + !! ** Action : - read/fix the geothermal heat qgh_trd0 + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: inum ! temporary logical unit + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: ierror ! local integer + ! + TYPE(FLD_N) :: sn_qgh ! informations about the geotherm. field to be read + CHARACTER(len=256) :: cn_dir ! Root directory for location of ssr files + !! + NAMELIST/nambbc/ln_trabbc, nn_geoflx, rn_geoflx_cst, sn_qgh, cn_dir + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, nambbc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbc in reference namelist' ) + ! + READ ( numnam_cfg, nambbc, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambbc in configuration namelist' ) + IF(lwm) WRITE ( numond, nambbc ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'tra_bbc : Bottom Boundary Condition (bbc), apply a Geothermal heating' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' Namelist nambbc : set bbc parameters' + WRITE(numout,*) ' Apply a geothermal heating at ocean bottom ln_trabbc = ', ln_trabbc + WRITE(numout,*) ' type of geothermal flux nn_geoflx = ', nn_geoflx + WRITE(numout,*) ' Constant geothermal flux value rn_geoflx_cst = ', rn_geoflx_cst + WRITE(numout,*) + ENDIF + ! + IF( ln_trabbc ) THEN !== geothermal heating ==! + ! + ALLOCATE( qgh_trd0(jpi,jpj) ) ! allocation + ! + SELECT CASE ( nn_geoflx ) ! geothermal heat flux / (rauO * Cp) + ! + CASE ( 1 ) !* constant flux + IF(lwp) WRITE(numout,*) ' ==>>> constant heat flux = ', rn_geoflx_cst + qgh_trd0(:,:) = r1_rho0_rcp * rn_geoflx_cst + ! + CASE ( 2 ) !* variable geothermal heat flux : read the geothermal fluxes in mW/m2 + IF(lwp) WRITE(numout,*) ' ==>>> variable geothermal heat flux' + ! + ALLOCATE( sf_qgh(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'tra_bbc_init: unable to allocate sf_qgh structure' ) ; + RETURN + ENDIF + ALLOCATE( sf_qgh(1)%fnow(jpi,jpj,1) ) + IF( sn_qgh%ln_tint ) ALLOCATE( sf_qgh(1)%fdta(jpi,jpj,1,2) ) + ! fill sf_chl with sn_chl and control print + CALL fld_fill( sf_qgh, (/ sn_qgh /), cn_dir, 'tra_bbc_init', & + & 'bottom temperature boundary condition', 'nambbc', no_print ) + + CALL fld_read( nit000, 1, sf_qgh ) ! Read qgh data + qgh_trd0(:,:) = r1_rho0_rcp * sf_qgh(1)%fnow(:,:,1) * 1.e-3 ! conversion in W/m2 + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for nn_geoflx = ', nn_geoflx + CALL ctl_stop( ctmp1 ) + END SELECT + ! + ELSE + IF(lwp) WRITE(numout,*) ' ==>>> no geothermal heat flux' + ENDIF + ! + END SUBROUTINE tra_bbc_init + + !!====================================================================== +END MODULE trabbc \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trabbl.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trabbl.F90 new file mode 100644 index 0000000..4ed6616 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trabbl.F90 @@ -0,0 +1,543 @@ +MODULE trabbl + !!============================================================================== + !! *** MODULE trabbl *** + !! Ocean physics : advective and/or diffusive bottom boundary layer scheme + !!============================================================================== + !! History : OPA ! 1996-06 (L. Mortier) Original code + !! 8.0 ! 1997-11 (G. Madec) Optimization + !! NEMO 1.0 ! 2002-08 (G. Madec) free form + modules + !! - ! 2004-01 (A. de Miranda, G. Madec, J.M. Molines ) add advective bbl + !! 3.3 ! 2009-11 (G. Madec) merge trabbl and trabbl_adv + style + optimization + !! - ! 2010-04 (G. Madec) Campin & Goosse advective bbl + !! - ! 2010-06 (C. Ethe, G. Madec) merge TRA-TRC + !! - ! 2010-11 (G. Madec) add mbk. arrays associated to the deepest ocean level + !! - ! 2013-04 (F. Roquet, G. Madec) use of eosbn2 instead of local hard coded alpha and beta + !! 4.0 ! 2017-04 (G. Madec) ln_trabbl namelist variable instead of a CPP key + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_bbl_alloc : allocate trabbl arrays + !! tra_bbl : update the tracer trends due to the bottom boundary layer (advective and/or diffusive) + !! tra_bbl_dif : generic routine to compute bbl diffusive trend + !! tra_bbl_adv : generic routine to compute bbl advective trend + !! bbl : computation of bbl diffu. flux coef. & transport in bottom boundary layer + !! tra_bbl_init : initialization, namelist read, parameters control + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constant + USE eosbn2 ! equation of state + USE trd_oce ! trends: ocean variables + USE trdtra ! trends: active tracers + ! + USE iom ! IOM library + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions + USE prtctl ! Print control + USE timing ! Timing + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_bbl ! routine called by step.F90 + PUBLIC tra_bbl_init ! routine called by nemogcm.F90 + PUBLIC tra_bbl_dif ! routine called by trcbbl.F90 + PUBLIC tra_bbl_adv ! - - - + PUBLIC bbl ! routine called by trcbbl.F90 and dtadyn.F90 + + ! !!* Namelist nambbl * + LOGICAL , PUBLIC :: ln_trabbl !: bottom boundary layer flag + INTEGER , PUBLIC :: nn_bbl_ldf !: =1 : diffusive bbl or not (=0) + INTEGER , PUBLIC :: nn_bbl_adv !: =1/2 : advective bbl or not (=0) + ! ! =1 : advective bbl using the bottom ocean velocity + ! ! =2 : - - using utr_bbl proportional to grad(rho) + REAL(wp), PUBLIC :: rn_ahtbbl !: along slope bbl diffusive coefficient [m2/s] + REAL(wp), PUBLIC :: rn_gambbl !: lateral coeff. for bottom boundary layer scheme [s] + + LOGICAL , PUBLIC :: l_bbl !: flag to compute bbl diffu. flux coef and transport + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: utr_bbl , vtr_bbl ! u- (v-) transport in the bottom boundary layer + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: ahu_bbl , ahv_bbl ! masked diffusive bbl coeff. at u & v-pts + + INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: mbku_d , mbkv_d ! vertical index of the "lower" bottom ocean U/V-level (PUBLIC for TAM) + INTEGER , ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: mgrhu , mgrhv ! = +/-1, sign of grad(H) in u-(v-)direction (PUBLIC for TAM) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahu_bbl_0, ahv_bbl_0 ! diffusive bbl flux coefficients at u and v-points + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: e3u_bbl_0, e3v_bbl_0 ! thichness of the bbl (e3) at u and v-points (PUBLIC for TAM) + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trabbl.F90 15053 2021-06-24 15:39:38Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION tra_bbl_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION tra_bbl_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( utr_bbl (jpi,jpj) , ahu_bbl (jpi,jpj) , mbku_d(jpi,jpj) , mgrhu(jpi,jpj) , & + & vtr_bbl (jpi,jpj) , ahv_bbl (jpi,jpj) , mbkv_d(jpi,jpj) , mgrhv(jpi,jpj) , & + & ahu_bbl_0(jpi,jpj) , ahv_bbl_0(jpi,jpj) , & + & e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) , STAT=tra_bbl_alloc ) + ! + CALL mpp_sum ( 'trabbl', tra_bbl_alloc ) + IF( tra_bbl_alloc > 0 ) CALL ctl_warn('tra_bbl_alloc: allocation of arrays failed.') + END FUNCTION tra_bbl_alloc + + + SUBROUTINE tra_bbl( kt, Kbb, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bbl *** + !! + !! ** Purpose : Compute the before tracer (t & s) trend associated + !! with the bottom boundary layer and add it to the general + !! trend of tracer equations. + !! + !! ** Method : Depending on namtra_bbl namelist parameters the bbl + !! diffusive and/or advective contribution to the tracer trend + !! is added to the general tracer trend + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step + INTEGER, INTENT(in ) :: Kbb, Kmm, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk ! Dummy loop indices + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'tra_bbl') + ! + IF( l_trdtra ) THEN !* Save the T-S input trends + ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) + ENDIF + + IF( l_bbl ) CALL bbl( kt, nit000, 'TRA', Kbb, Kmm ) !* bbl coef. and transport (only if not already done in trcbbl) + + IF( nn_bbl_ldf == 1 ) THEN !* Diffusive bbl + ! + CALL tra_bbl_dif( pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, Kmm ) + IF( sn_cfctl%l_prtctl ) & + CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_ldf - Ta: ', mask1=tmask, & + & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + CALL iom_put( "ahu_bbl", ahu_bbl ) ! bbl diffusive flux i-coef + CALL iom_put( "ahv_bbl", ahv_bbl ) ! bbl diffusive flux j-coef + ! + ENDIF + ! + IF( nn_bbl_adv /= 0 ) THEN !* Advective bbl + ! + CALL tra_bbl_adv( pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, Kmm ) + IF(sn_cfctl%l_prtctl) & + CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_adv - Ta: ', mask1=tmask, & + & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + CALL iom_put( "uoce_bbl", utr_bbl ) ! bbl i-transport + CALL iom_put( "voce_bbl", vtr_bbl ) ! bbl j-transport + ! + ENDIF + + IF( l_trdtra ) THEN ! send the trends for further diagnostics + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_bbl, ztrdt ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_bbl, ztrds ) + DEALLOCATE( ztrdt, ztrds ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop( 'tra_bbl') + ! + END SUBROUTINE tra_bbl + + + SUBROUTINE tra_bbl_dif( pt, pt_rhs, kjpt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_bbl_dif *** + !! + !! ** Purpose : Computes the bottom boundary horizontal and vertical + !! advection terms. + !! + !! ** Method : * diffusive bbl only (nn_bbl_ldf=1) : + !! When the product grad( rho) * grad(h) < 0 (where grad is an + !! along bottom slope gradient) an additional lateral 2nd order + !! diffusion along the bottom slope is added to the general + !! tracer trend, otherwise the additional trend is set to 0. + !! A typical value of ahbt is 2000 m2/s (equivalent to + !! a downslope velocity of 20 cm/s if the condition for slope + !! convection is satified) + !! + !! ** Action : pt_rhs increased by the bbl diffusive trend + !! + !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. + !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! before and now tracer fields + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend + INTEGER , INTENT(in ) :: Kmm ! time level indices + ! + INTEGER :: ji, jj, jn ! dummy loop indices + INTEGER :: ik ! local integers + REAL(wp) :: zbtr ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zptb ! workspace + !!---------------------------------------------------------------------- + ! + DO jn = 1, kjpt ! tracer loop + ! ! =========== + DO_2D( 1, 1, 1, 1 ) + ik = mbkt(ji,jj) ! bottom T-level index + zptb(ji,jj) = pt(ji,jj,ik,jn) ! bottom before T and S + END_2D + ! + DO_2D( 0, 0, 0, 0 ) ! Compute the trend + ik = mbkt(ji,jj) ! bottom T-level index + pt_rhs(ji,jj,ik,jn) = pt_rhs(ji,jj,ik,jn) & + & + ( ahu_bbl(ji ,jj ) * ( zptb(ji+1,jj ) - zptb(ji ,jj ) ) & + & - ahu_bbl(ji-1,jj ) * ( zptb(ji ,jj ) - zptb(ji-1,jj ) ) & + & + ahv_bbl(ji ,jj ) * ( zptb(ji ,jj+1) - zptb(ji ,jj ) ) & + & - ahv_bbl(ji ,jj-1) * ( zptb(ji ,jj ) - zptb(ji ,jj-1) ) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,ik,Kmm) + END_2D + ! ! =========== + END DO ! end tracer + ! ! =========== + END SUBROUTINE tra_bbl_dif + + + ! NOTE: [tiling] tiling changes the results, but only the order of floating point operations is different + SUBROUTINE tra_bbl_adv( pt, pt_rhs, kjpt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_bbl *** + !! + !! ** Purpose : Compute the before passive tracer trend associated + !! with the bottom boundary layer and add it to the general trend + !! of tracer equations. + !! ** Method : advective bbl (nn_bbl_adv = 1 or 2) : + !! nn_bbl_adv = 1 use of the ocean near bottom velocity as bbl velocity + !! nn_bbl_adv = 2 follow Campin and Goosse (1999) implentation i.e. + !! transport proportional to the along-slope density gradient + !! + !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. + !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! before and now tracer fields + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend + INTEGER , INTENT(in ) :: Kmm ! time level indices + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: iis , iid , ijs , ijd ! local integers + INTEGER :: ikus, ikud, ikvs, ikvd ! - - + REAL(wp) :: zbtr, ztra ! local scalars + REAL(wp) :: zu_bbl, zv_bbl ! - - + !!---------------------------------------------------------------------- + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + DO_2D_OVR( 1, 0, 1, 0 ) ! CAUTION start from i=1 to update i=2 when cyclic east-west + IF( utr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero i-direction bbl advection + ! down-slope i/k-indices (deep) & up-slope i/k indices (shelf) + iid = ji + MAX( 0, mgrhu(ji,jj) ) ; iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) + ikud = mbku_d(ji,jj) ; ikus = mbku(ji,jj) + zu_bbl = ABS( utr_bbl(ji,jj) ) + ! + ! ! up -slope T-point (shelf bottom point) + zbtr = r1_e1e2t(iis,jj) / e3t(iis,jj,ikus,Kmm) + ztra = zu_bbl * ( pt(iid,jj,ikus,jn) - pt(iis,jj,ikus,jn) ) * zbtr + pt_rhs(iis,jj,ikus,jn) = pt_rhs(iis,jj,ikus,jn) + ztra + ! + DO jk = ikus, ikud-1 ! down-slope upper to down T-point (deep column) + zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,jk,Kmm) + ztra = zu_bbl * ( pt(iid,jj,jk+1,jn) - pt(iid,jj,jk,jn) ) * zbtr + pt_rhs(iid,jj,jk,jn) = pt_rhs(iid,jj,jk,jn) + ztra + END DO + ! + zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,ikud,Kmm) + ztra = zu_bbl * ( pt(iis,jj,ikus,jn) - pt(iid,jj,ikud,jn) ) * zbtr + pt_rhs(iid,jj,ikud,jn) = pt_rhs(iid,jj,ikud,jn) + ztra + ENDIF + ! + IF( vtr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero j-direction bbl advection + ! down-slope j/k-indices (deep) & up-slope j/k indices (shelf) + ijd = jj + MAX( 0, mgrhv(ji,jj) ) ; ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) + ikvd = mbkv_d(ji,jj) ; ikvs = mbkv(ji,jj) + zv_bbl = ABS( vtr_bbl(ji,jj) ) + ! + ! up -slope T-point (shelf bottom point) + zbtr = r1_e1e2t(ji,ijs) / e3t(ji,ijs,ikvs,Kmm) + ztra = zv_bbl * ( pt(ji,ijd,ikvs,jn) - pt(ji,ijs,ikvs,jn) ) * zbtr + pt_rhs(ji,ijs,ikvs,jn) = pt_rhs(ji,ijs,ikvs,jn) + ztra + ! + DO jk = ikvs, ikvd-1 ! down-slope upper to down T-point (deep column) + zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,jk,Kmm) + ztra = zv_bbl * ( pt(ji,ijd,jk+1,jn) - pt(ji,ijd,jk,jn) ) * zbtr + pt_rhs(ji,ijd,jk,jn) = pt_rhs(ji,ijd,jk,jn) + ztra + END DO + ! ! down-slope T-point (deep bottom point) + zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,ikvd,Kmm) + ztra = zv_bbl * ( pt(ji,ijs,ikvs,jn) - pt(ji,ijd,ikvd,jn) ) * zbtr + pt_rhs(ji,ijd,ikvd,jn) = pt_rhs(ji,ijd,ikvd,jn) + ztra + ENDIF + END_2D + ! ! =========== + END DO ! end tracer + ! ! =========== + END SUBROUTINE tra_bbl_adv + + + SUBROUTINE bbl( kt, kit000, cdtype, Kbb, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE bbl *** + !! + !! ** Purpose : Computes the bottom boundary horizontal and vertical + !! advection terms. + !! + !! ** Method : * diffusive bbl (nn_bbl_ldf=1) : + !! When the product grad( rho) * grad(h) < 0 (where grad is an + !! along bottom slope gradient) an additional lateral 2nd order + !! diffusion along the bottom slope is added to the general + !! tracer trend, otherwise the additional trend is set to 0. + !! A typical value of ahbt is 2000 m2/s (equivalent to + !! a downslope velocity of 20 cm/s if the condition for slope + !! convection is satified) + !! * advective bbl (nn_bbl_adv=1 or 2) : + !! nn_bbl_adv = 1 use of the ocean velocity as bbl velocity + !! nn_bbl_adv = 2 follow Campin and Goosse (1999) implentation + !! i.e. transport proportional to the along-slope density gradient + !! + !! NB: the along slope density gradient is evaluated using the + !! local density (i.e. referenced at a common local depth). + !! + !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. + !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level index + ! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ik ! local integers + INTEGER :: iis, iid, ikus, ikud ! - - + INTEGER :: ijs, ijd, ikvs, ikvd ! - - + REAL(wp) :: za, zb, zgdrho ! local scalars + REAL(wp) :: zsign, zsigna, zgbbl ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zts, zab ! 3D workspace + REAL(wp), DIMENSION(A2D(nn_hls)) :: zub, zvb, zdep ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'trabbl:bbl : Compute bbl velocities and diffusive coefficients in ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ENDIF + ENDIF + ! !* bottom variables (T, S, alpha, beta, depth, velocity) + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ik = mbkt(ji,jj) ! bottom T-level index + zts (ji,jj,jp_tem) = ts(ji,jj,ik,jp_tem,Kbb) ! bottom before T and S + zts (ji,jj,jp_sal) = ts(ji,jj,ik,jp_sal,Kbb) + ! + zdep(ji,jj) = gdept(ji,jj,ik,Kmm) ! bottom T-level reference depth + zub (ji,jj) = uu(ji,jj,mbku(ji,jj),Kmm) ! bottom velocity + zvb (ji,jj) = vv(ji,jj,mbkv(ji,jj),Kmm) + END_2D + ! + CALL eos_rab( zts, zdep, zab, Kmm ) + ! + ! !-------------------! + IF( nn_bbl_ldf == 1 ) THEN ! diffusive bbl ! + ! !-------------------! + DO_2D_OVR( 1, 0, 1, 0 ) ! (criteria for non zero flux: grad(rho).grad(h) < 0 ) + ! ! i-direction + za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point + zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) + ! ! 2*masked bottom density gradient + zgdrho = ( za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) ) & + & - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1) + ! + zsign = SIGN( 0.5_wp, -zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of ( i-gradient * i-slope ) + ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj) ! masked diffusive flux coeff. + ! + ! ! j-direction + za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point + zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) + ! ! 2*masked bottom density gradient + zgdrho = ( za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) ) & + & - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1) + ! + zsign = SIGN( 0.5_wp, -zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of ( j-gradient * j-slope ) + ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) + END_2D + ! + ENDIF + ! + ! !-------------------! + IF( nn_bbl_adv /= 0 ) THEN ! advective bbl ! + ! !-------------------! + SELECT CASE ( nn_bbl_adv ) !* bbl transport type + ! + CASE( 1 ) != use of upper velocity + DO_2D_OVR( 1, 0, 1, 0 ) ! criteria: grad(rho).grad(h)<0 and grad(rho).grad(h)<0 + ! ! i-direction + za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point + zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) + ! ! 2*masked bottom density gradient + zgdrho = ( za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) ) & + - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) ) ) * umask(ji,jj,1) + ! + zsign = SIGN( 0.5_wp, - zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of i-gradient * i-slope + zsigna= SIGN( 0.5_wp, zub(ji,jj) * REAL( mgrhu(ji,jj) ) ) ! sign of u * i-slope + ! + ! ! bbl velocity + utr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e2u(ji,jj) * e3u_bbl_0(ji,jj) * zub(ji,jj) + ! + ! ! j-direction + za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point + zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) + ! ! 2*masked bottom density gradient + zgdrho = ( za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) ) & + & - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) ) ) * vmask(ji,jj,1) + zsign = SIGN( 0.5_wp, - zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of j-gradient * j-slope + zsigna= SIGN( 0.5_wp, zvb(ji,jj) * REAL( mgrhv(ji,jj) ) ) ! sign of u * i-slope + ! + ! ! bbl transport + vtr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e1v(ji,jj) * e3v_bbl_0(ji,jj) * zvb(ji,jj) + END_2D + ! + CASE( 2 ) != bbl velocity = F( delta rho ) + zgbbl = grav * rn_gambbl + DO_2D_OVR( 1, 0, 1, 0 ) ! criteria: rho_up > rho_down + ! ! i-direction + ! down-slope T-point i/k-index (deep) & up-slope T-point i/k-index (shelf) + iid = ji + MAX( 0, mgrhu(ji,jj) ) + iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) + ! + ikud = mbku_d(ji,jj) + ikus = mbku(ji,jj) + ! + za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at u-point + zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) + ! ! masked bottom density gradient + zgdrho = 0.5 * ( za * ( zts(iid,jj,jp_tem) - zts(iis,jj,jp_tem) ) & + & - zb * ( zts(iid,jj,jp_sal) - zts(iis,jj,jp_sal) ) ) * umask(ji,jj,1) + zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep + ! + ! ! bbl transport (down-slope direction) + utr_bbl(ji,jj) = e2u(ji,jj) * e3u_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhu(ji,jj) ) + ! + ! ! j-direction + ! down-slope T-point j/k-index (deep) & of the up -slope T-point j/k-index (shelf) + ijd = jj + MAX( 0, mgrhv(ji,jj) ) + ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) + ! + ikvd = mbkv_d(ji,jj) + ikvs = mbkv(ji,jj) + ! + za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem) ! 2*(alpha,beta) at v-point + zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) + ! ! masked bottom density gradient + zgdrho = 0.5 * ( za * ( zts(ji,ijd,jp_tem) - zts(ji,ijs,jp_tem) ) & + & - zb * ( zts(ji,ijd,jp_sal) - zts(ji,ijs,jp_sal) ) ) * vmask(ji,jj,1) + zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep + ! + ! ! bbl transport (down-slope direction) + vtr_bbl(ji,jj) = e1v(ji,jj) * e3v_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhv(ji,jj) ) + END_2D + END SELECT + ! + ENDIF + ! + END SUBROUTINE bbl + + + SUBROUTINE tra_bbl_init + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_bbl_init *** + !! + !! ** Purpose : Initialization for the bottom boundary layer scheme. + !! + !! ** Method : Read the nambbl namelist and check the parameters + !! called by nemo_init at the first timestep (kit000) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ii0, ii1, ij0, ij1, ios ! local integer + REAL(wp), DIMENSION(jpi,jpj) :: zmbku, zmbkv ! workspace + !! + NAMELIST/nambbl/ ln_trabbl, nn_bbl_ldf, nn_bbl_adv, rn_ahtbbl, rn_gambbl + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, nambbl, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbl in reference namelist' ) + ! + READ ( numnam_cfg, nambbl, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambbl in configuration namelist' ) + IF(lwm) WRITE ( numond, nambbl ) + ! + l_bbl = .TRUE. !* flag to compute bbl coef and transport + ! + IF(lwp) THEN !* Parameter control and print + WRITE(numout,*) + WRITE(numout,*) 'tra_bbl_init : bottom boundary layer initialisation' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist nambbl : set bbl parameters' + WRITE(numout,*) ' bottom boundary layer flag ln_trabbl = ', ln_trabbl + ENDIF + IF( .NOT.ln_trabbl ) RETURN + ! + IF(lwp) THEN + WRITE(numout,*) ' diffusive bbl (=1) or not (=0) nn_bbl_ldf = ', nn_bbl_ldf + WRITE(numout,*) ' advective bbl (=1/2) or not (=0) nn_bbl_adv = ', nn_bbl_adv + WRITE(numout,*) ' diffusive bbl coefficient rn_ahtbbl = ', rn_ahtbbl, ' m2/s' + WRITE(numout,*) ' advective bbl coefficient rn_gambbl = ', rn_gambbl, ' s' + ENDIF + ! + ! ! allocate trabbl arrays + IF( tra_bbl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'tra_bbl_init : unable to allocate arrays' ) + ! + IF(lwp) THEN + IF( nn_bbl_adv == 1 ) WRITE(numout,*) ' * Advective BBL using upper velocity' + IF( nn_bbl_adv == 2 ) WRITE(numout,*) ' * Advective BBL using velocity = F( delta rho)' + ENDIF + ! + ! !* vertical index of "deep" bottom u- and v-points + DO_2D( 1, 0, 1, 0 ) ! (the "shelf" bottom k-indices are mbku and mbkv) + mbku_d(ji,jj) = MAX( mbkt(ji+1,jj ) , mbkt(ji,jj) ) ! >= 1 as mbkt=1 over land + mbkv_d(ji,jj) = MAX( mbkt(ji ,jj+1) , mbkt(ji,jj) ) + END_2D + ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk + zmbku(:,:) = REAL( mbku_d(:,:), wp ) ; zmbkv(:,:) = REAL( mbkv_d(:,:), wp ) + CALL lbc_lnk( 'trabbl', zmbku,'U',1.0_wp, zmbkv,'V',1.0_wp) + mbku_d(:,:) = MAX( INT( zmbku(:,:) ), 1 ) ; mbkv_d(:,:) = MAX( NINT( zmbkv(:,:) ), 1 ) + ! + ! !* sign of grad(H) at u- and v-points; zero if grad(H) = 0 + mgrhu(:,:) = 0 ; mgrhv(:,:) = 0 + DO_2D( 1, 0, 1, 0 ) + IF( gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN + mgrhu(ji,jj) = INT( SIGN( 1.0_wp, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) ) ) + ENDIF + ! + IF( gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN + mgrhv(ji,jj) = INT( SIGN( 1.0_wp, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) ) ) + ENDIF + END_2D + ! + DO_2D( 1, 0, 1, 0 ) !* bbl thickness at u- (v-) point; minimum of top & bottom e3u_0 (e3v_0) + e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj )), e3u_0(ji,jj,mbkt(ji,jj)) ) + e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) + END_2D + CALL lbc_lnk( 'trabbl', e3u_bbl_0, 'U', 1.0_wp , e3v_bbl_0, 'V', 1.0_wp ) ! lateral boundary conditions + ! + ! !* masked diffusive flux coefficients + ahu_bbl_0(:,:) = rn_ahtbbl * e2_e1u(:,:) * e3u_bbl_0(:,:) * umask(:,:,1) + ahv_bbl_0(:,:) = rn_ahtbbl * e1_e2v(:,:) * e3v_bbl_0(:,:) * vmask(:,:,1) + ! + END SUBROUTINE tra_bbl_init + + !!====================================================================== +END MODULE trabbl \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/tradmp.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/tradmp.F90 new file mode 100644 index 0000000..a03069c --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/tradmp.F90 @@ -0,0 +1,243 @@ +MODULE tradmp + !!====================================================================== + !! *** MODULE tradmp *** + !! Ocean physics: internal restoring trend on active tracers (T and S) + !!====================================================================== + !! History : OPA ! 1991-03 (O. Marti, G. Madec) Original code + !! ! 1992-06 (M. Imbard) doctor norme + !! ! 1998-07 (M. Imbard, G. Madec) ORCA version + !! 7.0 ! 2001-02 (M. Imbard) add distance to coast, Original code + !! 8.1 ! 2001-02 (G. Madec, E. Durand) cleaning + !! NEMO 1.0 ! 2002-08 (G. Madec, E. Durand) free form + modules + !! 3.2 ! 2009-08 (G. Madec, C. Talandier) DOCTOR norm for namelist parameter + !! 3.3 ! 2010-06 (C. Ethe, G. Madec) merge TRA-TRC + !! 3.4 ! 2011-04 (G. Madec, C. Ethe) Merge of dtatem and dtasal + suppression of CPP keys + !! 3.6 ! 2015-06 (T. Graham) read restoring coefficient in a file + !! 3.7 ! 2015-10 (G. Madec) remove useless trends arrays + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_dmp_alloc : allocate tradmp arrays + !! tra_dmp : update the tracer trend with the internal damping + !! tra_dmp_init : initialization, namlist read, parameters control + !!---------------------------------------------------------------------- + USE oce ! ocean: variables + USE dom_oce ! ocean: domain variables + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + USE zdf_oce ! ocean: vertical physics + USE phycst ! physical constants + USE dtatsd ! data: temperature & salinity + USE zdfmxl ! vertical physics: mixed layer depth + ! + USE in_out_manager ! I/O manager + USE iom ! XIOS + USE lib_mpp ! MPP library + USE prtctl ! Print control + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_dmp ! called by step.F90 + PUBLIC tra_dmp_init ! called by nemogcm.F90 + + ! !!* Namelist namtra_dmp : T & S newtonian damping * + LOGICAL , PUBLIC :: ln_tradmp !: internal damping flag + INTEGER , PUBLIC :: nn_zdmp !: = 0/1/2 flag for damping in the mixed layer + CHARACTER(LEN=200) , PUBLIC :: cn_resto !: name of netcdf file containing restoration coefficient field + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: resto !: restoring coeff. on T and S (s-1) + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: tradmp.F90 15023 2021-06-18 14:35:25Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION tra_dmp_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION tra_dmp_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( resto(jpi,jpj,jpk), STAT= tra_dmp_alloc ) + ! + CALL mpp_sum ( 'tradmp', tra_dmp_alloc ) + IF( tra_dmp_alloc > 0 ) CALL ctl_warn('tra_dmp_alloc: allocation of arrays failed') + ! + END FUNCTION tra_dmp_alloc + + + SUBROUTINE tra_dmp( kt, Kbb, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_dmp *** + !! + !! ** Purpose : Compute the tracer trend due to a newtonian damping + !! of the tracer field towards given data field and add it to the + !! general tracer trends. + !! + !! ** Method : Newtonian damping towards t_dta and s_dta computed + !! and add to the general tracer trends: + !! ta = ta + resto * (t_dta - tb) + !! sa = sa + resto * (s_dta - sb) + !! The trend is computed either throughout the water column + !! (nlmdmp=0) or in area of weak vertical mixing (nlmdmp=1) or + !! below the well mixed layer (nlmdmp=2) + !! + !! ** Action : - tsa: tracer trends updated with the damping trend + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(in ) :: Kbb, Kmm, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(dp), DIMENSION(A2D(nn_hls),jpk,jpts) :: zts_dta + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: zwrk + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: ztrdts + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_dmp') + ! + IF( l_trdtra .OR. iom_use('hflx_dmp_cea') .OR. iom_use('sflx_dmp_cea') ) THEN !* Save ta and sa trends + ALLOCATE( ztrdts(A2D(nn_hls),jpk,jpts) ) + DO jn = 1, jpts + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) + ztrdts(ji,jj,jk,jn) = pts(ji,jj,jk,jn,Krhs) + END_3D + END DO + ENDIF + ! !== input T-S data at kt ==! + CALL dta_tsd( kt, zts_dta ) ! read and interpolates T-S data at kt + ! + SELECT CASE ( nn_zdmp ) !== type of damping ==! + ! + CASE( 0 ) !* newtonian damping throughout the water column *! + DO jn = 1, jpts + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + pts(ji,jj,jk,jn,Krhs) = pts(ji,jj,jk,jn,Krhs) & + & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jn) - pts(ji,jj,jk,jn,Kbb) ) + END_3D + END DO + ! + CASE ( 1 ) !* no damping in the turbocline (avt > 5 cm2/s) *! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + IF( avt(ji,jj,jk) <= avt_c ) THEN + pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) & + & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - pts(ji,jj,jk,jp_tem,Kbb) ) + pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) & + & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - pts(ji,jj,jk,jp_sal,Kbb) ) + ENDIF + END_3D + ! + CASE ( 2 ) !* no damping in the mixed layer *! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + IF( gdept(ji,jj,jk,Kmm) >= hmlp (ji,jj) ) THEN + pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) & + & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - pts(ji,jj,jk,jp_tem,Kbb) ) + pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) & + & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - pts(ji,jj,jk,jp_sal,Kbb) ) + ENDIF + END_3D + ! + END SELECT + ! + ! outputs (clem trunk) + IF( iom_use('hflx_dmp_cea') .OR. iom_use('sflx_dmp_cea') ) THEN + ALLOCATE( zwrk(A2D(nn_hls),jpk) ) ! Needed to handle expressions containing e3t when using key_qco or key_linssh + zwrk(:,:,:) = 0._wp + + IF( iom_use('hflx_dmp_cea') ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + zwrk(ji,jj,jk) = ( pts(ji,jj,jk,jp_tem,Krhs) - ztrdts(ji,jj,jk,jp_tem) ) * e3t(ji,jj,jk,Kmm) + END_3D + CALL iom_put('hflx_dmp_cea', SUM( zwrk(:,:,:), dim=3 ) * rcp * rho0 ) ! W/m2 + ENDIF + IF( iom_use('sflx_dmp_cea') ) THEN + DO_3D( 0, 0, 0, 0, 1, jpk ) + zwrk(ji,jj,jk) = ( pts(ji,jj,jk,jp_sal,Krhs) - ztrdts(ji,jj,jk,jp_sal) ) * e3t(ji,jj,jk,Kmm) + END_3D + CALL iom_put('sflx_dmp_cea', SUM( zwrk(:,:,:), dim=3 ) * rho0 ) ! g/m2/s + ENDIF + + DEALLOCATE( zwrk ) + ENDIF + ! + IF( l_trdtra ) THEN ! trend diagnostic + ztrdts(:,:,:,:) = pts(:,:,:,:,Krhs) - ztrdts(:,:,:,:) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) ) + DEALLOCATE( ztrdts ) + ENDIF + ! ! Control print + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' dmp - Ta: ', mask1=tmask, & + & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! + IF( ln_timing ) CALL timing_stop('tra_dmp') + ! + END SUBROUTINE tra_dmp + + + SUBROUTINE tra_dmp_init + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_dmp_init *** + !! + !! ** Purpose : Initialization for the newtonian damping + !! + !! ** Method : read the namtra_dmp namelist and check the parameters + !!---------------------------------------------------------------------- + INTEGER :: ios, imask ! local integers + ! + NAMELIST/namtra_dmp/ ln_tradmp, nn_zdmp, cn_resto + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist' ) + ! + READ ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist' ) + IF(lwm) WRITE ( numond, namtra_dmp ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) + WRITE(numout,*) 'tra_dmp_init : T and S newtonian relaxation' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namtra_dmp : set relaxation parameters' + WRITE(numout,*) ' Apply relaxation or not ln_tradmp = ', ln_tradmp + WRITE(numout,*) ' mixed layer damping option nn_zdmp = ', nn_zdmp + WRITE(numout,*) ' Damping file name cn_resto = ', cn_resto + WRITE(numout,*) + ENDIF + ! + IF( ln_tradmp ) THEN + ! ! Allocate arrays + IF( tra_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'tra_dmp_init: unable to allocate arrays' ) + ! + SELECT CASE (nn_zdmp) ! Check values of nn_zdmp + CASE ( 0 ) ; IF(lwp) WRITE(numout,*) ' tracer damping as specified by mask' + CASE ( 1 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the mixing layer (kz > 5 cm2/s)' + CASE ( 2 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the mixed layer' + CASE DEFAULT + CALL ctl_stop('tra_dmp_init : wrong value of nn_zdmp') + END SELECT + ! + !!TG: Initialisation of dtatsd - Would it be better to have dmpdta routine + ! so can damp to something other than intitial conditions files? + !!gm: In principle yes. Nevertheless, we can't anticipate demands that have never been formulated. + IF( .NOT.ln_tsd_dmp ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout, *) ' read T-S data not initialized, we force ln_tsd_dmp=T' + CALL dta_tsd_init( ld_tradmp=ln_tradmp ) ! forces the initialisation of T-S data + ENDIF + ! ! Read in mask from file + CALL iom_open ( cn_resto, imask) + CALL iom_get ( imask, jpdom_auto, 'resto', resto ) + CALL iom_close( imask ) + ENDIF + ! + END SUBROUTINE tra_dmp_init + + !!====================================================================== +END MODULE tradmp \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traisf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traisf.F90 new file mode 100644 index 0000000..03e504e --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traisf.F90 @@ -0,0 +1,156 @@ +MODULE traisf + !!============================================================================== + !! *** MODULE traisf *** + !! Ocean active tracers: ice shelf boundary condition + !!============================================================================== + !! History : 4.0 ! 2019-09 (P. Mathiot) original file + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_isf : update the tracer trend at ocean surface + !!---------------------------------------------------------------------- + USE isf_oce ! Ice shelf variables + USE par_oce , ONLY : nijtile, ntile, ntsi, ntei, ntsj, ntej + USE dom_oce ! ocean space domain variables + USE isfutils, ONLY : debug ! debug option + USE timing , ONLY : timing_start, timing_stop ! Timing + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_isf ! routine called by step.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trasbc.F90 10499 2019-01-10 15:12:24Z deazer $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_isf ( kt, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_isf *** + !! + !! ** Purpose : Compute the temperature trend due to the ice shelf melting (qhoce + qhc) + !! + !! ** Action : - update pts(:,:,:,:,Krhs) for cav, par and cpl case + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_isf') + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_isf : Ice shelf heat fluxes' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + ENDIF + ! + ! cavity case + IF ( ln_isfcav_mlt ) CALL tra_isf_mlt(misfkt_cav, misfkb_cav, rhisf_tbl_cav, rfrac_tbl_cav, risf_cav_tsc, risf_cav_tsc_b, pts(:,:,:,:,Krhs)) + ! + ! parametrisation case + IF ( ln_isfpar_mlt ) CALL tra_isf_mlt(misfkt_par, misfkb_par, rhisf_tbl_par, rfrac_tbl_par, risf_par_tsc, risf_par_tsc_b, pts(:,:,:,:,Krhs)) + ! + ! ice sheet coupling case + IF ( ln_isfcpl ) THEN + ! + ! Dynamical stability at start up after change in under ice shelf cavity geometry is achieve by correcting the divergence. + ! This is achieved by applying a volume flux in order to keep the horizontal divergence after remapping + ! the same as at the end of the latest time step. So correction need to be apply at nit000 (euler time step) and + ! half of it at nit000+1 (leap frog time step). + ! in accordance to this, the heat content flux due to injected water need to be added in the temperature and salt trend + ! at time step nit000 and nit000+1 + IF ( kt == nit000 ) CALL tra_isf_cpl(Kmm, risfcpl_tsc , pts(:,:,:,:,Krhs)) + IF ( kt == nit000+1) CALL tra_isf_cpl(Kmm, risfcpl_tsc*0.5_wp, pts(:,:,:,:,Krhs)) + ! + ! ensure 0 trend due to unconservation of the ice shelf coupling + IF ( ln_isfcpl_cons ) CALL tra_isf_cpl(Kmm, risfcpl_cons_tsc, pts(:,:,:,:,Krhs)) + ! + END IF + ! + IF ( ln_isfdebug ) THEN + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only for the full domain + CALL debug('tra_isf: pts(:,:,:,:,Krhs) T', pts(:,:,:,1,Krhs)) + CALL debug('tra_isf: pts(:,:,:,:,Krhs) S', pts(:,:,:,2,Krhs)) + ENDIF + END IF + ! + IF( ln_timing ) CALL timing_stop('tra_isf') + ! + END SUBROUTINE tra_isf + ! + SUBROUTINE tra_isf_mlt(ktop, kbot, phtbl, pfrac, ptsc, ptsc_b, pts) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_isf_mlt *** + !! + !! *** Purpose : Compute the temperature trend due to the ice shelf melting (qhoce + qhc) for cav or par case + !! + !! *** Action :: Update pts(:,:,:,:,Krhs) with the surface boundary condition trend + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) :: pts + !!---------------------------------------------------------------------- + INTEGER , DIMENSION(jpi,jpj) , INTENT(in ) :: ktop , kbot + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: phtbl, pfrac + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: ptsc , ptsc_b + !!---------------------------------------------------------------------- + INTEGER :: ji,jj,jk ! loop index + INTEGER :: ikt, ikb ! top and bottom level of the tbl + REAL(wp), DIMENSION(A2D(nn_hls)) :: ztc ! total ice shelf tracer trend + !!---------------------------------------------------------------------- + ! + ! compute 2d total trend due to isf + DO_2D( 0, 0, 0, 0 ) + ztc(ji,jj) = 0.5_wp * ( ptsc(ji,jj,jp_tem) + ptsc_b(ji,jj,jp_tem) ) / phtbl(ji,jj) + END_2D + ! + ! update pts(:,:,:,:,Krhs) + DO_2D( 0, 0, 0, 0 ) + ! + ikt = ktop(ji,jj) + ikb = kbot(ji,jj) + ! + ! level fully include in the ice shelf boundary layer + DO jk = ikt, ikb - 1 + pts(ji,jj,jk,jp_tem) = pts(ji,jj,jk,jp_tem) + ztc(ji,jj) + END DO + ! + ! level partially include in ice shelf boundary layer + pts(ji,jj,ikb,jp_tem) = pts(ji,jj,ikb,jp_tem) + ztc(ji,jj) * pfrac(ji,jj) + ! + END_2D + ! + END SUBROUTINE tra_isf_mlt + ! + SUBROUTINE tra_isf_cpl( Kmm, ptsc, ptsa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_isf_cpl *** + !! + !! *** Action :: Update pts(:,:,:,:,Krhs) with the ice shelf coupling trend + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) :: ptsa + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: ptsc + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk + !!---------------------------------------------------------------------- + ! + DO_3D( 0, 0, 0, 0, 1, jpk ) + ptsa(ji,jj,jk,jp_tem) = ptsa(ji,jj,jk,jp_tem) + ptsc(ji,jj,jk,jp_tem) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + ptsa(ji,jj,jk,jp_sal) = ptsa(ji,jj,jk,jp_sal) + ptsc(ji,jj,jk,jp_sal) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_3D + ! + END SUBROUTINE tra_isf_cpl + ! +END MODULE traisf \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traldf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traldf.F90 new file mode 100644 index 0000000..140b666 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traldf.F90 @@ -0,0 +1,128 @@ +MODULE traldf + !!====================================================================== + !! *** MODULE traldf *** + !! Ocean Active tracers : lateral diffusive trends + !!===================================================================== + !! History : 9.0 ! 2005-11 (G. Madec) Original code + !! NEMO 3.0 ! 2008-01 (C. Ethe, G. Madec) merge TRC-TRA + !! 3.7 ! 2013-12 (G. Madec) remove the optional computation from T & S anomaly profiles and traldf_bilapg + !! - ! 2013-12 (F. Lemarie, G. Madec) triad operator (Griffies) + Method of Stabilizing Correction + !! - ! 2014-01 (G. Madec, S. Masson) restructuration/simplification of lateral diffusive operators + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_ldf : update the tracer trend with the lateral diffusion trend + !! tra_ldf_init : initialization, namelist read, and parameters control + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. + USE ldfslp ! lateral diffusion: iso-neutral slope + USE traldf_lap_blp ! lateral diffusion: laplacian iso-level operator (tra_ldf_lap/_blp routines) + USE traldf_iso ! lateral diffusion: laplacian iso-neutral standard operator (tra_ldf_iso routine ) + USE traldf_triad ! lateral diffusion: laplacian iso-neutral triad operator (tra_ldf_triad routine ) + USE trd_oce ! trends: ocean variables + USE trdtra ! ocean active tracers trends + ! + USE prtctl ! Print control + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_ldf ! called by step.F90 + PUBLIC tra_ldf_init ! called by nemogcm.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traldf.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_ldf( kt, Kbb, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_ldf *** + !! + !! ** Purpose : compute the lateral ocean tracer physics. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(in ) :: Kbb, Kmm, Krhs ! ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + !! + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_ldf') + ! + IF( l_trdtra ) THEN !* Save ta and sa trends + ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) + ENDIF + ! + SELECT CASE ( nldf_tra ) !* compute lateral mixing trend and add it to the general trend + CASE ( np_lap ) ! laplacian: iso-level operator + CALL tra_ldf_lap ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) + CASE ( np_lap_i ) ! laplacian: standard iso-neutral operator (Madec) + CALL tra_ldf_iso ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) + CASE ( np_lap_it ) ! laplacian: triad iso-neutral operator (griffies) + CALL tra_ldf_triad( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) + CASE ( np_blp , np_blp_i , np_blp_it ) ! bilaplacian: iso-level & iso-neutral operators + CALL tra_ldf_blp ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, nldf_tra ) + END SELECT + ! + IF( l_trdtra ) THEN !* save the horizontal diffusive trends for further diagnostics + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_ldf, ztrdt ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_ldf, ztrds ) + DEALLOCATE( ztrdt, ztrds ) + ENDIF + ! !* print mean trends (used for debugging) + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' ldf - Ta: ', mask1=tmask, & + & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! + IF( ln_timing ) CALL timing_stop('tra_ldf') + ! + END SUBROUTINE tra_ldf + + + SUBROUTINE tra_ldf_init + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_ldf_init *** + !! + !! ** Purpose : Choice of the operator for the lateral tracer diffusion + !! + !! ** Method : set nldf_tra from the namtra_ldf logicals + !!---------------------------------------------------------------------- + INTEGER :: ioptio, ierr ! temporary integers + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN !== Namelist print ==! + WRITE(numout,*) + WRITE(numout,*) 'tra_ldf_init : lateral tracer diffusive operator' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namtra_ldf: already read in ldftra module' + WRITE(numout,*) ' see ldf_tra_init report for lateral mixing parameters' + WRITE(numout,*) + ! + SELECT CASE( nldf_tra ) ! print the choice of operator + CASE( np_no_ldf ) ; WRITE(numout,*) ' ==>>> NO lateral diffusion' + CASE( np_lap ) ; WRITE(numout,*) ' ==>>> laplacian iso-level operator' + CASE( np_lap_i ) ; WRITE(numout,*) ' ==>>> Rotated laplacian operator (standard)' + CASE( np_lap_it ) ; WRITE(numout,*) ' ==>>> Rotated laplacian operator (triad)' + CASE( np_blp ) ; WRITE(numout,*) ' ==>>> bilaplacian iso-level operator' + CASE( np_blp_i ) ; WRITE(numout,*) ' ==>>> Rotated bilaplacian operator (standard)' + CASE( np_blp_it ) ; WRITE(numout,*) ' ==>>> Rotated bilaplacian operator (triad)' + END SELECT + ENDIF + ! + END SUBROUTINE tra_ldf_init + + !!====================================================================== +END MODULE traldf \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traldf_iso.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traldf_iso.F90 new file mode 100644 index 0000000..cd2d3e5 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traldf_iso.F90 @@ -0,0 +1,408 @@ +MODULE traldf_iso + !!====================================================================== + !! *** MODULE traldf_iso *** + !! Ocean tracers: horizontal component of the lateral tracer mixing trend + !!====================================================================== + !! History : OPA ! 1994-08 (G. Madec, M. Imbard) + !! 8.0 ! 1997-05 (G. Madec) split into traldf and trazdf + !! NEMO ! 2002-08 (G. Madec) Free form, F90 + !! 1.0 ! 2005-11 (G. Madec) merge traldf and trazdf :-) + !! 3.3 ! 2010-09 (C. Ethe, G. Madec) Merge TRA-TRC + !! 3.7 ! 2014-01 (G. Madec, S. Masson) restructuration/simplification of aht/aeiv specification + !! - ! 2014-02 (F. Lemarie, G. Madec) triad operator (Griffies) + Method of Stabilizing Correction + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_ldf_iso : update the tracer trend with the horizontal component of a iso-neutral laplacian operator + !! and with the vertical part of the isopycnal or geopotential s-coord. operator + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE domutl, ONLY : is_tile + USE trc_oce ! share passive tracers/Ocean variables + USE zdf_oce ! ocean vertical physics + USE ldftra ! lateral diffusion: tracer eddy coefficients + USE ldfslp ! iso-neutral slopes + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE phycst ! physical constants + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_ldf_iso ! routine called by step.F90 + + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat transport + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traldf_iso.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_ldf_iso( kt, Kmm, kit000, cdtype, pahu, pahv, & + & pgu , pgv , pgui, pgvi, & + & pt, pt2, pt_rhs, kjpt, kpass ) + !! + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend + !! + CALL tra_ldf_iso_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu), & + & pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), & + & pt, is_tile(pt), pt2, is_tile(pt2), pt_rhs, is_tile(pt_rhs), kjpt, kpass ) + END SUBROUTINE tra_ldf_iso + + + SUBROUTINE tra_ldf_iso_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah, & + & pgu , pgv , ktg , pgui, pgvi, ktgi, & + & pt, ktt, pt2, ktt2, pt_rhs, ktt_rhs, kjpt, kpass ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_ldf_iso *** + !! + !! ** Purpose : Compute the before horizontal tracer (t & s) diffusive + !! trend for a laplacian tensor (ezxcept the dz[ dz[.] ] term) and + !! add it to the general trend of tracer equation. + !! + !! ** Method : The horizontal component of the lateral diffusive trends + !! is provided by a 2nd order operator rotated along neural or geopo- + !! tential surfaces to which an eddy induced advection can be added + !! It is computed using before fields (forward in time) and isopyc- + !! nal or geopotential slopes computed in routine ldfslp. + !! + !! 1st part : masked horizontal derivative of T ( di[ t ] ) + !! ======== with partial cell update if ln_zps=T + !! with top cell update if ln_isfcav + !! + !! 2nd part : horizontal fluxes of the lateral mixing operator + !! ======== + !! zftu = pahu e2u*e3u/e1u di[ tb ] + !! - pahu e2u*uslp dk[ mi(mk(tb)) ] + !! zftv = pahv e1v*e3v/e2v dj[ tb ] + !! - pahv e2u*vslp dk[ mj(mk(tb)) ] + !! take the horizontal divergence of the fluxes: + !! difft = 1/(e1e2t*e3t) { di-1[ zftu ] + dj-1[ zftv ] } + !! Add this trend to the general trend (ta,sa): + !! ta = ta + difft + !! + !! 3rd part: vertical trends of the lateral mixing operator + !! ======== (excluding the vertical flux proportional to dk[t] ) + !! vertical fluxes associated with the rotated lateral mixing: + !! zftw = - { mi(mk(pahu)) * e2t*wslpi di[ mi(mk(tb)) ] + !! + mj(mk(pahv)) * e1t*wslpj dj[ mj(mk(tb)) ] } + !! take the horizontal divergence of the fluxes: + !! difft = 1/(e1e2t*e3t) dk[ zftw ] + !! Add this trend to the general trend (ta,sa): + !! pt_rhs = pt_rhs + difft + !! + !! ** Action : Update pt_rhs arrays with the before rotated diffusion + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt2, ktt_rhs + REAL(wp), DIMENSION(A2D_T(ktah) ,JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(A2D_T(ktg) ,KJPT), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(A2D_T(ktgi) ,KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(dp), DIMENSION(A2D_T(ktt) ,JPK,KJPT), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) + REAL(dp), DIMENSION(A2D_T(ktt2) ,JPK,KJPT), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) + REAL(dp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: ikt + INTEGER :: ierr, iij ! local integer + REAL(wp) :: zmsku, zahu_w, zabe1, zcof1, zcoef3 ! local scalars + REAL(wp) :: zmskv, zahv_w, zabe2, zcof2, zcoef4 ! - - + REAL(wp) :: zcoef0, ze3w_2, zsign ! - - + REAL(wp), DIMENSION(A2D(nn_hls)) :: zdkt, zdk1t, z2d + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdit, zdjt, zftu, zftv, ztfw + !!---------------------------------------------------------------------- + ! + IF( kpass == 1 .AND. kt == kit000 ) THEN + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_ldf_iso : rotated laplacian diffusion operator on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + akz (ji,jj,jk) = 0._wp + ah_wslp2(ji,jj,jk) = 0._wp + END_3D + ENDIF + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + l_hst = .FALSE. + l_ptr = .FALSE. + IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE. + IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. + ENDIF + ! + ! Define pt_rhs halo points for multi-point haloes in bilaplacian case + IF( nldf_tra == np_blp_i .AND. kpass == 1 ) THEN ; iij = nn_hls + ELSE ; iij = 1 + ENDIF + + ! + IF( kpass == 1 ) THEN ; zsign = 1._wp ! bilaplacian operator require a minus sign (eddy diffusivity >0) + ELSE ; zsign = -1._wp + ENDIF + + !!---------------------------------------------------------------------- + !! 0 - calculate ah_wslp2 and akz + !!---------------------------------------------------------------------- + ! + IF( kpass == 1 ) THEN !== first pass only ==! + ! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + ! + zmsku = wmask(ji,jj,jk) / MAX( umask(ji ,jj,jk-1) + umask(ji-1,jj,jk) & + & + umask(ji-1,jj,jk-1) + umask(ji ,jj,jk) , 1._wp ) + zmskv = wmask(ji,jj,jk) / MAX( vmask(ji,jj ,jk-1) + vmask(ji,jj-1,jk) & + & + vmask(ji,jj-1,jk-1) + vmask(ji,jj ,jk) , 1._wp ) + ! + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zahu_w = ( ( pahu(ji ,jj,jk-1) + pahu(ji-1,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( pahu(ji-1,jj,jk-1) + pahu(ji ,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * zmsku + zahv_w = ( ( pahv(ji,jj ,jk-1) + pahv(ji,jj-1,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( pahv(ji,jj-1,jk-1) + pahv(ji,jj ,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * zmskv + ! + ah_wslp2(ji,jj,jk) = zahu_w * wslpi(ji,jj,jk) * wslpi(ji,jj,jk) & + & + zahv_w * wslpj(ji,jj,jk) * wslpj(ji,jj,jk) + END_3D + ! + IF( ln_traldf_msc ) THEN ! stabilizing vertical diffusivity coefficient + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + akz(ji,jj,jk) = 0.25_wp * ( & + & ( ( pahu(ji ,jj,jk) + pahu(ji ,jj,jk-1) ) / ( e1u(ji ,jj) * e1u(ji ,jj) ) & + & + ( pahu(ji-1,jj,jk) + pahu(ji-1,jj,jk-1) ) / ( e1u(ji-1,jj) * e1u(ji-1,jj) ) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( ( pahv(ji,jj ,jk) + pahv(ji,jj ,jk-1) ) / ( e2v(ji,jj ) * e2v(ji,jj ) ) & + & + ( pahv(ji,jj-1,jk) + pahv(ji,jj-1,jk-1) ) / ( e2v(ji,jj-1) * e2v(ji,jj-1) ) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) + END_3D + ! + IF( ln_traldf_blp ) THEN ! bilaplacian operator + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + akz(ji,jj,jk) = 16._wp & + & * ah_wslp2 (ji,jj,jk) & + & * ( akz (ji,jj,jk) & + & + ah_wslp2(ji,jj,jk) & + & / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) ) ) + END_3D + ELSEIF( ln_traldf_lap ) THEN ! laplacian operator + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) + zcoef0 = rDt * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2 ) + akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * r1_Dt + END_3D + ENDIF + ! + ELSE ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + akz(ji,jj,jk) = ah_wslp2(ji,jj,jk) + END_3D + ENDIF + ENDIF + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + ! + !!---------------------------------------------------------------------- + !! I - masked horizontal derivative + !!---------------------------------------------------------------------- + zdit(:,:,:) = 0._wp + zdjt(:,:,:) = 0._wp + + ! Horizontal tracer gradient + DO_3D( iij, iij-1, iij, iij-1, 1, jpkm1 ) + zdit(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) + zdjt(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk) + END_3D + IF( ln_zps ) THEN ! botton and surface ocean correction of the horizontal gradient + DO_2D( iij, iij-1, iij, iij-1 ) ! bottom correction (partial bottom cell) + zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) + zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) + END_2D + IF( ln_isfcav ) THEN ! first wet level beneath a cavity + DO_2D( iij, iij-1, iij, iij-1 ) + IF( miku(ji,jj) > 1 ) zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn) + IF( mikv(ji,jj) > 1 ) zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn) + END_2D + ENDIF + ENDIF + ! + !!---------------------------------------------------------------------- + !! II - horizontal trend (full) + !!---------------------------------------------------------------------- + ! + DO jk = 1, jpkm1 ! Horizontal slab + ! + DO_2D( iij, iij, iij, iij ) + ! !== Vertical tracer gradient + zdk1t(ji,jj) = ( pt(ji,jj,jk,jn) - pt(ji,jj,jk+1,jn) ) * wmask(ji,jj,jk+1) ! level jk+1 + ! + IF( jk == 1 ) THEN ; zdkt(ji,jj) = zdk1t(ji,jj) ! surface: zdkt(jk=1)=zdkt(jk=2) + ELSE ; zdkt(ji,jj) = ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) * wmask(ji,jj,jk) + ENDIF + END_2D + ! + DO_2D( iij, iij-1, iij, iij-1 ) !== Horizontal fluxes + zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) + zabe2 = pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) + ! + zmsku = 1. / MAX( wmask(ji+1,jj,jk ) + wmask(ji,jj,jk+1) & + & + wmask(ji+1,jj,jk+1) + wmask(ji,jj,jk ), 1. ) + ! + zmskv = 1. / MAX( wmask(ji,jj+1,jk ) + wmask(ji,jj,jk+1) & + & + wmask(ji,jj+1,jk+1) + wmask(ji,jj,jk ), 1. ) + ! + zcof1 = - pahu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku + zcof2 = - pahv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv + ! + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zftu(ji,jj,jk ) = ( zabe1 * zdit(ji,jj,jk) & + & + zcof1 * ( ( zdkt (ji+1,jj) + zdk1t(ji,jj) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( zdk1t(ji+1,jj) + zdkt (ji,jj) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) ) * umask(ji,jj,jk) + zftv(ji,jj,jk) = ( zabe2 * zdjt(ji,jj,jk) & + & + zcof2 * ( ( zdkt (ji,jj+1) + zdk1t(ji,jj) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( zdk1t(ji,jj+1) + zdkt (ji,jj) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) ) * vmask(ji,jj,jk) + END_2D + ! + DO_2D( iij-1, iij-1, iij-1, iij-1 ) !== horizontal divergence and add to pta + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) & + & + zsign * ( ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( zftv(ji,jj,jk) - zftv(ji,jj-1,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) + END_2D + END DO ! End of slab + + !!---------------------------------------------------------------------- + !! III - vertical trend (full) + !!---------------------------------------------------------------------- + ! + ! Vertical fluxes + ! --------------- + ! ! Surface and bottom vertical fluxes set to zero + ztfw(:,:, 1 ) = 0._wp ; ztfw(:,:,jpk) = 0._wp + + DO_3D( iij-1, iij-1, iij-1, iij-1, 2, jpkm1 ) ! interior (2=0) + ELSE ; zsign = -1._wp + ENDIF + + DO_3D( iij, iij-1, iij, iij-1, 1, jpkm1 ) !== First derivative (gradient) ==! + zaheeu(ji,jj,jk) = zsign * pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) !!gm * umask(ji,jj,jk) pah masked! + zaheev(ji,jj,jk) = zsign * pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) !!gm * vmask(ji,jj,jk) + END_3D + ! + ! ! =========== ! + DO jn = 1, kjpt ! tracer loop ! + ! ! =========== ! + ! + DO_3D( iij, iij-1, iij, iij-1, 1, jpkm1 ) !== First derivative (gradient) ==! + ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) + ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) + END_3D + IF( ln_zps ) THEN ! set gradient at bottom/top ocean level + DO_2D( iij, iij-1, iij, iij-1 ) ! bottom + ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn) + ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn) + END_2D + IF( ln_isfcav ) THEN ! top in ocean cavities only + DO_2D( iij, iij-1, iij, iij-1 ) + IF( miku(ji,jj) > 1 ) ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn) + IF( mikv(ji,jj) > 1 ) ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn) + END_2D + ENDIF + ENDIF + ! + DO_3D( iij-1, iij-1, iij-1, iij-1, 1, jpkm1 ) !== Second derivative (divergence) added to the general tracer trends ==! + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + ( ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( ztv(ji,jj,jk) - ztv(ji,jj-1,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) + END_3D + ! + ! !== "Poleward" diffusive heat or salt transports ==! + IF( ( kpass == 1 .AND. .NOT.ln_traldf_blp ) .OR. & !== first pass only ( laplacian) ==! + ( kpass == 2 .AND. ln_traldf_blp ) ) THEN !== 2nd pass only (bilaplacian) ==! + + IF( l_ptr ) CALL dia_ptr_hst( jn, 'ldf', -ztv(:,:,:) ) + IF( l_hst ) CALL dia_ar5_hst( jn, 'ldf', -ztu(:,:,:), -ztv(:,:,:) ) + ENDIF + ! ! ================== + END DO ! end of tracer loop + ! ! ================== + ! + END SUBROUTINE tra_ldf_lap_t + + + SUBROUTINE tra_ldf_blp( kt, Kmm, kit000, cdtype, pahu, pahv , & + & pgu , pgv , pgui, pgvi, & + & pt , pt_rhs, kjpt, kldf ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_ldf_blp *** + !! + !! ** Purpose : Compute the before lateral tracer diffusive + !! trend and add it to the general trend of tracer equation. + !! + !! ** Method : The lateral diffusive trends is provided by a bilaplacian + !! operator applied to before field (forward in time). + !! It is computed by two successive calls to laplacian routine + !! + !! ** Action : pta updated with the before rotated bilaplacian diffusion + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kldf ! type of operator used + INTEGER , INTENT(in ) :: Kmm ! ocean time level indices + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! before and now tracer fields + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(dp), DIMENSION(A2D(nn_hls),jpk,kjpt) :: zlap ! laplacian at t-point + REAL(wp), DIMENSION(A2D(nn_hls), kjpt) :: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points) + REAL(wp), DIMENSION(A2D(nn_hls), kjpt) :: zgui, zgvi ! top GRADh of the laplacian (u- and v-points) + !!--------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == kit000 .AND. lwp ) THEN + WRITE(numout,*) + SELECT CASE ( kldf ) + CASE ( np_blp ) ; WRITE(numout,*) 'tra_ldf_blp : iso-level bilaplacian operator on ', cdtype + CASE ( np_blp_i ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (Standard)' + CASE ( np_blp_it ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (triad)' + END SELECT + WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ENDIF + + zlap(:,:,:,:) = 0._wp + ! + SELECT CASE ( kldf ) !== 1st laplacian applied to pt (output in zlap) ==! + ! + CASE ( np_blp ) ! iso-level bilaplacian + CALL tra_ldf_lap ( kt, Kmm, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, pt, zlap, kjpt, 1 ) + CASE ( np_blp_i ) ! rotated bilaplacian : standard operator (Madec) + CALL tra_ldf_iso ( kt, Kmm, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, pt, pt, zlap, kjpt, 1 ) + CASE ( np_blp_it ) ! rotated bilaplacian : triad operator (griffies) + CALL tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, pt, pt, zlap, kjpt, 1 ) + END SELECT + ! + IF (nn_hls==1) CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1.0_dp ) ! Lateral boundary conditions (unchanged sign) + ! ! Partial top/bottom cell: GRADh( zlap ) + IF( ln_isfcav .AND. ln_zps ) THEN ; CALL zps_hde_isf( kt, Kmm, kjpt, zlap, zglu, zglv, zgui, zgvi ) ! both top & bottom + ELSEIF( ln_zps ) THEN ; CALL zps_hde ( kt, Kmm, kjpt, zlap, zglu, zglv ) ! only bottom + ENDIF + ! + SELECT CASE ( kldf ) !== 2nd laplacian applied to zlap (output in pt_rhs) ==! + ! + CASE ( np_blp ) ! iso-level bilaplacian + CALL tra_ldf_lap ( kt, Kmm, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pt_rhs, kjpt, 2 ) + CASE ( np_blp_i ) ! rotated bilaplacian : standard operator (Madec) + CALL tra_ldf_iso ( kt, Kmm, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pt , pt_rhs, kjpt, 2 ) + CASE ( np_blp_it ) ! rotated bilaplacian : triad operator (griffies) + CALL tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pt , pt_rhs, kjpt, 2 ) + END SELECT + ! + END SUBROUTINE tra_ldf_blp + + !!============================================================================== +END MODULE traldf_lap_blp diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traldf_triad.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traldf_triad.F90 new file mode 100644 index 0000000..667ab49 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traldf_triad.F90 @@ -0,0 +1,506 @@ +MODULE traldf_triad + !!====================================================================== + !! *** MODULE traldf_triad *** + !! Ocean tracers: horizontal component of the lateral tracer mixing trend + !!====================================================================== + !! History : 3.3 ! 2010-10 (G. Nurser, C. Harris, G. Madec) Griffies operator (original code) + !! 3.7 ! 2013-12 (F. Lemarie, G. Madec) triad operator (Griffies) + Method of Stabilizing Correction + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_ldf_triad : update the tracer trend with the iso-neutral laplacian triad-operator + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE domutl, ONLY : is_tile + USE phycst ! physical constants + USE trc_oce ! share passive tracers/Ocean variables + USE zdf_oce ! ocean vertical physics + USE ldftra ! lateral physics: eddy diffusivity + USE ldfslp ! lateral physics: iso-neutral slopes + USE traldf_iso ! lateral diffusion (Madec operator) (tra_ldf_iso routine) + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + USE zpshde ! partial step: hor. derivative (zps_hde routine) + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_ldf_triad ! routine called by traldf.F90 + + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat transport + + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traldf_triad.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, & + & pgu , pgv , pgui, pgvi, & + & pt, pt2, pt_rhs, kjpt, kpass ) + !! + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage + INTEGER , INTENT(in ) :: Kmm ! ocean time level indices + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) + REAL(dp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend + !! + CALL tra_ldf_triad_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu), & + & pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), & + & pt, is_tile(pt), pt2, is_tile(pt2), pt_rhs, is_tile(pt_rhs), kjpt, kpass ) + END SUBROUTINE tra_ldf_triad + + + SUBROUTINE tra_ldf_triad_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah, & + & pgu , pgv , ktg , pgui, pgvi, ktgi, & + & pt, ktt, pt2, ktt2, pt_rhs, ktt_rhs, kjpt, kpass ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_ldf_triad *** + !! + !! ** Purpose : Compute the before horizontal tracer (t & s) diffusive + !! trend for a laplacian tensor (ezxcept the dz[ dz[.] ] term) and + !! add it to the general trend of tracer equation. + !! + !! ** Method : The horizontal component of the lateral diffusive trends + !! is provided by a 2nd order operator rotated along neural or geopo- + !! tential surfaces to which an eddy induced advection can be added + !! It is computed using before fields (forward in time) and isopyc- + !! nal or geopotential slopes computed in routine ldfslp. + !! + !! see documentation for the desciption + !! + !! ** Action : pt_rhs updated with the before rotated diffusion + !! ah_wslp2 .... + !! akz stabilizing vertical diffusivity coefficient (used in trazdf_imp) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage + INTEGER , INTENT(in) :: Kmm ! ocean time level indices + INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt2, ktt_rhs + REAL(wp), DIMENSION(A2D_T(ktah), JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] + REAL(wp), DIMENSION(A2D_T(ktg), KJPT), INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels + REAL(wp), DIMENSION(A2D_T(ktgi), KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels + REAL(dp), DIMENSION(A2D_T(ktt), JPK,KJPT), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) + REAL(dp), DIMENSION(A2D_T(ktt2), JPK,KJPT), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) + REAL(dp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend + ! + INTEGER :: ji, jj, jk, jn, kp, iij ! dummy loop indices + REAL(wp) :: zcoef0, ze3w_2, zsign ! - - + ! + REAL(wp) :: zslope2, zbu, zbv, zbu1, zbv1, zslope21, zah, zah1, zah_ip1, zah_jp1, zbu_ip1, zbv_jp1 + REAL(wp) :: ze1ur, ze2vr, ze3wr, zdxt, zdyt, zdzt, zdyt_jp1, ze3wr_jp1, zdzt_jp1, zah_slp1, zah_slp_jp1, zaei_slp_jp1 + REAL(wp) :: zah_slp, zaei_slp, zdxt_ip1, ze3wr_ip1, zdzt_ip1, zah_slp_ip1, zaei_slp_ip1, zaei_slp1 + REAL(wp), DIMENSION(A2D(nn_hls),0:1) :: zdkt3d ! vertical tracer gradient at 2 levels + REAL(wp), DIMENSION(A2D(nn_hls) ) :: z2d ! 2D workspace + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ! 3D - + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kpass == 1 .AND. kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_ldf_triad : rotated laplacian diffusion operator on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + ! + l_hst = .FALSE. + l_ptr = .FALSE. + IF( cdtype == 'TRA' ) THEN + IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf') ) l_ptr = .TRUE. + IF( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & + & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) l_hst = .TRUE. + ENDIF + ENDIF + ! + ! Define pt_rhs halo points for multi-point haloes in bilaplacian case + IF( nldf_tra == np_blp_it .AND. kpass == 1 ) THEN ; iij = nn_hls + ELSE ; iij = 1 + ENDIF + + ! + IF( kpass == 1 ) THEN ; zsign = 1._wp ! bilaplacian operator require a minus sign (eddy diffusivity >0) + ELSE ; zsign = -1._wp + ENDIF + ! + !!---------------------------------------------------------------------- + !! 0 - calculate ah_wslp2, akz, and optionally zpsi_uw, zpsi_vw + !!---------------------------------------------------------------------- + ! + IF( kpass == 1 ) THEN !== first pass only and whatever the tracer is ==! + ! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + akz (ji,jj,jk) = 0._wp + ah_wslp2(ji,jj,jk) = 0._wp + END_3D + ! + DO kp = 0, 1 ! i-k triads + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + ze3wr = 1._wp / e3w(ji,jj,jk+kp,Kmm) + zbu = e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm) + zbu1 = e1e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) + zah = 0.25_wp * pahu(ji,jj,jk) + zah1 = 0.25_wp * pahu(ji-1,jj,jk) + ! Subtract s-coordinate slope at t-points to give slope rel to s-surfaces (do this by *adding* gradient of depth) + zslope2 = triadi_g(ji,jj,jk,1,kp) + ( gdept(ji+1,jj,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) + zslope2 = zslope2 *zslope2 + zslope21 = triadi_g(ji,jj,jk,0,kp) + ( gdept(ji,jj,jk,Kmm) - gdept(ji-1,jj,jk,Kmm) ) * r1_e1u(ji-1,jj) * umask(ji-1,jj,jk+kp) + zslope21 = zslope21 *zslope21 + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + ah_wslp2(ji,jj,jk+kp) = ah_wslp2(ji,jj,jk+kp) + ( zah * zbu * ze3wr * r1_e1e2t(ji,jj) * zslope2 & + & + zah1 * zbu1 * ze3wr * r1_e1e2t(ji,jj) * zslope21 & + & ) ! bracket for halo 1 - halo 2 compatibility + akz (ji,jj,jk+kp) = akz (ji,jj,jk+kp) + ( zah * r1_e1u(ji,jj) * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) & + + zah1 * r1_e1u(ji-1,jj) * r1_e1u(ji-1,jj) * umask(ji-1,jj,jk+kp) & + & ) ! bracket for halo 1 - halo 2 compatibility + END_3D + END DO + ! + DO kp = 0, 1 ! j-k triads + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + ze3wr = 1.0_wp / e3w(ji,jj,jk+kp,Kmm) + zbv = e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm) + zbv1 = e1e2v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) + zah = 0.25_wp * pahv(ji,jj,jk) + zah1 = 0.25_wp * pahv(ji,jj-1,jk) + ! Subtract s-coordinate slope at t-points to give slope rel to s surfaces + ! (do this by *adding* gradient of depth) + zslope2 = triadj_g(ji,jj,jk,1,kp) + ( gdept(ji,jj+1,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) + zslope2 = zslope2 * zslope2 + zslope21 = triadj_g(ji,jj,jk,0,kp) + ( gdept(ji,jj,jk,Kmm) - gdept(ji,jj-1,jk,Kmm) ) * r1_e2v(ji,jj-1) * vmask(ji,jj-1,jk+kp) + zslope21 = zslope21 * zslope21 + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + ah_wslp2(ji,jj,jk+kp) = ah_wslp2(ji,jj,jk+kp) + ( zah * zbv * ze3wr * r1_e1e2t(ji,jj) * zslope2 & + & + zah1 * zbv1 * ze3wr * r1_e1e2t(ji,jj) * zslope21 & + & ) ! bracket for halo 1 - halo 2 compatibility + akz (ji,jj,jk+kp) = akz (ji,jj,jk+kp) + ( zah * r1_e2v(ji,jj) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) & + & + zah1 * r1_e2v(ji,jj-1) * r1_e2v(ji,jj-1) * vmask(ji,jj-1,jk+kp) & + & ) ! bracket for halo 1 - halo 2 compatibility + END_3D + END DO + ! + IF( ln_traldf_msc ) THEN ! stabilizing vertical diffusivity coefficient + ! + IF( ln_traldf_blp ) THEN ! bilaplacian operator + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + akz(ji,jj,jk) = 16._wp & + & * ah_wslp2 (ji,jj,jk) & + & * ( akz (ji,jj,jk) & + & + ah_wslp2(ji,jj,jk) & + & / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) ) ) + END_3D + ELSEIF( ln_traldf_lap ) THEN ! laplacian operator + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) + zcoef0 = rDt * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2 ) + akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * r1_Dt + END_3D + ENDIF + ! + ELSE ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + akz(ji,jj,jk) = ah_wslp2(ji,jj,jk) + END_3D + ENDIF + ! + IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' ) THEN + zpsi_uw(:,:,:) = 0._wp + zpsi_vw(:,:,:) = 0._wp + + DO kp = 0, 1 + DO_3D( 1, 0, 1, 0, 1, jpkm1 ) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp) & + & + ( 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * triadi_g(ji,jj,jk,1,kp) & + & + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * triadi_g(ji+1,jj,jk,0,kp) & + & ) ! bracket for halo 1 - halo 2 compatibility + zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp) & + & + ( 0.25_wp * aeiv(ji,jj,jk) * e1v(ji,jj) * triadj_g(ji,jj,jk,1,kp) & + & + 0.25_wp * aeiv(ji,jj,jk) * e1v(ji,jj) * triadj_g(ji,jj+1,jk,0,kp) & + & ) ! bracket for halo 1 - halo 2 compatibility + END_3D + END DO + CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) + ENDIF + ! + ENDIF !== end 1st pass only ==! + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + ! Zero fluxes for each tracer +!!gm this should probably be done outside the jn loop + ztfw(:,:,:) = 0._wp + zftu(:,:,:) = 0._wp + zftv(:,:,:) = 0._wp + zdit(:,:,:) = 0._wp + zdjt(:,:,:) = 0._wp + ! + DO_3D( iij, iij-1, iij, iij-1, 1, jpkm1 ) !== before lateral T & S gradients at T-level jk ==! + zdit(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) + zdjt(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk) + END_3D + IF( ln_zps .AND. l_grad_zps ) THEN ! partial steps: correction at top/bottom ocean level + DO_2D( iij, iij-1, iij, iij-1 ) ! bottom level + zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) + zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) + END_2D + IF( ln_isfcav ) THEN ! top level (ocean cavities only) + DO_2D( iij, iij-1, iij, iij-1 ) + IF( miku(ji,jj) > 1 ) zdit(ji,jj,miku(ji,jj) ) = pgui(ji,jj,jn) + IF( mikv(ji,jj) > 1 ) zdjt(ji,jj,mikv(ji,jj) ) = pgvi(ji,jj,jn) + END_2D + ENDIF + ENDIF + ! + !!---------------------------------------------------------------------- + !! II - horizontal trend (full) + !!---------------------------------------------------------------------- + ! + DO jk = 1, jpkm1 + ! !== Vertical tracer gradient at level jk and jk+1 + DO_2D( iij, iij, iij, iij ) + zdkt3d(ji,jj,1) = ( pt(ji,jj,jk,jn) - pt(ji,jj,jk+1,jn) ) * tmask(ji,jj,jk+1) + END_2D + ! + ! ! surface boundary condition: zdkt3d(jk=0)=zdkt3d(jk=1) + IF( jk == 1 ) THEN ; zdkt3d(:,:,0) = zdkt3d(:,:,1) + ELSE + DO_2D( iij, iij, iij, iij ) + zdkt3d(ji,jj,0) = ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) * tmask(ji,jj,jk) + END_2D + ENDIF + ! + zaei_slp = 0._wp + zaei_slp_ip1 = 0._wp + zaei_slp_jp1 = 0._wp + zaei_slp1 = 0._wp + ! + IF( ln_botmix_triad ) THEN + DO kp = 0, 1 !== Horizontal & vertical fluxes + DO_2D( iij, iij-1, iij, iij-1 ) + ze1ur = r1_e1u(ji,jj) + zdxt = zdit(ji,jj,jk) * ze1ur + zdxt_ip1 = zdit(ji+1,jj,jk) * r1_e1u(ji+1,jj) + ze3wr = 1._wp / e3w(ji,jj,jk+kp,Kmm) + ze3wr_ip1 = 1._wp / e3w(ji+1,jj,jk+kp,Kmm) + zdzt = zdkt3d(ji,jj,kp) * ze3wr + zdzt_ip1 = zdkt3d(ji+1,jj,kp) * ze3wr_ip1 + ! + zbu = 0.25_wp * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm) + zbu_ip1 = 0.25_wp * e1e2u(ji+1,jj) * e3u(ji+1,jj,jk,Kmm) + ! ln_botmix_triad is .T. don't mask zah for bottom half cells !!gm ????? ahu is masked.... + zah = pahu(ji,jj,jk) + zah_ip1 = pahu(ji+1,jj,jk) + zah_slp = zah * triadi(ji,jj,jk,1,kp) + zah_slp_ip1 = zah_ip1 * triadi(ji+1,jj,jk,1,kp) + zah_slp1 = zah * triadi(ji+1,jj,jk,0,kp) + IF( ln_ldfeiv ) THEN + zaei_slp = aeiu(ji,jj,jk) * triadi_g(ji,jj,jk,1,kp) + zaei_slp_ip1 = aeiu(ji+1,jj,jk) * triadi_g(ji+1,jj,jk,1,kp) + zaei_slp1 = aeiu(ji,jj,jk) * triadi_g(ji+1,jj,jk,0,kp) + ENDIF + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zftu(ji ,jj,jk ) = zftu(ji ,jj,jk ) & + & - ( ( zah * zdxt + ( zah_slp - zaei_slp ) * zdzt ) * zbu * ze1ur & + & + ( zah * zdxt + zah_slp1 * zdzt_ip1 - zaei_slp1 * zdzt_ip1 ) * zbu * ze1ur & + & ) ! bracket for halo 1 - halo 2 compatibility + ztfw(ji+1,jj,jk+kp) = ztfw(ji+1,jj,jk+kp) & + & - ( (zah_slp_ip1 + zaei_slp_ip1) * zdxt_ip1 * zbu_ip1 * ze3wr_ip1 & + & + ( zah_slp1 + zaei_slp1) * zdxt * zbu * ze3wr_ip1 & + & ) ! bracket for halo 1 - halo 2 compatibility + END_2D + END DO + ! + DO kp = 0, 1 + DO_2D( iij, iij-1, iij, iij-1 ) + ze2vr = r1_e2v(ji,jj) + zdyt = zdjt(ji,jj,jk) * ze2vr + zdyt_jp1 = zdjt(ji,jj+1,jk) * r1_e2v(ji,jj+1) + ze3wr = 1._wp / e3w(ji,jj,jk+kp,Kmm) + ze3wr_jp1 = 1._wp / e3w(ji,jj+1,jk+kp,Kmm) + zdzt = zdkt3d(ji,jj,kp) * ze3wr + zdzt_jp1 = zdkt3d(ji,jj+1,kp) * ze3wr_jp1 + zbv = 0.25_wp * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm) + zbv_jp1 = 0.25_wp * e1e2v(ji,jj+1) * e3v(ji,jj+1,jk,Kmm) + ! ln_botmix_triad is .T. don't mask zah for bottom half cells !!gm ????? ahu is masked.... + zah = pahv(ji,jj,jk) ! pahv(ji,jj+jp,jk) ???? + zah_jp1 = pahv(ji,jj+1,jk) + zah_slp = zah * triadj(ji,jj,jk,1,kp) + zah_slp1 = zah * triadj(ji,jj+1,jk,0,kp) + zah_slp_jp1 = zah_jp1 * triadj(ji,jj+1,jk,1,kp) + IF( ln_ldfeiv ) THEN + zaei_slp = aeiv(ji,jj,jk) * triadj_g(ji,jj,jk,1,kp) + zaei_slp_jp1 = aeiv(ji,jj+1,jk) * triadj_g(ji,jj+1,jk,1,kp) + zaei_slp1 = aeiv(ji,jj,jk) * triadj_g(ji,jj+1,jk,0,kp) + ENDIF + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zftv(ji,jj ,jk ) = zftv(ji,jj ,jk ) & + & - ( ( zah * zdyt + ( zah_slp - zaei_slp ) * zdzt ) * zbv * ze2vr & + & + ( zah * zdyt + zah_slp1 * zdzt_jp1 - zaei_slp1 * zdzt_jp1 ) * zbv * ze2vr & + & ) ! bracket for halo 1 - halo 2 compatibility + ztfw(ji,jj+1,jk+kp) = ztfw(ji,jj+1,jk+kp) & + & - ( ( zah_slp_jp1 + zaei_slp_jp1) * zdyt_jp1 * zbv_jp1 * ze3wr_jp1 & + & + ( zah_slp1 + zaei_slp1) * zdyt * zbv * ze3wr_jp1 & + & ) ! bracket for halo 1 - halo 2 compatibility + END_2D + END DO + ! + ELSE + ! + DO kp = 0, 1 !== Horizontal & vertical fluxes + DO_2D( iij, iij-1, iij, iij-1 ) + ze1ur = r1_e1u(ji,jj) + zdxt = zdit(ji,jj,jk) * ze1ur + zdxt_ip1 = zdit(ji+1,jj,jk) * r1_e1u(ji+1,jj) + ze3wr = 1._wp / e3w(ji,jj,jk+kp,Kmm) + ze3wr_ip1 = 1._wp / e3w(ji+1,jj,jk+kp,Kmm) + zdzt = zdkt3d(ji,jj,kp) * ze3wr + zdzt_ip1 = zdkt3d(ji+1,jj,kp) * ze3wr_ip1 + ! + zbu = 0.25_wp * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm) + zbu_ip1 = 0.25_wp * e1e2u(ji+1,jj) * e3u(ji+1,jj,jk,Kmm) + ! ln_botmix_triad is .F. mask zah for bottom half cells + zah = pahu(ji,jj,jk) * umask(ji,jj,jk+kp) ! pahu(ji+ip,jj,jk) ===>> ???? + zah_ip1 = pahu(ji+1,jj,jk) * umask(ji+1,jj,jk+kp) + zah_slp = zah * triadi(ji,jj,jk,1,kp) + zah_slp_ip1 = zah_ip1 * triadi(ji+1,jj,jk,1,kp) + zah_slp1 = zah * triadi(ji+1,jj,jk,0,kp) + IF( ln_ldfeiv ) THEN + zaei_slp = aeiu(ji,jj,jk) * triadi_g(ji,jj,jk,1,kp) + zaei_slp_ip1 = aeiu(ji+1,jj,jk) * triadi_g(ji+1,jj,jk,1,kp) + zaei_slp1 = aeiu(ji,jj,jk) * triadi_g(ji+1,jj,jk,0,kp) + ENDIF + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zftu(ji ,jj,jk ) = zftu(ji ,jj,jk ) & + & - ( ( zah * zdxt + ( zah_slp - zaei_slp ) * zdzt ) * zbu * ze1ur & + & + ( zah * zdxt + zah_slp1 * zdzt_ip1 - zaei_slp1 * zdzt_ip1 ) * zbu * ze1ur & + & ) ! bracket for halo 1 - halo 2 compatibility + ztfw(ji+1,jj,jk+kp) = ztfw(ji+1,jj,jk+kp) & + & - ( (zah_slp_ip1 + zaei_slp_ip1) * zdxt_ip1 * zbu_ip1 * ze3wr_ip1 & + & + ( zah_slp1 + zaei_slp1) * zdxt * zbu * ze3wr_ip1 & + & ) ! bracket for halo 1 - halo 2 compatibility + END_2D + END DO + ! + DO kp = 0, 1 + DO_2D( iij, iij-1, iij, iij-1 ) + ze2vr = r1_e2v(ji,jj) + zdyt = zdjt(ji,jj,jk) * ze2vr + zdyt_jp1 = zdjt(ji,jj+1,jk) * r1_e2v(ji,jj+1) + ze3wr = 1._wp / e3w(ji,jj,jk+kp,Kmm) + ze3wr_jp1 = 1._wp / e3w(ji,jj+1,jk+kp,Kmm) + zdzt = zdkt3d(ji,jj,kp) * ze3wr + zdzt_jp1 = zdkt3d(ji,jj+1,kp) * ze3wr_jp1 + zbv = 0.25_wp * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm) + zbv_jp1 = 0.25_wp * e1e2v(ji,jj+1) * e3v(ji,jj+1,jk,Kmm) + ! ln_botmix_triad is .F. mask zah for bottom half cells + zah = pahv(ji,jj,jk) * vmask(ji,jj,jk+kp) ! pahv(ji,jj+jp,jk) ???? + zah_jp1 = pahv(ji,jj+1,jk) * vmask(ji,jj+1,jk+kp) + zah_slp = zah * triadj(ji,jj,jk,1,kp) + zah_slp1 = zah * triadj(ji,jj+1,jk,0,kp) + zah_slp_jp1 = zah_jp1 * triadj(ji,jj+1,jk,1,kp) + IF( ln_ldfeiv ) THEN + zaei_slp = aeiv(ji,jj,jk) * triadj_g(ji,jj,jk,1,kp) + zaei_slp_jp1 = aeiv(ji,jj+1,jk) * triadj_g(ji,jj+1,jk,1,kp) + zaei_slp1 = aeiv(ji,jj,jk) * triadj_g(ji,jj+1,jk,0,kp) + ENDIF + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + zftv(ji,jj ,jk ) = zftv(ji,jj ,jk ) & + & - ( ( zah * zdyt + ( zah_slp - zaei_slp ) * zdzt ) * zbv * ze2vr & + & + ( zah * zdyt + zah_slp1 * zdzt_jp1 - zaei_slp1 * zdzt_jp1 ) * zbv * ze2vr & + & ) ! bracket for halo 1 - halo 2 compatibility + ztfw(ji,jj+1,jk+kp) = ztfw(ji,jj+1,jk+kp) & + & - ( ( zah_slp_jp1 + zaei_slp_jp1) * zdyt_jp1 * zbv_jp1 * ze3wr_jp1 & + & + ( zah_slp1 + zaei_slp1) * zdyt * zbv * ze3wr_jp1 & + & ) ! bracket for halo 1 - halo 2 compatibility + END_2D + END DO + ENDIF + ! !== horizontal divergence and add to the general trend ==! + DO_2D( iij-1, iij-1, iij-1, iij-1 ) + ! round brackets added to fix the order of floating point operations + ! needed to ensure halo 1 - halo 2 compatibility + pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) & + & + zsign * ( ( zftu(ji-1,jj ,jk) - zftu(ji,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & + ( zftv(ji,jj-1,jk) - zftv(ji,jj,jk) & + & ) & ! bracket for halo 1 - halo 2 compatibility + & ) / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) + END_2D + ! + END DO + ! + ! !== add the vertical 33 flux ==! + IF( ln_traldf_lap ) THEN ! laplacian case: eddy coef = ah_wslp2 - akz + DO_3D( iij-1, iij-1, iij-1, iij-1, 2, jpkm1 ) + ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) & + & * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) ) & + & * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) + END_3D + ELSE ! bilaplacian + SELECT CASE( kpass ) + CASE( 1 ) ! 1st pass : eddy coef = ah_wslp2 + DO_3D( iij-1, iij-1, iij-1, iij-1, 2, jpkm1 ) + ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) & + & * ah_wslp2(ji,jj,jk) * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) + END_3D + CASE( 2 ) ! 2nd pass : eddy flux = ah_wslp2 and akz applied on pt and pt2 gradients, resp. + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) & + & * ( ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) ) & + & + akz (ji,jj,jk) * ( pt2(ji,jj,jk-1,jn) - pt2(ji,jj,jk,jn) ) ) + END_3D + END SELECT + ENDIF + ! + DO_3D( iij-1, iij-1, iij-1, iij-1, 1, jpkm1 ) !== Divergence of vertical fluxes added to pta ==! + pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) & + & + zsign * ( ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk) ) & + & / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) + END_3D + ! + IF( ( kpass == 1 .AND. ln_traldf_lap ) .OR. & !== first pass only ( laplacian) ==! + ( kpass == 2 .AND. ln_traldf_blp ) ) THEN !== 2nd pass (bilaplacian) ==! + ! + ! ! "Poleward" diffusive heat or salt transports (T-S case only) + IF( l_ptr ) CALL dia_ptr_hst( jn, 'ldf', zftv(:,:,:) ) + ! ! Diffusive heat transports + IF( l_hst ) CALL dia_ar5_hst( jn, 'ldf', zftu(:,:,:), zftv(:,:,:) ) + ! + ENDIF !== end pass selection ==! + ! + ! ! =============== + END DO ! end tracer loop + ! ! =============== + END SUBROUTINE tra_ldf_triad_t + + !!============================================================================== +END MODULE traldf_triad \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/tramle.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/tramle.F90 new file mode 100644 index 0000000..8ad7587 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/tramle.F90 @@ -0,0 +1,373 @@ +MODULE tramle + !!====================================================================== + !! *** MODULE tramle *** + !! Ocean tracers: Mixed Layer Eddy induced transport + !!====================================================================== + !! History : 3.3 ! 2010-08 (G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_mle_trp : update the effective transport with the Mixed Layer Eddy induced transport + !! tra_mle_init : initialisation of the Mixed Layer Eddy induced transport computation + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE phycst ! physical constant + USE zdfmxl ! mixed layer depth + ! + USE in_out_manager ! I/O manager + USE iom ! IOM library + USE lib_mpp ! MPP library + USE lbclnk ! lateral boundary condition / mpp link + + ! where OSMOSIS_OBL is used with integrated FK + USE zdf_oce, ONLY : ln_zdfosm + USE zdfosm, ONLY : ln_osm_mle, hmle, dbdx_mle, dbdy_mle, mld_prof + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_mle_trp ! routine called in traadv.F90 + PUBLIC tra_mle_init ! routine called in traadv.F90 + + ! !!* namelist namtra_mle * + LOGICAL, PUBLIC :: ln_mle !: flag to activate the Mixed Layer Eddy (MLE) parameterisation + INTEGER :: nn_mle ! MLE type: =0 standard Fox-Kemper ; =1 new formulation + INTEGER :: nn_mld_uv ! space interpolation of MLD at u- & v-pts (0=min,1=averaged,2=max) + INTEGER :: nn_conv ! =1 no MLE in case of convection ; =0 always MLE + REAL(wp) :: rn_ce ! MLE coefficient + ! ! parameters used in nn_mle = 0 case + REAL(wp) :: rn_lf ! typical scale of mixed layer front + REAL(wp) :: rn_time ! time scale for mixing momentum across the mixed layer + ! ! parameters used in nn_mle = 1 case + REAL(wp) :: rn_lat ! reference latitude for a 5 km scale of ML front + REAL(wp) :: rn_rho_c_mle ! Density criterion for definition of MLD used by FK + + REAL(wp) :: r5_21 = 5.e0 / 21.e0 ! factor used in mle streamfunction computation + REAL(wp) :: rb_c ! ML buoyancy criteria = g rho_c /rho0 where rho_c is defined in zdfmld + REAL(wp) :: rc_f ! MLE coefficient (= rn_ce / (5 km * fo) ) in nn_mle=1 case + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: rfu, rfv ! modified Coriolis parameter (f+tau) at u- & v-pts + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_ft ! inverse of the modified Coriolis parameter at t-pts + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: tramle.F90 14921 2021-05-28 12:19:26Z smueller $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_mle_trp( kt, kit000, pu, pv, pw, cdtype, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_mle_trp *** + !! + !! ** Purpose : Add to the transport the Mixed Layer Eddy induced transport + !! + !! ** Method : The 3 components of the Mixed Layer Eddy (MLE) induced + !! transport are computed as follows : + !! zu_mle = dk[ zpsi_uw ] + !! zv_mle = dk[ zpsi_vw ] + !! zw_mle = - di[ zpsi_uw ] - dj[ zpsi_vw ] + !! where zpsi is the MLE streamfunction at uw and vw points (see the doc) + !! and added to the input velocity : + !! p.n = p.n + z._mle + !! + !! ** Action : - (pu,pv,pw) increased by the mle transport + !! CAUTION, the transport is not updated at the last line/raw + !! this may be a problem for some advection schemes + !! + !! References: Fox-Kemper et al., JPO, 38, 1145-1165, 2008 + !! Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kit000 ! first time step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + ! TEMP: [tiling] Can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu ! in : 3 ocean transport components + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pv ! out: same 3 transport components + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the MLE induced transport + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ii, ij, ik, ikmax ! local integers + REAL(wp) :: zcuw, zmuw, zc ! local scalar + REAL(wp) :: zcvw, zmvw ! - - + INTEGER , DIMENSION(A2D(nn_hls)) :: inml_mle + REAL(wp), DIMENSION(A2D(nn_hls)) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw + !!---------------------------------------------------------------------- + ! + ! + IF(ln_osm_mle.and.ln_zdfosm) THEN + ikmax = MIN( MAXVAL( mld_prof(:,:) ), jpkm1 ) ! max level of the computation + ! + ! + SELECT CASE( nn_mld_uv ) ! MLD at u- & v-pts + CASE ( 0 ) != min of the 2 neighbour MLDs + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + zhu(ji,jj) = MIN( hmle(ji+1,jj), hmle(ji,jj) ) + zhv(ji,jj) = MIN( hmle(ji,jj+1), hmle(ji,jj) ) + END_2D + CASE ( 1 ) != average of the 2 neighbour MLDs + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + zhu(ji,jj) = MAX( hmle(ji+1,jj), hmle(ji,jj) ) + zhv(ji,jj) = MAX( hmle(ji,jj+1), hmle(ji,jj) ) + END_2D + CASE ( 2 ) != max of the 2 neighbour MLDs + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + zhu(ji,jj) = MAX( hmle(ji+1,jj), hmle(ji,jj) ) + zhv(ji,jj) = MAX( hmle(ji,jj+1), hmle(ji,jj) ) + END_2D + END SELECT + IF( nn_mle == 0 ) THEN ! Fox-Kemper et al. 2010 formulation + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj) * e2u(ji,jj) & + & * dbdx_mle(ji,jj) * MIN( 111.e3_wp , e1u(ji,jj) ) & + & / ( MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) ) ) + ! + zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj) * e1v(ji,jj) & + & * dbdy_mle(ji,jj) * MIN( 111.e3_wp , e2v(ji,jj) ) & + & / ( MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) ) ) + END_2D + ! + ELSEIF( nn_mle == 1 ) THEN ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat) + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + zpsim_u(ji,jj) = rc_f * zhu(ji,jj) * zhu(ji,jj) * e2u(ji,jj) & + & * dbdx_mle(ji,jj) * MIN( 111.e3_wp , e1u(ji,jj) ) + ! + zpsim_v(ji,jj) = rc_f * zhv(ji,jj) * zhv(ji,jj) * e1v(ji,jj) & + & * dbdy_mle(ji,jj) * MIN( 111.e3_wp , e2v(ji,jj) ) + END_2D + ENDIF + + ELSE !do not use osn_mle + ! !== MLD used for MLE ==! + ! ! compute from the 10m density to deal with the diurnal cycle + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + inml_mle(ji,jj) = mbkt(ji,jj) + 1 ! init. to number of ocean w-level (T-level + 1) + END_2D + IF ( nla10 > 0 ) THEN ! avoid case where first level is thicker than 10m + DO_3DS( nn_hls, nn_hls, nn_hls, nn_hls, jpkm1, nlb10, -1 ) ! from the bottom to nlb10 (10m) + IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle ) inml_mle(ji,jj) = jk ! Mixed layer + END_3D + ENDIF + ikmax = MIN( MAXVAL( inml_mle(:,:) ), jpkm1 ) ! max level of the computation + ! + ! + zmld(:,:) = 0._wp !== Horizontal shape of the MLE ==! + zbm (:,:) = 0._wp + zn2 (:,:) = 0._wp + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, ikmax ) ! MLD and mean buoyancy and N2 over the mixed layer + zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1 ) ) ! zc being 0 outside the ML t-points + zmld(ji,jj) = zmld(ji,jj) + zc + zbm (ji,jj) = zbm (ji,jj) + zc * (rho0 - rhop(ji,jj,jk) ) * r1_rho0 + zn2 (ji,jj) = zn2 (ji,jj) + zc * (rn2(ji,jj,jk)+rn2(ji,jj,jk+1))*0.5_wp + END_3D + + SELECT CASE( nn_mld_uv ) ! MLD at u- & v-pts + CASE ( 0 ) != min of the 2 neighbour MLDs + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + zhu(ji,jj) = MIN( zmld(ji+1,jj), zmld(ji,jj) ) + zhv(ji,jj) = MIN( zmld(ji,jj+1), zmld(ji,jj) ) + END_2D + CASE ( 1 ) != average of the 2 neighbour MLDs + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + zhu(ji,jj) = ( zmld(ji+1,jj) + zmld(ji,jj) ) * 0.5_wp + zhv(ji,jj) = ( zmld(ji,jj+1) + zmld(ji,jj) ) * 0.5_wp + END_2D + CASE ( 2 ) != max of the 2 neighbour MLDs + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + zhu(ji,jj) = MAX( zmld(ji+1,jj), zmld(ji,jj) ) + zhv(ji,jj) = MAX( zmld(ji,jj+1), zmld(ji,jj) ) + END_2D + END SELECT + ! ! convert density into buoyancy + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zbm(ji,jj) = + grav * zbm(ji,jj) / MAX( e3t(ji,jj,1,Kmm), zmld(ji,jj) ) + END_2D + ! + ! + ! !== Magnitude of the MLE stream function ==! + ! + ! di[bm] Ds + ! Psi = Ce H^2 ---------------- e2u mu(z) where fu Lf = MAX( fu*rn_fl , (Db H)^1/2 ) + ! e1u Lf fu and the e2u for the "transport" + ! (not *e3u as divided by e3u at the end) + ! + IF( nn_mle == 0 ) THEN ! Fox-Kemper et al. 2010 formulation + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj) * e2_e1u(ji,jj) & + & * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) & + & / ( MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) ) ) + ! + zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj) * e1_e2v(ji,jj) & + & * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) & + & / ( MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) ) ) + END_2D + ! + ELSEIF( nn_mle == 1 ) THEN ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat) + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + zpsim_u(ji,jj) = rc_f * zhu(ji,jj) * zhu(ji,jj) * e2_e1u(ji,jj) & + & * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) + ! + zpsim_v(ji,jj) = rc_f * zhv(ji,jj) * zhv(ji,jj) * e1_e2v(ji,jj) & + & * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) + END_2D + ENDIF + ! + IF( nn_conv == 1 ) THEN ! No MLE in case of convection + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + IF( MIN( zn2(ji,jj) , zn2(ji+1,jj) ) < 0._wp ) zpsim_u(ji,jj) = 0._wp + IF( MIN( zn2(ji,jj) , zn2(ji,jj+1) ) < 0._wp ) zpsim_v(ji,jj) = 0._wp + END_2D + ENDIF + ! + ENDIF ! end of ln_osm_mle conditional + ! !== structure function value at uw- and vw-points ==! + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + zhu(ji,jj) = 1._wp / MAX(zhu(ji,jj), rsmall) ! hu --> 1/hu + zhv(ji,jj) = 1._wp / MAX(zhv(ji,jj), rsmall) + END_2D + ! + zpsi_uw(:,:,:) = 0._wp + zpsi_vw(:,:,:) = 0._wp + ! + DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 2, ikmax ) ! start from 2 : surface value = 0 + + zcuw = 1._wp - ( gdepw(ji+1,jj,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhu(ji,jj) + zcvw = 1._wp - ( gdepw(ji,jj+1,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhv(ji,jj) + zcuw = zcuw * zcuw + zcvw = zcvw * zcvw + zmuw = MAX( 0._wp , ( 1._wp - zcuw ) * ( 1._wp + r5_21 * zcuw ) ) + zmvw = MAX( 0._wp , ( 1._wp - zcvw ) * ( 1._wp + r5_21 * zcvw ) ) + ! + zpsi_uw(ji,jj,jk) = zpsim_u(ji,jj) * zmuw * wumask(ji,jj,jk) * wumask(ji,jj,1) + zpsi_vw(ji,jj,jk) = zpsim_v(ji,jj) * zmvw * wvmask(ji,jj,jk) * wvmask(ji,jj,1) + END_3D + ! + ! !== transport increased by the MLE induced transport ==! + DO jk = 1, ikmax + DO_2D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + pu(ji,jj,jk) = pu(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) ) + pv(ji,jj,jk) = pv(ji,jj,jk) + ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) ) + END_2D + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + pw(ji,jj,jk) = pw(ji,jj,jk) - ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji-1,jj,jk) & + & + zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj-1,jk) ) * wmask(ji,jj,1) + END_2D + END DO + + IF( cdtype == 'TRA') THEN !== outputs ==! + ! + IF (ln_osm_mle.and.ln_zdfosm) THEN + DO_2D( 0, 0, 0, 0 ) + zLf_NH(ji,jj) = SQRT( rb_c * hmle(ji,jj) ) * r1_ft(ji,jj) ! Lf = N H / f + END_2D + ELSE + DO_2D( 0, 0, 0, 0 ) + zLf_NH(ji,jj) = SQRT( rb_c * zmld(ji,jj) ) * r1_ft(ji,jj) ! Lf = N H / f + END_2D + ENDIF + ! + CALL iom_put( "Lf_NHpf" , zLf_NH ) ! Lf = N H / f + ! + ! divide by cross distance to give streamfunction with dimensions m^2/s + DO_3D( 0, 0, 0, 0, 1, ikmax+1 ) + zpsi_uw(ji,jj,jk) = zpsi_uw(ji,jj,jk) * r1_e2u(ji,jj) + zpsi_vw(ji,jj,jk) = zpsi_vw(ji,jj,jk) * r1_e1v(ji,jj) + END_3D + CALL iom_put( "psiu_mle", zpsi_uw ) ! i-mle streamfunction + CALL iom_put( "psiv_mle", zpsi_vw ) ! j-mle streamfunction + ENDIF + ! + END SUBROUTINE tra_mle_trp + + SUBROUTINE tra_mle_init + !!--------------------------------------------------------------------- + !! *** ROUTINE tra_mle_init *** + !! + !! ** Purpose : Control the consistency between namelist options for + !! tracer advection schemes and set nadv + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ierr + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp) :: z1_t2, zfu, zfv ! - - + ! + NAMELIST/namtra_mle/ ln_mle , nn_mle, rn_ce, rn_lf, rn_time, rn_lat, nn_mld_uv, nn_conv, rn_rho_c_mle + !!---------------------------------------------------------------------- + + READ ( numnam_ref, namtra_mle, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_mle in reference namelist' ) + + READ ( numnam_cfg, namtra_mle, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_mle in configuration namelist' ) + IF(lwm) WRITE ( numond, namtra_mle ) + + IF(lwp) THEN ! Namelist print + WRITE(numout,*) + WRITE(numout,*) 'tra_mle_init : mixed layer eddy (MLE) advection acting on tracers' + WRITE(numout,*) '~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namtra_mle : mixed layer eddy advection applied on tracers' + WRITE(numout,*) ' use mixed layer eddy (MLE, i.e. Fox-Kemper param) (T/F) ln_mle = ', ln_mle + WRITE(numout,*) ' MLE type: =0 standard Fox-Kemper ; =1 new formulation nn_mle = ', nn_mle + WRITE(numout,*) ' magnitude of the MLE (typical value: 0.06 to 0.08) rn_ce = ', rn_ce + WRITE(numout,*) ' scale of ML front (ML radius of deformation) (rn_mle=0) rn_lf = ', rn_lf, 'm' + WRITE(numout,*) ' maximum time scale of MLE (rn_mle=0) rn_time = ', rn_time, 's' + WRITE(numout,*) ' reference latitude (degrees) of MLE coef. (rn_mle=1) rn_lat = ', rn_lat, 'deg' + WRITE(numout,*) ' space interp. of MLD at u-(v-)pts (0=min,1=averaged,2=max) nn_mld_uv = ', nn_mld_uv + WRITE(numout,*) ' =1 no MLE in case of convection ; =0 always MLE nn_conv = ', nn_conv + WRITE(numout,*) ' Density difference used to define ML for FK rn_rho_c_mle = ', rn_rho_c_mle + ENDIF + ! + IF(lwp) THEN + WRITE(numout,*) + IF( ln_mle ) THEN + WRITE(numout,*) ' ==>>> Mixed Layer Eddy induced transport added to tracer advection' + IF( nn_mle == 0 ) WRITE(numout,*) ' Fox-Kemper et al 2010 formulation' + IF( nn_mle == 1 ) WRITE(numout,*) ' New formulation' + ELSE + WRITE(numout,*) ' ==>>> Mixed Layer Eddy parametrisation NOT used' + ENDIF + ENDIF + ! + IF( ln_mle ) THEN ! MLE initialisation + ! + rb_c = grav * rn_rho_c_mle /rho0 ! Mixed Layer buoyancy criteria + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ML buoyancy criteria = ', rb_c, ' m/s2 ' + IF(lwp) WRITE(numout,*) ' associated ML density criteria defined in zdfmxl = ', rho_c, 'kg/m3' + ! + IF( nn_mle == 0 ) THEN ! MLE array allocation & initialisation + ALLOCATE( rfu(jpi,jpj) , rfv(jpi,jpj) , STAT= ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' ) + z1_t2 = 1._wp / ( rn_time * rn_time ) + DO_2D( 0, 1, 0, 1 ) ! "coriolis+ time^-1" at u- & v-points + zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp + zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp + rfu(ji,jj) = SQRT( zfu * zfu + z1_t2 ) + rfv(ji,jj) = SQRT( zfv * zfv + z1_t2 ) + END_2D + CALL lbc_lnk( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) + ! + ELSEIF( nn_mle == 1 ) THEN ! MLE array allocation & initialisation + rc_f = rn_ce / ( 5.e3_wp * 2._wp * omega * SIN( rad * rn_lat ) ) + ! + ENDIF + ! + ! ! 1/(f^2+tau^2)^1/2 at t-point (needed in both nn_mle case) + ALLOCATE( r1_ft(jpi,jpj) , STAT= ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'tra_adv_mle_init: failed to allocate r1_ft array' ) + ! + z1_t2 = 1._wp / ( rn_time * rn_time ) + r1_ft(:,:) = 1._wp / SQRT( ff_t(:,:) * ff_t(:,:) + z1_t2 ) + ! + ENDIF + ! + END SUBROUTINE tra_mle_init + + !!============================================================================== +END MODULE tramle diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/tranpc.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/tranpc.F90 new file mode 100644 index 0000000..b2708fc --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/tranpc.F90 @@ -0,0 +1,327 @@ +MODULE tranpc + !!============================================================================== + !! *** MODULE tranpc *** + !! Ocean active tracers: non penetrative convective adjustment scheme + !!============================================================================== + !! History : 1.0 ! 1990-09 (G. Madec) Original code + !! ! 1996-01 (G. Madec) statement function for e3 + !! NEMO 1.0 ! 2002-06 (G. Madec) free form F90 + !! 3.0 ! 2008-06 (G. Madec) applied on ta, sa and called before tranxt in step.F90 + !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + !! 3.6 ! 2015-05 (L. Brodeau) new algorithm based on local Brunt-Vaisala freq. + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_npc : apply the non penetrative convection scheme + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE zdf_oce ! ocean vertical physics + USE trd_oce ! ocean active tracer trends + USE trdtra ! ocean active tracer trends + USE eosbn2 ! equation of state (eos routine) + ! + USE lbclnk ! lateral boundary conditions (or mpp link) + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_npc ! routine called by step.F90 + + INTEGER :: nnpcc ! number of statically instable water column + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: tranpc.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_npc( kt, Kmm, Krhs, pts, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tranpc *** + !! + !! ** Purpose : Non-penetrative convective adjustment scheme. solve + !! the static instability of the water column on after fields + !! while conserving heat and salt contents. + !! + !! ** Method : updated algorithm able to deal with non-linear equation of state + !! (i.e. static stability computed locally) + !! + !! ** Action : - tsa: after tracers with the application of the npc scheme + !! - send the associated trends for on-line diagnostics (l_trdtra=T) + !! + !! References : Madec, et al., 1991, JPO, 21, 9, 1349-1371. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(in ) :: Kmm, Krhs, Kaa ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: jiter, ikbot, ikp, ikup, ikdown, ilayer, ik_low ! local integers + LOGICAL :: l_bottom_reached, l_column_treated + REAL(wp) :: zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z + REAL(wp) :: zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_rDt + REAL(wp), PARAMETER :: zn2_zero = 1.e-14_wp ! acceptance criteria for neutrality (N2==0) + REAL(wp), DIMENSION( jpk ) :: zvn2 ! vertical profile of N2 at 1 given point... + REAL(wp), DIMENSION( jpk,jpts) :: zvts, zvab ! vertical profile of T & S , and alpha & betaat 1 given point + REAL(wp), DIMENSION(A2D(nn_hls),jpk ) :: zn2 ! N^2 + REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts) :: zab ! alpha and beta + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace + ! + LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is + INTEGER :: ilc1, jlc1, klc1, nncpu ! actually happening in a water column at point "ilc1, jlc1" + LOGICAL :: lp_monitor_point = .FALSE. ! in CPU domain "nncpu" + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_npc') + ! + IF( MOD( kt, nn_npc ) == 0 ) THEN + ! + IF( l_trdtra ) THEN !* Save initial after fields + ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) + ENDIF + ! + IF( l_LB_debug ) THEN + ! Location of 1 known convection site to follow what's happening in the water column + ilc1 = 45 ; jlc1 = 3 ; ! ORCA2 4x4, Antarctic coast, more than 2 unstable portions in the water column... + nncpu = 1 ; ! the CPU domain contains the convection spot + klc1 = mbkt(ilc1,jlc1) ! bottom of the ocean for debug point... + ENDIF + ! + CALL eos_rab( pts(:,:,:,:,Kaa), zab, Kmm ) ! after alpha and beta (given on T-points) + CALL bn2 ( pts(:,:,:,:,Kaa), zab, zn2, Kmm ) ! after Brunt-Vaisala (given on W-points) + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) nnpcc = 0 ! Do only on the first tile + ! + DO_2D_OVR( 0, 0, 0, 0 ) ! interior column only + ! + IF( tmask(ji,jj,2) == 1 ) THEN ! At least 2 ocean points + ! ! consider one ocean column + zvts(:,jp_tem) = pts(ji,jj,:,jp_tem,Kaa) ! temperature + zvts(:,jp_sal) = pts(ji,jj,:,jp_sal,Kaa) ! salinity + ! + zvab(:,jp_tem) = zab(ji,jj,:,jp_tem) ! Alpha + zvab(:,jp_sal) = zab(ji,jj,:,jp_sal) ! Beta + zvn2(:) = zn2(ji,jj,:) ! N^2 + ! + IF( l_LB_debug ) THEN !LB debug: + lp_monitor_point = .FALSE. + IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE. + ! writing only if on CPU domain where conv region is: + lp_monitor_point = (narea == nncpu).AND.lp_monitor_point + ENDIF !LB debug end + ! + ikbot = mbkt(ji,jj) ! ikbot: ocean bottom T-level + ikp = 1 ! because N2 is irrelevant at the surface level (will start at ikp=2) + ilayer = 0 + jiter = 0 + l_column_treated = .FALSE. + ! + DO WHILE ( .NOT. l_column_treated ) + ! + jiter = jiter + 1 + ! + IF( jiter >= 400 ) EXIT + ! + l_bottom_reached = .FALSE. + ! + DO WHILE ( .NOT. l_bottom_reached ) + ! + ikp = ikp + 1 + ! + !! Testing level ikp for instability + !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF( zvn2(ikp) < -zn2_zero ) THEN ! Instability found! + ! + ilayer = ilayer + 1 ! yet another instable portion of the water column found.... + ! + IF( lp_monitor_point ) THEN + WRITE(numout,*) + IF( ilayer == 1 .AND. jiter == 1 ) THEN ! first time a column is spoted with an instability + WRITE(numout,*) + WRITE(numout,*) 'Time step = ',kt,' !!!' + ENDIF + WRITE(numout,*) ' * Iteration #',jiter,': found instable portion #',ilayer, & + & ' in column! Starting at ikp =', ikp + WRITE(numout,*) ' *** N2 for point (i,j) = ',ji,' , ',jj + DO jk = 1, klc1 + WRITE(numout,*) jk, zvn2(jk) + END DO + WRITE(numout,*) + ENDIF + ! + IF( jiter == 1 ) nnpcc = nnpcc + 1 + ! + IF( lp_monitor_point ) WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer + ! + !! ikup is the uppermost point where mixing will start: + ikup = ikp - 1 ! ikup is always "at most at ikp-1", less if neutral levels overlying + ! + !! If the points above ikp-1 have N2 == 0 they must also be mixed: + IF( ikp > 2 ) THEN + DO jk = ikp-1, 2, -1 + IF( ABS(zvn2(jk)) < zn2_zero ) THEN + ikup = ikup - 1 ! 1 more upper level has N2=0 and must be added for the mixing + ELSE + EXIT + ENDIF + END DO + ENDIF + ! + IF( ikup < 1 ) CALL ctl_stop( 'tra_npc : PROBLEM #1') + ! + zsum_temp = 0._wp + zsum_sali = 0._wp + zsum_alfa = 0._wp + zsum_beta = 0._wp + zsum_z = 0._wp + + DO jk = ikup, ikbot ! Inside the instable (and overlying neutral) portion of the column + ! + zdz = e3t(ji,jj,jk,Kmm) + zsum_temp = zsum_temp + zvts(jk,jp_tem)*zdz + zsum_sali = zsum_sali + zvts(jk,jp_sal)*zdz + zsum_alfa = zsum_alfa + zvab(jk,jp_tem)*zdz + zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz + zsum_z = zsum_z + zdz + ! + IF( jk == ikbot ) EXIT ! avoid array-index overshoot in case ikbot = jpk, cause we're calling jk+1 next line + !! EXIT when we have reached the last layer that is instable (N2<0) or neutral (N2=0): + IF( zvn2(jk+1) > zn2_zero ) EXIT + END DO + + ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative or neutral N2 + IF( ikup == ikdown ) CALL ctl_stop( 'tra_npc : PROBLEM #2') + + ! Mixing Temperature, salinity, alpha and beta from ikup to ikdown included: + zta = zsum_temp/zsum_z + zsa = zsum_sali/zsum_z + zalfa = zsum_alfa/zsum_z + zbeta = zsum_beta/zsum_z + + IF( lp_monitor_point ) THEN + WRITE(numout,*) 'MIXED T, S, alfa and beta between ikup =',ikup, & + & ' and ikdown =',ikdown,', in layer #',ilayer + WRITE(numout,*) ' => Mean temp. in that portion =', zta + WRITE(numout,*) ' => Mean sali. in that portion =', zsa + WRITE(numout,*) ' => Mean Alfa in that portion =', zalfa + WRITE(numout,*) ' => Mean Beta in that portion =', zbeta + ENDIF + + !! Homogenaizing the temperature, salinity, alpha and beta in this portion of the column + DO jk = ikup, ikdown + zvts(jk,jp_tem) = zta + zvts(jk,jp_sal) = zsa + zvab(jk,jp_tem) = zalfa + zvab(jk,jp_sal) = zbeta + END DO + + + !! Updating N2 in the relvant portion of the water column + !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion + !! => Need to re-compute N2! will use Alpha and Beta! + + ikup = MAX(2,ikup) ! ikup can never be 1 ! + ik_low = MIN(ikdown+1,ikbot) ! we must go 1 point deeper than ikdown! + + DO jk = ikup, ik_low ! we must go 1 point deeper than ikdown! + + !! Interpolating alfa and beta at W point: + zrw = (gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm)) & + & / (gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm)) + zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw + zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw + + !! N2 at W point, doing exactly as in eosbn2.F90: + zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) ) & + & - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) ) ) & + & / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) + + !! OR, faster => just considering the vertical gradient of density + !! as only the signa maters... + !zvn2(jk) = ( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) ) & + ! & - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) ) ) + + END DO + + ikp = MIN(ikdown+1,ikbot) + + + ENDIF !IF( zvn2(ikp) < 0. ) + + + IF( ikp == ikbot ) l_bottom_reached = .TRUE. + ! + END DO ! DO WHILE ( .NOT. l_bottom_reached ) + + IF( ikp /= ikbot ) CALL ctl_stop( 'tra_npc : PROBLEM #3') + + ! ******* At this stage ikp == ikbot ! ******* + + IF( ilayer > 0 ) THEN !! least an unstable layer has been found + ! + IF( lp_monitor_point ) THEN + WRITE(numout,*) + WRITE(numout,*) 'After ',jiter,' iteration(s), we neutralized ',ilayer,' instable layer(s)' + WRITE(numout,*) ' ==> N2 at i,j=',ji,',',jj,' now looks like this:' + DO jk = 1, klc1 + WRITE(numout,*) jk, zvn2(jk) + END DO + WRITE(numout,*) + ENDIF + ! + ikp = 1 ! starting again at the surface for the next iteration + ilayer = 0 + ENDIF + ! + IF( ikp >= ikbot ) l_column_treated = .TRUE. + ! + END DO ! DO WHILE ( .NOT. l_column_treated ) + + !! Updating pts: + pts(ji,jj,:,jp_tem,Kaa) = zvts(:,jp_tem) + pts(ji,jj,:,jp_sal,Kaa) = zvts(:,jp_sal) + + !! LB: Potentially some other global variable beside theta and S can be treated here + !! like BGC tracers. + + IF( lp_monitor_point ) WRITE(numout,*) + + ENDIF ! IF( tmask(ji,jj,3) == 1 ) THEN + + END_2D + ! + IF( l_trdtra ) THEN ! send the Non penetrative mixing trends for diagnostic + z1_rDt = 1._wp / (2._wp * rn_Dt) + ztrdt(:,:,:) = ( pts(:,:,:,jp_tem,Kaa) - ztrdt(:,:,:) ) * z1_rDt + ztrds(:,:,:) = ( pts(:,:,:,jp_sal,Kaa) - ztrds(:,:,:) ) * z1_rDt + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_npc, ztrdt ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_npc, ztrds ) + DEALLOCATE( ztrdt, ztrds ) + ENDIF + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only for the full domain + IF( lwp .AND. l_LB_debug ) THEN + WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', nnpcc + WRITE(numout,*) + ENDIF + ENDIF + ! + ENDIF ! IF( MOD( kt, nn_npc ) == 0 ) THEN + ! + IF( ln_timing ) CALL timing_stop('tra_npc') + ! + END SUBROUTINE tra_npc + + !!====================================================================== +END MODULE tranpc \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traqsr.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traqsr.F90 new file mode 100644 index 0000000..fb36a41 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/traqsr.F90 @@ -0,0 +1,453 @@ +MODULE traqsr + !!====================================================================== + !! *** MODULE traqsr *** + !! Ocean physics: solar radiation penetration in the top ocean levels + !!====================================================================== + !! History : OPA ! 1990-10 (B. Blanke) Original code + !! 7.0 ! 1991-11 (G. Madec) + !! ! 1996-01 (G. Madec) s-coordinates + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! - ! 2005-11 (G. Madec) zco, zps, sco coordinate + !! 3.2 ! 2009-04 (G. Madec & NEMO team) + !! 3.6 ! 2012-05 (C. Rousset) store attenuation coef for use in ice model + !! 3.6 ! 2015-12 (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll + !! 3.7 ! 2015-11 (G. Madec, A. Coward) remove optimisation for fix volume + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_qsr : temperature trend due to the penetration of solar radiation + !! tra_qsr_init : initialization of the qsr penetration + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE phycst ! physical constants + USE dom_oce ! ocean space and time domain + USE domtile + USE sbc_oce ! surface boundary condition: ocean + USE trc_oce ! share SMS/Ocean variables + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE iom ! I/O library + USE fldread ! read input fields + USE restart ! ocean restart + USE lib_mpp ! MPP library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_qsr ! routine called by step.F90 (ln_traqsr=T) + PUBLIC tra_qsr_init ! routine called by nemogcm.F90 + + ! !!* Namelist namtra_qsr: penetrative solar radiation + LOGICAL , PUBLIC :: ln_traqsr !: light absorption (qsr) flag + LOGICAL , PUBLIC :: ln_qsr_rgb !: Red-Green-Blue light absorption flag + LOGICAL , PUBLIC :: ln_qsr_2bd !: 2 band light absorption flag + LOGICAL , PUBLIC :: ln_qsr_bio !: bio-model light absorption flag + INTEGER , PUBLIC :: nn_chldta !: use Chlorophyll data (=1) or not (=0) + REAL(wp), PUBLIC :: rn_abs !: fraction absorbed in the very near surface (RGB & 2 bands) + REAL(wp), PUBLIC :: rn_si0 !: very near surface depth of extinction (RGB & 2 bands) + REAL(wp), PUBLIC :: rn_si1 !: deepest depth of extinction (water type I) (2 bands) + ! + INTEGER , PUBLIC :: nksr !: levels below which the light cannot penetrate (depth larger than 391 m) + + INTEGER, PARAMETER :: np_RGB = 1 ! R-G-B light penetration with constant Chlorophyll + INTEGER, PARAMETER :: np_RGBc = 2 ! R-G-B light penetration with Chlorophyll data + INTEGER, PARAMETER :: np_2BD = 3 ! 2 bands light penetration + INTEGER, PARAMETER :: np_BIO = 4 ! bio-model light penetration + ! + INTEGER :: nqsr ! user choice of the type of light penetration + REAL(wp) :: xsi0r ! inverse of rn_si0 + REAL(wp) :: xsi1r ! inverse of rn_si1 + ! + REAL(wp) , PUBLIC, DIMENSION(3,61) :: rkrgb ! tabulated attenuation coefficients for RGB absorption + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_chl ! structure of input Chl (file informations, fields read) + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: traqsr.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_qsr( kt, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_qsr *** + !! + !! ** Purpose : Compute the temperature trend due to the solar radiation + !! penetration and add it to the general temperature trend. + !! + !! ** Method : The profile of the solar radiation within the ocean is defined + !! through 2 wavebands (rn_si0,rn_si1) or 3 wavebands (RGB) and a ratio rn_abs + !! Considering the 2 wavebands case: + !! I(k) = Qsr*( rn_abs*EXP(z(k)/rn_si0) + (1.-rn_abs)*EXP(z(k)/rn_si1) ) + !! The temperature trend associated with the solar radiation penetration + !! is given by : zta = 1/e3t dk[ I ] / (rho0*Cp) + !! At the bottom, boudary condition for the radiation is no flux : + !! all heat which has not been absorbed in the above levels is put + !! in the last ocean level. + !! The computation is only done down to the level where + !! I(k) < 1.e-15 W/m2 (i.e. over the top nksr levels) . + !! + !! ** Action : - update ta with the penetrative solar radiation trend + !! - send trend for further diagnostics (l_trdtra=T) + !! + !! Reference : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp. + !! Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. + !! Morel, A. et Berthon, JF, 1989, Limnol Oceanogr 34(8), 1545-1562 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step + INTEGER, INTENT(in ) :: Kmm, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: irgb ! local integers + REAL(wp) :: zchl, zcoef, z1_2 ! local scalars + REAL(wp) :: zc0 , zc1 , zc2 , zc3 ! - - + REAL(wp) :: zzc0, zzc1, zzc2, zzc3 ! - - + REAL(wp) :: zz0 , zz1 , ze3t, zlui ! - - + REAL(wp) :: zCb, zCmax, zpsi, zpsimax, zrdpsi, zCze + REAL(wp) :: zlogc, zlogze, zlogCtot, zlogCze + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ze0, ze1, ze2, ze3 + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, zetot, ztmp3d + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_qsr') + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + ENDIF + ! + IF( l_trdtra ) THEN ! trends diagnostic: save the input temperature trend + ALLOCATE( ztrdt(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) + ENDIF + ! + ! !-----------------------------------! + ! ! before qsr induced heat content ! + ! !-----------------------------------! + IF( kt == nit000 ) THEN !== 1st time step ==! + IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN ! read in restart + z1_2 = 0.5_wp + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field read in the restart file' + CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b ) ! before heat content trend due to Qsr flux + ENDIF + ELSE ! No restart or Euler forward at 1st time step + z1_2 = 1._wp + DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) + qsr_hc_b(ji,jj,jk) = 0._wp + END_3D + ENDIF + ELSE !== Swap of qsr heat content ==! + z1_2 = 0.5_wp + DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) + qsr_hc_b(ji,jj,jk) = qsr_hc(ji,jj,jk) + END_3D + ENDIF + ! + ! !--------------------------------! + SELECT CASE( nqsr ) ! now qsr induced heat content ! + ! !--------------------------------! + ! + CASE( np_BIO ) !== bio-model fluxes ==! + ! + DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksr ) + qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( etot3(ji,jj,jk) - etot3(ji,jj,jk+1) ) + END_3D + ! + CASE( np_RGB , np_RGBc ) !== R-G-B fluxes ==! + ! + ALLOCATE( ze0 (A2D(nn_hls)) , ze1 (A2D(nn_hls)) , & + & ze2 (A2D(nn_hls)) , ze3 (A2D(nn_hls)) , & + & ztmp3d(A2D(nn_hls),nksr + 1) ) + ! + IF( nqsr == np_RGBc ) THEN !* Variable Chlorophyll + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only for the full domain + IF( ln_tile ) CALL dom_tile_stop( ldhold=.TRUE. ) ! Use full domain + CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step + IF( ln_tile ) CALL dom_tile_start( ldhold=.TRUE. ) ! Revert to tile domain + ENDIF + ! + ! Separation in R-G-B depending on the surface Chl + ! perform and store as many of the 2D calculations as possible + ! before the 3D loop (use the temporary 2D arrays to replace the + ! most expensive calculations) + ! + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + ! zlogc = log(zchl) + zlogc = LOG ( MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) ) + ! zc1 : log(zCze) = log (1.12 * zchl**0.803) + zc1 = 0.113328685307 + 0.803 * zlogc + ! zc2 : log(zCtot) = log(40.6 * zchl**0.459) + zc2 = 3.703768066608 + 0.459 * zlogc + ! zc3 : log(zze) = log(568.2 * zCtot**(-0.746)) + zc3 = 6.34247346942 - 0.746 * zc2 + ! IF( log(zze) > log(102.) ) log(zze) = log(200.0 * zCtot**(-0.293)) + IF( zc3 > 4.62497281328 ) zc3 = 5.298317366548 - 0.293 * zc2 + ! + ze0(ji,jj) = zlogc ! ze0 = log(zchl) + ze1(ji,jj) = EXP( zc1 ) ! ze1 = zCze + ze2(ji,jj) = 1._wp / ( 0.710 + zlogc * ( 0.159 + zlogc * 0.021 ) ) ! ze2 = 1/zdelpsi + ze3(ji,jj) = EXP( - zc3 ) ! ze3 = 1/zze + END_2D + +! + DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksr + 1 ) + ! zchl = ALOG( ze0(ji,jj) ) + zlogc = ze0(ji,jj) + ! + zCb = 0.768 + zlogc * ( 0.087 - zlogc * ( 0.179 + zlogc * 0.025 ) ) + zCmax = 0.299 - zlogc * ( 0.289 - zlogc * 0.579 ) + zpsimax = 0.6 - zlogc * ( 0.640 - zlogc * ( 0.021 + zlogc * 0.115 ) ) + ! zdelpsi = 0.710 + zlogc * ( 0.159 + zlogc * 0.021 ) + ! + zCze = ze1(ji,jj) + zrdpsi = ze2(ji,jj) ! 1/zdelpsi + zpsi = ze3(ji,jj) * gdepw(ji,jj,jk,Kmm) ! gdepw/zze + ! + ! NB. make sure zchl value is such that: zchl = MIN( 10. , MAX( 0.03, zchl ) ) + zchl = MIN( 10. , MAX( 0.03, zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) * zrdpsi )**2 ) ) ) ) + ! Convert chlorophyll value to attenuation coefficient look-up table index + ztmp3d(ji,jj,jk) = 41 + 20.*LOG10(zchl) + 1.e-15 + END_3D + ELSE !* constant chlorophyll + zchl = 0.05 + ! NB. make sure constant value is such that: + zchl = MIN( 10. , MAX( 0.03, zchl ) ) + ! Convert chlorophyll value to attenuation coefficient look-up table index + zlui = 41 + 20.*LOG10(zchl) + 1.e-15 + DO jk = 1, nksr + 1 + ztmp3d(:,:,jk) = zlui + END DO + ENDIF + ! + zcoef = ( 1. - rn_abs ) / 3._wp !* surface equi-partition in R-G-B + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + ze0(ji,jj) = rn_abs * qsr(ji,jj) + ze1(ji,jj) = zcoef * qsr(ji,jj) + ze2(ji,jj) = zcoef * qsr(ji,jj) + ze3(ji,jj) = zcoef * qsr(ji,jj) + ! store the surface SW radiation; re-use the surface ztmp3d array + ! since the surface attenuation coefficient is not used + ztmp3d(ji,jj,1) = qsr(ji,jj) + END_2D + ! + ! !* interior equi-partition in R-G-B depending on vertical profile of Chl + DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 2, nksr + 1 ) + ze3t = e3t(ji,jj,jk-1,Kmm) + irgb = NINT( ztmp3d(ji,jj,jk) ) + zc0 = ze0(ji,jj) * EXP( - ze3t * xsi0r ) + zc1 = ze1(ji,jj) * EXP( - ze3t * rkrgb(1,irgb) ) + zc2 = ze2(ji,jj) * EXP( - ze3t * rkrgb(2,irgb) ) + zc3 = ze3(ji,jj) * EXP( - ze3t * rkrgb(3,irgb) ) + ze0(ji,jj) = zc0 + ze1(ji,jj) = zc1 + ze2(ji,jj) = zc2 + ze3(ji,jj) = zc3 + ztmp3d(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * wmask(ji,jj,jk) + END_3D + ! + DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksr ) !* now qsr induced heat content + qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( ztmp3d(ji,jj,jk) - ztmp3d(ji,jj,jk+1) ) + END_3D + ! + DEALLOCATE( ze0 , ze1 , ze2 , ze3 , ztmp3d ) + ! + CASE( np_2BD ) !== 2-bands fluxes ==! + ! + zz0 = rn_abs * r1_rho0_rcp ! surface equi-partition in 2-bands + zz1 = ( 1. - rn_abs ) * r1_rho0_rcp + DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksr ) !* now qsr induced heat content + zc0 = zz0 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi1r ) + zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r ) + qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) ) + END_3D + ! + END SELECT + ! + ! !-----------------------------! + ! ! update to the temp. trend ! + ! !-----------------------------! + DO_3D( 0, 0, 0, 0, 1, nksr ) + pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) & + & + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) & + & / e3t(ji,jj,jk,Kmm) + END_3D + ! + ! sea-ice: store the 1st ocean level attenuation coefficient + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + IF( qsr(ji,jj) /= 0._wp ) THEN ; fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rho0_rcp * qsr(ji,jj) ) + ELSE ; fraqsr_1lev(ji,jj) = 1._wp + ENDIF + END_2D + ! + IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution + ALLOCATE( zetot(A2D(nn_hls),jpk) ) + zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero + DO_3DS(0, 0, 0, 0, nksr, 1, -1) + zetot(ji,jj,jk) = zetot(ji,jj,jk+1) + qsr_hc(ji,jj,jk) * rho0_rcp + END_3D + CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation + DEALLOCATE( zetot ) + ENDIF + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF( lrst_oce ) THEN ! write in the ocean restart file + CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b' , qsr_hc ) + CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev ) + ENDIF + ENDIF + ! + IF( l_trdtra ) THEN ! qsr tracers trends saved for diagnostics + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_qsr, ztrdt ) + DEALLOCATE( ztrdt ) + ENDIF + ! ! print mean trends (used for debugging) + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' qsr - Ta: ', mask1=tmask, clinfo3='tra-ta' ) + + IF( ln_timing ) CALL timing_stop('tra_qsr') + ! + END SUBROUTINE tra_qsr + + + SUBROUTINE tra_qsr_init + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_qsr_init *** + !! + !! ** Purpose : Initialization for the penetrative solar radiation + !! + !! ** Method : The profile of solar radiation within the ocean is set + !! from two length scale of penetration (rn_si0,rn_si1) and a ratio + !! (rn_abs). These parameters are read in the namtra_qsr namelist. The + !! default values correspond to clear water (type I in Jerlov' + !! (1968) classification. + !! called by tra_qsr at the first timestep (nit000) + !! + !! ** Action : - initialize rn_si0, rn_si1 and rn_abs + !! + !! Reference : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp. + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ios, irgb, ierror, ioptio ! local integer + REAL(wp) :: zz0, zc0 , zc1, zcoef ! local scalars + REAL(wp) :: zz1, zc2 , zc3, zchl ! - - + ! + CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files + TYPE(FLD_N) :: sn_chl ! informations about the chlorofyl field to be read + !! + NAMELIST/namtra_qsr/ sn_chl, cn_dir, ln_qsr_rgb, ln_qsr_2bd, ln_qsr_bio, & + & nn_chldta, rn_abs, rn_si0, rn_si1 + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namtra_qsr, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in reference namelist' ) + ! + READ ( numnam_cfg, namtra_qsr, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist' ) + IF(lwm) WRITE ( numond, namtra_qsr ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'tra_qsr_init : penetration of the surface solar radiation' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namtra_qsr : set the parameter of penetration' + WRITE(numout,*) ' RGB (Red-Green-Blue) light penetration ln_qsr_rgb = ', ln_qsr_rgb + WRITE(numout,*) ' 2 band light penetration ln_qsr_2bd = ', ln_qsr_2bd + WRITE(numout,*) ' bio-model light penetration ln_qsr_bio = ', ln_qsr_bio + WRITE(numout,*) ' RGB : Chl data (=1) or cst value (=0) nn_chldta = ', nn_chldta + WRITE(numout,*) ' RGB & 2 bands: fraction of light (rn_si1) rn_abs = ', rn_abs + WRITE(numout,*) ' RGB & 2 bands: shortess depth of extinction rn_si0 = ', rn_si0 + WRITE(numout,*) ' 2 bands: longest depth of extinction rn_si1 = ', rn_si1 + WRITE(numout,*) + ENDIF + ! + ioptio = 0 ! Parameter control + IF( ln_qsr_rgb ) ioptio = ioptio + 1 + IF( ln_qsr_2bd ) ioptio = ioptio + 1 + IF( ln_qsr_bio ) ioptio = ioptio + 1 + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE type of light penetration in namelist namtra_qsr', & + & ' 2 bands, 3 RGB bands or bio-model light penetration' ) + ! + IF( ln_qsr_rgb .AND. nn_chldta == 0 ) nqsr = np_RGB + IF( ln_qsr_rgb .AND. nn_chldta == 1 ) nqsr = np_RGBc + IF( ln_qsr_2bd ) nqsr = np_2BD + IF( ln_qsr_bio ) nqsr = np_BIO + ! + ! ! Initialisation + xsi0r = 1._wp / rn_si0 + xsi1r = 1._wp / rn_si1 + ! + SELECT CASE( nqsr ) + ! + CASE( np_RGB , np_RGBc ) !== Red-Green-Blue light penetration ==! + ! + IF(lwp) WRITE(numout,*) ' ==>>> R-G-B light penetration ' + ! + CALL trc_oce_rgb( rkrgb ) ! tabulated attenuation coef. + ! + nksr = trc_oce_ext_lev( r_si2, 33._wp ) ! level of light extinction + ! + IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' + ! + IF( nqsr == np_RGBc ) THEN ! Chl data : set sf_chl structure + IF(lwp) WRITE(numout,*) ' ==>>> Chlorophyll read in a file' + ALLOCATE( sf_chl(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'tra_qsr_init: unable to allocate sf_chl structure' ) ; RETURN + ENDIF + ALLOCATE( sf_chl(1)%fnow(jpi,jpj,1) ) + IF( sn_chl%ln_tint ) ALLOCATE( sf_chl(1)%fdta(jpi,jpj,1,2) ) + ! ! fill sf_chl with sn_chl and control print + CALL fld_fill( sf_chl, (/ sn_chl /), cn_dir, 'tra_qsr_init', & + & 'Solar penetration function of read chlorophyll', 'namtra_qsr' , no_print ) + ENDIF + IF( nqsr == np_RGB ) THEN ! constant Chl + IF(lwp) WRITE(numout,*) ' ==>>> Constant Chlorophyll concentration = 0.05' + ENDIF + ! + CASE( np_2BD ) !== 2 bands light penetration ==! + ! + IF(lwp) WRITE(numout,*) ' ==>>> 2 bands light penetration' + ! + nksr = trc_oce_ext_lev( rn_si1, 100._wp ) ! level of light extinction + IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' + ! + CASE( np_BIO ) !== BIO light penetration ==! + ! + IF(lwp) WRITE(numout,*) ' ==>>> bio-model light penetration' + IF( .NOT.lk_top ) CALL ctl_stop( 'No bio model : ln_qsr_bio = true impossible ' ) + ! + CALL trc_oce_rgb( rkrgb ) ! tabulated attenuation coef. + ! + nksr = trc_oce_ext_lev( r_si2, 33._wp ) ! level of light extinction + ! + IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' + ! + END SELECT + ! + qsr_hc(:,:,:) = 0._wp ! now qsr heat content set to zero where it will not be computed + ! + ! 1st ocean level attenuation coefficient (used in sbcssm) + IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, jpdom_auto, 'fraqsr_1lev' , fraqsr_1lev ) + ELSE + fraqsr_1lev(:,:) = 1._wp ! default : no penetration + ENDIF + ! + END SUBROUTINE tra_qsr_init + + !!====================================================================== +END MODULE traqsr \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trasbc.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trasbc.F90 new file mode 100644 index 0000000..6549f91 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trasbc.F90 @@ -0,0 +1,226 @@ +MODULE trasbc + !!============================================================================== + !! *** MODULE trasbc *** + !! Ocean active tracers: surface boundary condition + !!============================================================================== + !! History : OPA ! 1998-10 (G. Madec, G. Roullet, M. Imbard) Original code + !! 8.2 ! 2001-02 (D. Ludicone) sea ice and free surface + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.3 ! 2010-04 (M. Leclair, G. Madec) Forcing averaged over 2 time steps + !! - ! 2010-09 (C. Ethe, G. Madec) Merge TRA-TRC + !! 3.6 ! 2014-11 (P. Mathiot) isf melting forcing + !! 4.1 ! 2019-09 (P. Mathiot) isf moved in traisf + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_sbc : update the tracer trend at ocean surface + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE sbc_oce ! surface boundary condition: ocean + USE dom_oce ! ocean space domain variables + USE phycst ! physical constant + USE eosbn2 ! Equation Of State + USE sbcmod ! ln_rnf + USE sbcrnf ! River runoff + USE traqsr ! solar radiation penetration + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers +#if defined key_asminc + USE asminc ! Assimilation increment +#endif + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE iom ! xIOS server + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_sbc ! routine called by step.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trasbc.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_sbc ( kt, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_sbc *** + !! + !! ** Purpose : Compute the tracer surface boundary condition trend of + !! (flux through the interface, concentration/dilution effect) + !! and add it to the general trend of tracer equations. + !! + !! ** Method : The (air+ice)-sea flux has two components: + !! (1) Fext, external forcing (i.e. flux through the (air+ice)-sea interface); + !! (2) Fwe , tracer carried with the water that is exchanged with air+ice. + !! The input forcing fields (emp, rnf, sfx) contain Fext+Fwe, + !! they are simply added to the tracer trend (ts(Krhs)). + !! In linear free surface case (ln_linssh=T), the volume of the + !! ocean does not change with the water exchanges at the (air+ice)-sea + !! interface. Therefore another term has to be added, to mimic the + !! concentration/dilution effect associated with water exchanges. + !! + !! ** Action : - Update ts(Krhs) with the surface boundary condition trend + !! - send trends to trdtra module for further diagnostics(l_trdtra=T) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(in ) :: Kmm, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer Eq. + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: ikt, ikb ! local integers + REAL(wp) :: zfact, z1_e3t, zdep, ztim ! local scalar + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_sbc') + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_sbc : TRAcer Surface Boundary Condition' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + ENDIF + ! + IF( l_trdtra ) THEN !* Save ta and sa trends + ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) + ENDIF + ! +!!gm This should be moved into sbcmod.F90 module ? (especially now that ln_traqsr is read in namsbc namelist) + IF( .NOT.ln_traqsr ) THEN ! no solar radiation penetration + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + qns(ji,jj) = qns(ji,jj) + qsr(ji,jj) ! total heat flux in qns + qsr(ji,jj) = 0._wp ! qsr set to zero + END_2D + ENDIF + + !---------------------------------------- + ! EMP, SFX and QNS effects + !---------------------------------------- + ! !== Set before sbc tracer content fields ==! + IF( kt == nit000 ) THEN !* 1st time-step + IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN ! Restart: read in restart file + zfact = 0.5_wp + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) WRITE(numout,*) ' nit000-1 sbc tracer content field read in the restart file' + sbc_tsc(:,:,:) = 0._wp + CALL iom_get( numror, jpdom_auto, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem) ) ! before heat content sbc trend + CALL iom_get( numror, jpdom_auto, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal) ) ! before salt content sbc trend + ENDIF + ELSE ! No restart or restart not found: Euler forward time stepping + zfact = 1._wp + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + sbc_tsc(ji,jj,:) = 0._wp + sbc_tsc_b(ji,jj,:) = 0._wp + END_2D + ENDIF + ELSE !* other time-steps: swap of forcing fields + zfact = 0.5_wp + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + sbc_tsc_b(ji,jj,:) = sbc_tsc(ji,jj,:) + END_2D + ENDIF + ! !== Now sbc tracer content fields ==! + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + sbc_tsc(ji,jj,jp_tem) = r1_rho0_rcp * qns(ji,jj) ! non solar heat flux + sbc_tsc(ji,jj,jp_sal) = r1_rho0 * sfx(ji,jj) ! salt flux due to freezing/melting + END_2D + IF( ln_linssh ) THEN !* linear free surface + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) !==>> add concentration/dilution effect due to constant volume cell + sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) + sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) + END_2D !==>> output c./d. term + IF( iom_use('emp_x_sst') ) CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) + IF( iom_use('emp_x_sss') ) CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) + ENDIF + ! + DO jn = 1, jpts !== update tracer trend ==! + DO_2D( 0, 0, 0, 0 ) + pts(ji,jj,1,jn,Krhs) = pts(ji,jj,1,jn,Krhs) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) & + & / e3t(ji,jj,1,Kmm) + END_2D + END DO + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF( lrst_oce ) THEN !== write sbc_tsc in the ocean restart file ==! + CALL iom_rstput( kt, nitrst, numrow, 'sbc_hc_b', sbc_tsc(:,:,jp_tem) ) + CALL iom_rstput( kt, nitrst, numrow, 'sbc_sc_b', sbc_tsc(:,:,jp_sal) ) + ENDIF + ENDIF + ! + !---------------------------------------- + ! River Runoff effects + !---------------------------------------- + ! + IF( ln_rnf ) THEN ! input of heat and salt due to river runoff + zfact = 0.5_wp + DO_2D( 0, 0, 0, 0 ) + IF( rnf(ji,jj) /= 0._wp ) THEN + zdep = zfact / h_rnf(ji,jj) + DO jk = 1, nk_rnf(ji,jj) + pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) & + & + ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep + IF( ln_rnf_sal ) pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) & + & + ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep + END DO + ENDIF + END_2D + ENDIF + + IF( iom_use('rnf_x_sst') ) CALL iom_put( "rnf_x_sst", rnf*pts(:,:,1,jp_tem,Kmm) ) ! runoff term on sst + IF( iom_use('rnf_x_sss') ) CALL iom_put( "rnf_x_sss", rnf*pts(:,:,1,jp_sal,Kmm) ) ! runoff term on sss + +#if defined key_asminc + ! + !---------------------------------------- + ! Assmilation effects + !---------------------------------------- + ! + IF( ln_sshinc ) THEN ! input of heat and salt due to assimilation + ! + IF( ln_linssh ) THEN + DO_2D( 0, 0, 0, 0 ) + ztim = ssh_iau(ji,jj) / e3t(ji,jj,1,Kmm) + pts(ji,jj,1,jp_tem,Krhs) = pts(ji,jj,1,jp_tem,Krhs) + pts(ji,jj,1,jp_tem,Kmm) * ztim + pts(ji,jj,1,jp_sal,Krhs) = pts(ji,jj,1,jp_sal,Krhs) + pts(ji,jj,1,jp_sal,Kmm) * ztim + END_2D + ELSE + DO_2D( 0, 0, 0, 0 ) + ztim = ssh_iau(ji,jj) / ( ht(ji,jj) + 1. - ssmask(ji, jj) ) + pts(ji,jj,:,jp_tem,Krhs) = pts(ji,jj,:,jp_tem,Krhs) + pts(ji,jj,:,jp_tem,Kmm) * ztim + pts(ji,jj,:,jp_sal,Krhs) = pts(ji,jj,:,jp_sal,Krhs) + pts(ji,jj,:,jp_sal,Kmm) * ztim + END_2D + ENDIF + ! + ENDIF + ! +#endif + ! + IF( l_trdtra ) THEN ! save the horizontal diffusive trends for further diagnostics + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_nsr, ztrdt ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_nsr, ztrds ) + DEALLOCATE( ztrdt , ztrds ) + ENDIF + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' sbc - Ta: ', mask1=tmask, & + & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! + IF( ln_timing ) CALL timing_stop('tra_sbc') + ! + END SUBROUTINE tra_sbc + + !!====================================================================== +END MODULE trasbc \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trazdf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trazdf.F90 new file mode 100644 index 0000000..7e041a5 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/trazdf.F90 @@ -0,0 +1,267 @@ +MODULE trazdf + !!============================================================================== + !! *** MODULE trazdf *** + !! Ocean active tracers: vertical component of the tracer mixing trend + !!============================================================================== + !! History : 1.0 ! 2005-11 (G. Madec) Original code + !! 3.0 ! 2008-01 (C. Ethe, G. Madec) merge TRC-TRA + !! 4.0 ! 2017-06 (G. Madec) remove explict time-stepping option + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_zdf : Update the tracer trend with the vertical diffusion + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE domvvl ! variable volume + USE phycst ! physical constant + USE zdf_oce ! ocean vertical physics variables + USE zdfmfc ! Mass FLux Convection + USE sbc_oce ! surface boundary condition: ocean + USE ldftra ! lateral diffusion: eddy diffusivity + USE ldfslp ! lateral diffusion: iso-neutral slope + USE trd_oce ! trends: ocean variables + USE trdtra ! trends: tracer trend manager + USE eosbn2, ONLY: ln_SEOS, rn_b0 + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_zdf ! called by step.F90 + PUBLIC tra_zdf_imp ! called by trczdf.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trazdf.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_zdf( kt, Kbb, Kmm, Krhs, pts, Kaa ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_zdf *** + !! + !! ** Purpose : compute the vertical ocean tracer physics. + !!--------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step index + INTEGER , INTENT(in) :: Kbb, Kmm, Krhs, Kaa ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk ! Dummy loop indices + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds ! 3D workspace + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_zdf') + ! + IF( kt == nit000 ) THEN + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' + IF(lwp)WRITE(numout,*) '~~~~~~~ ' + ENDIF + ENDIF + ! + IF( l_trdtra ) THEN !* Save ta and sa trends + ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) + ENDIF + ! + ! !* compute lateral mixing trend and add it to the general trend + CALL tra_zdf_imp( kt, nit000, 'TRA', rDt, Kbb, Kmm, Krhs, pts, Kaa, jpts ) + +!!gm WHY here ! and I don't like that ! + ! DRAKKAR SSS control { + ! JMM avoid negative salinities near river outlet ! Ugly fix + ! JMM : restore negative salinities to small salinities: +!!jc: discard this correction in case salinity is not used in eos + IF ( .NOT.(ln_SEOS.AND.(rn_b0==0._wp)) ) THEN + WHERE( pts(A2D(0),:,jp_sal,Kaa) < 0._wp ) pts(A2D(0),:,jp_sal,Kaa) = 0.1_wp + ENDIF +!!gm + + IF( l_trdtra ) THEN ! save the vertical diffusive trends for further diagnostics + DO jk = 1, jpk + ztrdt(:,:,jk) = ( ( pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa) & + & - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb) ) & + & / ( e3t(:,:,jk,Kmm)*rDt ) ) & + & - ztrdt(:,:,jk) + ztrds(:,:,jk) = ( ( pts(:,:,jk,jp_sal,Kaa)*e3t(:,:,jk,Kaa) & + & - pts(:,:,jk,jp_sal,Kbb)*e3t(:,:,jk,Kbb) ) & + & / ( e3t(:,:,jk,Kmm)*rDt ) ) & + & - ztrds(:,:,jk) + END DO +!!gm this should be moved in trdtra.F90 and done on all trends + CALL lbc_lnk( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp ) +!!gm + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_zdf, ztrdt ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_zdf, ztrds ) + DEALLOCATE( ztrdt , ztrds ) + ENDIF + ! ! print mean trends (used for debugging) + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kaa), clinfo1=' zdf - Ta: ', mask1=tmask, & + & tab3d_2=pts(:,:,:,jp_sal,Kaa), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! + IF( ln_timing ) CALL timing_stop('tra_zdf') + ! + END SUBROUTINE tra_zdf + + + SUBROUTINE tra_zdf_imp( kt, kit000, cdtype, p2dt, Kbb, Kmm, Krhs, pt, Kaa, kjpt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_zdf_imp *** + !! + !! ** Purpose : Compute the after tracer through a implicit computation + !! of the vertical tracer diffusion (including the vertical component + !! of lateral mixing (only for 2nd order operator, for fourth order + !! it is already computed and add to the general trend in traldf) + !! + !! ** Method : The vertical diffusion of a tracer ,t , is given by: + !! difft = dz( avt dz(t) ) = 1/e3t dk+1( avt/e3w dk(t) ) + !! It is computed using a backward time scheme (t=after field) + !! which provide directly the after tracer field. + !! If ln_zdfddm=T, use avs for salinity or for passive tracers + !! Surface and bottom boundary conditions: no diffusive flux on + !! both tracers (bottom, applied through the masked field avt). + !! If iso-neutral mixing, add to avt the contribution due to lateral mixing. + !! + !! ** Action : - pt(:,:,:,:,Kaa) becomes the after tracer + !!--------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs, Kaa ! ocean time level indices + INTEGER , INTENT(in ) :: kit000 ! first time step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(dp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: zzwi, zzws! local scalars + REAL(dp) :: zrhs! local scalars + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zws + REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwt, zwd + !!--------------------------------------------------------------------- + ! + ! ! ============= ! + DO jn = 1, kjpt ! tracer loop ! + ! ! ============= ! + ! Matrix construction + ! -------------------- + ! Build matrix if temperature or salinity (only in double diffusion case) or first passive tracer + ! + IF( ( cdtype == 'TRA' .AND. ( jn == jp_tem .OR. ( jn == jp_sal .AND. ln_zdfddm ) ) ) .OR. & + & ( cdtype == 'TRC' .AND. jn == 1 ) ) THEN + ! + ! vertical mixing coef.: avt for temperature, avs for salinity and passive tracers + IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN + DO_3D( 1, 1, 1, 1, 2, jpk ) + zwt(ji,jj,jk) = avt(ji,jj,jk) + END_3D + ELSE + DO_3D( 1, 1, 1, 1, 2, jpk ) + zwt(ji,jj,jk) = avs(ji,jj,jk) + END_3D + ENDIF + zwt(:,:,1) = 0._wp + ! + IF( l_ldfslp ) THEN ! isoneutral diffusion: add the contribution + IF( ln_traldf_msc ) THEN ! MSC iso-neutral operator + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + zwt(ji,jj,jk) = zwt(ji,jj,jk) + akz(ji,jj,jk) + END_3D + ELSE ! standard or triad iso-neutral operator + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk) + END_3D + ENDIF + ENDIF + ! + ! Diagonal, lower (i), upper (s) (including the bottom boundary condition since avt is masked) + IF( ln_zad_Aimp ) THEN ! Adaptive implicit vertical advection + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zzwi = - p2dt * zwt(ji,jj,jk ) / e3w(ji,jj,jk ,Kmm) + zzws = - p2dt * zwt(ji,jj,jk+1) / e3w(ji,jj,jk+1,Kmm) + zwd(ji,jj,jk) = e3t(ji,jj,jk,Kaa) - zzwi - zzws & + & + p2dt * ( MAX( wi(ji,jj,jk ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) + zwi(ji,jj,jk) = zzwi + p2dt * MIN( wi(ji,jj,jk ) , 0._wp ) + zws(ji,jj,jk) = zzws - p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) + END_3D + ELSE + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zwi(ji,jj,jk) = - p2dt * zwt(ji,jj,jk ) / e3w(ji,jj,jk,Kmm) + zws(ji,jj,jk) = - p2dt * zwt(ji,jj,jk+1) / e3w(ji,jj,jk+1,Kmm) + zwd(ji,jj,jk) = e3t(ji,jj,jk,Kaa) - zwi(ji,jj,jk) - zws(ji,jj,jk) + END_3D + ENDIF + ! + ! Modification of diagonal to add MF scheme + IF ( ln_zdfmfc ) THEN + CALL diag_mfc( zwi, zwd, zws, p2dt, Kaa ) + END IF + ! + !! Matrix inversion from the first level + !!---------------------------------------------------------------------- + ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk ) + ! + ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 ) + ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 ) + ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 ) + ! ( ... )( ... ) ( ... ) + ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk ) + ! + ! m is decomposed in the product of an upper and lower triangular matrix. + ! The 3 diagonal terms are in 3d arrays: zwd, zws, zwi. + ! Suffices i,s and d indicate "inferior" (below diagonal), diagonal + ! and "superior" (above diagonal) components of the tridiagonal system. + ! The solution will be in the 4d array pta. + ! The 3d array zwt is used as a work space array. + ! En route to the solution pt(:,:,:,:,Kaa) is used a to evaluate the rhs and then + ! used as a work space array: its value is modified. + ! + DO_2D( 0, 0, 0, 0 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 (increasing k) ! done one for all passive tracers (so included in the IF instruction) + zwt(ji,jj,1) = zwd(ji,jj,1) + END_2D + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) + END_3D + ! + ENDIF + ! + ! Modification of rhs to add MF scheme + IF ( ln_zdfmfc ) THEN + CALL rhs_mfc( pt(:,:,:,jn,Krhs), jn ) + END IF + ! + DO_2D( 0, 0, 0, 0 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 + pt(ji,jj,1,jn,Kaa) = e3t(ji,jj,1,Kbb) * pt(ji,jj,1,jn,Kbb) & + & + p2dt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs) + END_2D + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + zrhs = e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) & + & + p2dt * e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk,jn,Krhs) ! zrhs=right hand side + pt(ji,jj,jk,jn,Kaa) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pt(ji,jj,jk-1,jn,Kaa) + END_3D + ! + DO_2D( 0, 0, 0, 0 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk (result is the after tracer) + pt(ji,jj,jpkm1,jn,Kaa) = pt(ji,jj,jpkm1,jn,Kaa) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) + END_2D + DO_3DS( 0, 0, 0, 0, jpk-2, 1, -1 ) + pt(ji,jj,jk,jn,Kaa) = ( pt(ji,jj,jk,jn,Kaa) - zws(ji,jj,jk) * pt(ji,jj,jk+1,jn,Kaa) ) & + & / zwt(ji,jj,jk) * tmask(ji,jj,jk) + END_3D + ! ! ================= ! + END DO ! end tracer loop ! + ! ! ================= ! + END SUBROUTINE tra_zdf_imp + + !!============================================================================== +END MODULE trazdf \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/zpshde.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/zpshde.F90 new file mode 100644 index 0000000..1f56bf7 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRA/zpshde.F90 @@ -0,0 +1,493 @@ +MODULE zpshde + !!====================================================================== + !! *** MODULE zpshde *** + !! z-coordinate + partial step : Horizontal Derivative at ocean bottom level + !!====================================================================== + !! History : OPA ! 2002-04 (A. Bozec) Original code + !! NEMO 1.0 ! 2002-08 (G. Madec E. Durand) Optimization and Free form + !! - ! 2004-03 (C. Ethe) adapted for passive tracers + !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + !! 3.6 ! 2014-11 (P. Mathiot) Add zps_hde_isf (needed to open a cavity) + !!====================================================================== + + !!---------------------------------------------------------------------- + !! zps_hde : Horizontal DErivative of T, S and rd at the last + !! ocean level (Z-coord. with Partial Steps) + !!---------------------------------------------------------------------- + USE oce ! ocean: dynamics and tracers variables + USE dom_oce ! domain: ocean variables + USE domutl, ONLY : is_tile + USE phycst ! physical constants + USE eosbn2 ! ocean equation of state + USE in_out_manager ! I/O manager + USE lbclnk ! lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC zps_hde ! routine called by step.F90 + PUBLIC zps_hde_isf ! routine called by step.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zpshde.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zps_hde( kt, Kmm, kjpt, pta, pgtu, pgtv, & + & prd, pgru, pgrv ) + !! + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pta ! 4D tracers fields + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(wp), DIMENSION(:,:,:) , INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + ! + INTEGER :: itrd, itgr + !! + IF( PRESENT(prd) ) THEN ; itrd = is_tile(prd) ; ELSE ; itrd = 0 ; ENDIF + IF( PRESENT(pgru) ) THEN ; itgr = is_tile(pgru) ; ELSE ; itgr = 0 ; ENDIF + + CALL zps_hde_t( kt, Kmm, kjpt, pta, is_tile(pta), pgtu, pgtv, is_tile(pgtu), & + & prd, itrd, pgru, pgrv, itgr ) + END SUBROUTINE zps_hde + + + SUBROUTINE zps_hde_t( kt, Kmm, kjpt, pta, ktta, pgtu, pgtv, ktgt, & + & prd, ktrd, pgru, pgrv, ktgr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zps_hde *** + !! + !! ** Purpose : Compute the horizontal derivative of T, S and rho + !! at u- and v-points with a linear interpolation for z-coordinate + !! with partial steps. + !! + !! ** Method : In z-coord with partial steps, scale factors on last + !! levels are different for each grid point, so that T, S and rd + !! points are not at the same depth as in z-coord. To have horizontal + !! gradients again, we interpolate T and S at the good depth : + !! Linear interpolation of T, S + !! Computation of di(tb) and dj(tb) by vertical interpolation: + !! di(t) = t~ - t(i,j,k) or t(i+1,j,k) - t~ + !! dj(t) = t~ - t(i,j,k) or t(i,j+1,k) - t~ + !! This formulation computes the two cases: + !! CASE 1 CASE 2 + !! k-1 ___ ___________ k-1 ___ ___________ + !! Ti T~ T~ Ti+1 + !! _____ _____ + !! k | |Ti+1 k Ti | | + !! | |____ ____| | + !! ___ | | | ___ | | | + !! + !! case 1-> e3w(i+1,:,:,Kmm) >= e3w(i,:,:,Kmm) ( and e3w(:,j+1,:,Kmm) >= e3w(:,j,:,Kmm) ) then + !! t~ = t(i+1,j ,k) + (e3w(i+1,j,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Ti+1)/e3w(i+1,j,k,Kmm) + !! ( t~ = t(i ,j+1,k) + (e3w(i,j+1,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Tj+1)/e3w(i,j+1,k,Kmm) ) + !! or + !! case 2-> e3w(i+1,:,:,Kmm) <= e3w(i,:,:,Kmm) ( and e3w(:,j+1,:,Kmm) <= e3w(:,j,:,Kmm) ) then + !! t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i+1,j,k,Kmm)) * dk(Ti)/e3w(i,j,k,Kmm) + !! ( t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i,j+1,k,Kmm)) * dk(Tj)/e3w(i,j,k,Kmm) ) + !! Idem for di(s) and dj(s) + !! + !! For rho, we call eos which will compute rd~(t~,s~) at the right + !! depth zh from interpolated T and S for the different formulations + !! of the equation of state (eos). + !! Gradient formulation for rho : + !! di(rho) = rd~ - rd(i,j,k) or rd(i+1,j,k) - rd~ + !! + !! ** Action : compute for top interfaces + !! - pgtu, pgtv: horizontal gradient of tracer at u- & v-points + !! - pgru, pgrv: horizontal gradient of rho (if present) at u- & v-points + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: ktta, ktgt, ktrd, ktgr + REAL(dp), DIMENSION(A2D_T(ktta),JPK,KJPT), INTENT(in ) :: pta ! 4D tracers fields + REAL(wp), DIMENSION(A2D_T(ktgt) ,KJPT), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(wp), DIMENSION(A2D_T(ktrd),JPK ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(wp), DIMENSION(A2D_T(ktgr) ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + ! + INTEGER :: ji, jj, jn ! Dummy loop indices + INTEGER :: iku, ikv, ikum1, ikvm1 ! partial step level (ocean bottom level) at u- and v-points + REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos + REAL(wp), DIMENSION(A2D(nn_hls),kjpt) :: zti, ztj ! + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'zps_hde') + ! + pgtu(:,:,:) = 0._wp ; zti (:,:,:) = 0._wp ; zhi (:,:) = 0._wp + pgtv(:,:,:) = 0._wp ; ztj (:,:,:) = 0._wp ; zhj (:,:) = 0._wp + ! + DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! + ! + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) ! Gradient of density at the last level + iku = mbku(ji,jj) ; ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points + ikv = mbkv(ji,jj) ; ikvm1 = MAX( ikv - 1 , 1 ) ! if level first is a p-step, ik.m1=1 +!!gm BUG ? when applied to before fields, e3w(:,:,k,Kbb) should be used.... + ze3wu = e3w(ji+1,jj ,iku,Kmm) - e3w(ji,jj,iku,Kmm) + ze3wv = e3w(ji ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm) + ! + ! i- direction + IF( ze3wu >= 0._wp ) THEN ! case 1 + zmaxu = ze3wu / e3w(ji+1,jj,iku,Kmm) + ! interpolated values of tracers + zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) + ! gradient of tracers + pgtu(ji,jj,jn) = umask(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) + ELSE ! case 2 + zmaxu = -ze3wu / e3w(ji,jj,iku,Kmm) + ! interpolated values of tracers + zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) + ! gradient of tracers + pgtu(ji,jj,jn) = umask(ji,jj,1) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) + ENDIF + ! + ! j- direction + IF( ze3wv >= 0._wp ) THEN ! case 1 + zmaxv = ze3wv / e3w(ji,jj+1,ikv,Kmm) + ! interpolated values of tracers + ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) + ! gradient of tracers + pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) + ELSE ! case 2 + zmaxv = -ze3wv / e3w(ji,jj,ikv,Kmm) + ! interpolated values of tracers + ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) + ! gradient of tracers + pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) + ENDIF + END_2D + END DO + ! + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. + ! + IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) + pgru(:,:) = 0._wp + pgrv(:,:) = 0._wp ! depth of the partial step level + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + iku = mbku(ji,jj) + ikv = mbkv(ji,jj) + ze3wu = e3w(ji+1,jj ,iku,Kmm) - e3w(ji,jj,iku,Kmm) + ze3wv = e3w(ji ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm) + IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = gdept(ji ,jj,iku,Kmm) ! i-direction: case 1 + ELSE ; zhi(ji,jj) = gdept(ji+1,jj,iku,Kmm) ! - - case 2 + ENDIF + IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = gdept(ji,jj ,ikv,Kmm) ! j-direction: case 1 + ELSE ; zhj(ji,jj) = gdept(ji,jj+1,ikv,Kmm) ! - - case 2 + ENDIF + END_2D + ! + CALL eos( zti, zhi, zri ) ! interpolated density from zti, ztj + CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! Gradient of density at the last level + iku = mbku(ji,jj) + ikv = mbkv(ji,jj) + ze3wu = e3w(ji+1,jj ,iku,Kmm) - e3w(ji,jj,iku,Kmm) + ze3wv = e3w(ji ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm) + IF( ze3wu >= 0._wp ) THEN ; pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji ,jj ) - prd(ji,jj,iku) ) ! i: 1 + ELSE ; pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj ) ) ! i: 2 + ENDIF + IF( ze3wv >= 0._wp ) THEN ; pgrv(ji,jj) = vmask(ji,jj,1) * ( zrj(ji,jj ) - prd(ji,jj,ikv) ) ! j: 1 + ELSE ; pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj ) ) ! j: 2 + ENDIF + END_2D + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions + ! + END IF + ! + IF( ln_timing ) CALL timing_stop( 'zps_hde') + ! + END SUBROUTINE zps_hde_t + + + SUBROUTINE zps_hde_isf( kt, Kmm, kjpt, pta, pgtu, pgtv, pgtui, pgtvi, & + & prd, pgru, pgrv, pgrui, pgrvi ) + !! + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(dp), DIMENSION(:,:,:,:), INTENT(in ) :: pta ! 4D tracers fields + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) + REAL(wp), DIMENSION(:,:,:) , INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) + ! + INTEGER :: itrd, itgr, itgri + !! + IF( PRESENT(prd) ) THEN ; itrd = is_tile(prd) ; ELSE ; itrd = 0 ; ENDIF + IF( PRESENT(pgru) ) THEN ; itgr = is_tile(pgru) ; ELSE ; itgr = 0 ; ENDIF + IF( PRESENT(pgrui) ) THEN ; itgri = is_tile(pgrui) ; ELSE ; itgri = 0 ; ENDIF + + CALL zps_hde_isf_t( kt, Kmm, kjpt, pta, is_tile(pta), pgtu, pgtv, is_tile(pgtu), pgtui, pgtvi, is_tile(pgtui), & + & prd, itrd, pgru, pgrv, itgr, pgrui, pgrvi, itgri ) + END SUBROUTINE zps_hde_isf + + + SUBROUTINE zps_hde_isf_t( kt, Kmm, kjpt, pta, ktta, pgtu, pgtv, ktgt, pgtui, pgtvi, ktgti, & + & prd, ktrd, pgru, pgrv, ktgr, pgrui, pgrvi, ktgri ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zps_hde_isf *** + !! + !! ** Purpose : Compute the horizontal derivative of T, S and rho + !! at u- and v-points with a linear interpolation for z-coordinate + !! with partial steps for top (ice shelf) and bottom. + !! + !! ** Method : In z-coord with partial steps, scale factors on last + !! levels are different for each grid point, so that T, S and rd + !! points are not at the same depth as in z-coord. To have horizontal + !! gradients again, we interpolate T and S at the good depth : + !! For the bottom case: + !! Linear interpolation of T, S + !! Computation of di(tb) and dj(tb) by vertical interpolation: + !! di(t) = t~ - t(i,j,k) or t(i+1,j,k) - t~ + !! dj(t) = t~ - t(i,j,k) or t(i,j+1,k) - t~ + !! This formulation computes the two cases: + !! CASE 1 CASE 2 + !! k-1 ___ ___________ k-1 ___ ___________ + !! Ti T~ T~ Ti+1 + !! _____ _____ + !! k | |Ti+1 k Ti | | + !! | |____ ____| | + !! ___ | | | ___ | | | + !! + !! case 1-> e3w(i+1,j,k,Kmm) >= e3w(i,j,k,Kmm) ( and e3w(i,j+1,k,Kmm) >= e3w(i,j,k,Kmm) ) then + !! t~ = t(i+1,j ,k) + (e3w(i+1,j ,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Ti+1)/e3w(i+1,j ,k,Kmm) + !! ( t~ = t(i ,j+1,k) + (e3w(i ,j+1,k,Kmm) - e3w(i,j,k,Kmm)) * dk(Tj+1)/e3w(i ,j+1,k,Kmm) ) + !! or + !! case 2-> e3w(i+1,j,k,Kmm) <= e3w(i,j,k,Kmm) ( and e3w(i,j+1,k,Kmm) <= e3w(i,j,k,Kmm) ) then + !! t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i+1,j ,k,Kmm)) * dk(Ti)/e3w(i,j,k,Kmm) + !! ( t~ = t(i,j,k) + (e3w(i,j,k,Kmm) - e3w(i ,j+1,k,Kmm)) * dk(Tj)/e3w(i,j,k,Kmm) ) + !! Idem for di(s) and dj(s) + !! + !! For rho, we call eos which will compute rd~(t~,s~) at the right + !! depth zh from interpolated T and S for the different formulations + !! of the equation of state (eos). + !! Gradient formulation for rho : + !! di(rho) = rd~ - rd(i,j,k) or rd(i+1,j,k) - rd~ + !! + !! For the top case (ice shelf): As for the bottom case but upside down + !! + !! ** Action : compute for top and bottom interfaces + !! - pgtu, pgtv, pgtui, pgtvi: horizontal gradient of tracer at u- & v-points + !! - pgru, pgrv, pgrui, pgtvi: horizontal gradient of rho (if present) at u- & v-points + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + INTEGER , INTENT(in ) :: kjpt ! number of tracers + INTEGER , INTENT(in ) :: ktta, ktgt, ktgti, ktrd, ktgr, ktgri + REAL(dp), DIMENSION(A2D_T(ktta),JPK,KJPT), INTENT(in ) :: pta ! 4D tracers fields + REAL(wp), DIMENSION(A2D_T(ktgt) ,KJPT), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(wp), DIMENSION(A2D_T(ktgti) ,KJPT), INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) + REAL(wp), DIMENSION(A2D_T(ktrd),JPK ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(wp), DIMENSION(A2D_T(ktgr) ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + REAL(wp), DIMENSION(A2D_T(ktgri) ), INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) + ! + INTEGER :: ji, jj, jn ! Dummy loop indices + INTEGER :: iku, ikv, ikum1, ikvm1,ikup1, ikvp1 ! partial step level (ocean bottom level) at u- and v-points + REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! temporary scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos + REAL(wp), DIMENSION(A2D(nn_hls),kjpt) :: zti, ztj ! + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start( 'zps_hde_isf') + ! + pgtu (:,:,:) = 0._wp ; pgtv (:,:,:) =0._wp + pgtui(:,:,:) = 0._wp ; pgtvi(:,:,:) =0._wp + zti (:,:,:) = 0._wp ; ztj (:,:,:) =0._wp + zhi (:,: ) = 0._wp ; zhj (:,: ) =0._wp + ! + DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! + ! + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + + iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points + ikv = mbkv(ji,jj); ikvm1 = MAX( ikv - 1 , 1 ) ! if level first is a p-step, ik.m1=1 + ze3wu = gdept(ji+1,jj,iku,Kmm) - gdept(ji,jj,iku,Kmm) + ze3wv = gdept(ji,jj+1,ikv,Kmm) - gdept(ji,jj,ikv,Kmm) + ! + ! i- direction + IF( ze3wu >= 0._wp ) THEN ! case 1 + zmaxu = ze3wu / e3w(ji+1,jj,iku,Kmm) + ! interpolated values of tracers + zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) + ! gradient of tracers + pgtu(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) + ELSE ! case 2 + zmaxu = -ze3wu / e3w(ji,jj,iku,Kmm) + ! interpolated values of tracers + zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) + ! gradient of tracers + pgtu(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) + ENDIF + ! + ! j- direction + IF( ze3wv >= 0._wp ) THEN ! case 1 + zmaxv = ze3wv / e3w(ji,jj+1,ikv,Kmm) + ! interpolated values of tracers + ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) + ! gradient of tracers + pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) + ELSE ! case 2 + zmaxv = -ze3wv / e3w(ji,jj,ikv,Kmm) + ! interpolated values of tracers + ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) + ! gradient of tracers + pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) + ENDIF + + END_2D + END DO + ! + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. + + ! horizontal derivative of density anomalies (rd) + IF( PRESENT( prd ) ) THEN ! depth of the partial step level + pgru(:,:)=0.0_wp ; pgrv(:,:)=0.0_wp ; + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + + iku = mbku(ji,jj) + ikv = mbkv(ji,jj) + ze3wu = gdept(ji+1,jj,iku,Kmm) - gdept(ji,jj,iku,Kmm) + ze3wv = gdept(ji,jj+1,ikv,Kmm) - gdept(ji,jj,ikv,Kmm) + ! + IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = gdept(ji ,jj,iku,Kmm) ! i-direction: case 1 + ELSE ; zhi(ji,jj) = gdept(ji+1,jj,iku,Kmm) ! - - case 2 + ENDIF + IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = gdept(ji,jj ,ikv,Kmm) ! j-direction: case 1 + ELSE ; zhj(ji,jj) = gdept(ji,jj+1,ikv,Kmm) ! - - case 2 + ENDIF + + END_2D + + ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial + ! step and store it in zri, zrj for each case + CALL eos( zti, zhi, zri ) + CALL eos( ztj, zhj, zrj ) + + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + iku = mbku(ji,jj) + ikv = mbkv(ji,jj) + ze3wu = gdept(ji+1,jj,iku,Kmm) - gdept(ji,jj,iku,Kmm) + ze3wv = gdept(ji,jj+1,ikv,Kmm) - gdept(ji,jj,ikv,Kmm) + + IF( ze3wu >= 0._wp ) THEN ; pgru(ji,jj) = ssumask(ji,jj) * ( zri(ji ,jj ) - prd(ji,jj,iku) ) ! i: 1 + ELSE ; pgru(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj,iku) - zri(ji,jj ) ) ! i: 2 + ENDIF + IF( ze3wv >= 0._wp ) THEN ; pgrv(ji,jj) = ssvmask(ji,jj) * ( zrj(ji,jj ) - prd(ji,jj,ikv) ) ! j: 1 + ELSE ; pgrv(ji,jj) = ssvmask(ji,jj) * ( prd(ji,jj+1,ikv) - zrj(ji,jj ) ) ! j: 2 + ENDIF + + END_2D + + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions + ! + END IF + ! + ! !== (ISH) compute grui and gruvi ==! + ! + DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! ! + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1 + ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1 + ! + ! (ISF) case partial step top and bottom in adjacent cell in vertical + ! cannot used e3w because if 2 cell water column, we have ps at top and bottom + ! in this case e3w(i,j,k,Kmm) - e3w(i,j+1,k,Kmm) is not the distance between Tj~ and Tj + ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0 + ze3wu = gdept(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm) + ze3wv = gdept(ji,jj,ikv,Kmm) - gdept(ji,jj+1,ikv,Kmm) + + ! i- direction + IF( ze3wu >= 0._wp ) THEN ! case 1 + zmaxu = ze3wu / e3w(ji+1,jj,ikup1,Kmm) + ! interpolated values of tracers + zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikup1,jn) - pta(ji+1,jj,iku,jn) ) + ! gradient of tracers + pgtui(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) + ELSE ! case 2 + zmaxu = - ze3wu / e3w(ji,jj,ikup1,Kmm) + ! interpolated values of tracers + zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikup1,jn) - pta(ji,jj,iku,jn) ) + ! gradient of tracers + pgtui(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) + ENDIF + ! + ! j- direction + IF( ze3wv >= 0._wp ) THEN ! case 1 + zmaxv = ze3wv / e3w(ji,jj+1,ikvp1,Kmm) + ! interpolated values of tracers + ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvp1,jn) - pta(ji,jj+1,ikv,jn) ) + ! gradient of tracers + pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) + ELSE ! case 2 + zmaxv = - ze3wv / e3w(ji,jj,ikvp1,Kmm) + ! interpolated values of tracers + ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvp1,jn) - pta(ji,jj,ikv,jn) ) + ! gradient of tracers + pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) + ENDIF + + END_2D + ! + END DO + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. + + IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) + ! + pgrui(:,:) =0.0_wp; pgrvi(:,:) =0.0_wp; + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + + iku = miku(ji,jj) + ikv = mikv(ji,jj) + ze3wu = gdept(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm) + ze3wv = gdept(ji,jj,ikv,Kmm) - gdept(ji,jj+1,ikv,Kmm) + ! + IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = gdept(ji ,jj,iku,Kmm) ! i-direction: case 1 + ELSE ; zhi(ji,jj) = gdept(ji+1,jj,iku,Kmm) ! - - case 2 + ENDIF + + IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = gdept(ji,jj ,ikv,Kmm) ! j-direction: case 1 + ELSE ; zhj(ji,jj) = gdept(ji,jj+1,ikv,Kmm) ! - - case 2 + ENDIF + + END_2D + ! + CALL eos( zti, zhi, zri ) ! interpolated density from zti, ztj + CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + iku = miku(ji,jj) + ikv = mikv(ji,jj) + ze3wu = gdept(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm) + ze3wv = gdept(ji,jj,ikv,Kmm) - gdept(ji,jj+1,ikv,Kmm) + + IF( ze3wu >= 0._wp ) THEN ; pgrui(ji,jj) = ssumask(ji,jj) * ( zri(ji ,jj ) - prd(ji,jj,iku) ) ! i: 1 + ELSE ; pgrui(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj ,iku) - zri(ji,jj ) ) ! i: 2 + ENDIF + IF( ze3wv >= 0._wp ) THEN ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( zrj(ji ,jj ) - prd(ji,jj,ikv) ) ! j: 1 + ELSE ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( prd(ji ,jj+1,ikv) - zrj(ji,jj ) ) ! j: 2 + ENDIF + + END_2D + IF (nn_hls==1) CALL lbc_lnk( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions + ! + END IF + ! + IF( ln_timing ) CALL timing_stop( 'zps_hde_isf') + ! + END SUBROUTINE zps_hde_isf_t + + !!====================================================================== +END MODULE zpshde \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trd_oce.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trd_oce.F90 new file mode 100644 index 0000000..c140b8f --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trd_oce.F90 @@ -0,0 +1,83 @@ +MODULE trd_oce + !!====================================================================== + !! *** MODULE trd_oce *** + !! Ocean trends : set tracer and momentum trend variables + !!====================================================================== + !! History : 1.0 ! 2004-08 (C. Talandier) Original code + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE trdmxl_oce ! ocean active mixed layer tracers trends variables + USE trdvor_oce ! ocean vorticity trends variables + + IMPLICIT NONE + PUBLIC + + ! !!* Namelist namtrd: diagnostics on dynamics/tracer trends * + LOGICAL , PUBLIC :: ln_dyn_trd = .FALSE. !: (T) 3D momentum trends or (F) not + LOGICAL , PUBLIC :: ln_tra_trd = .FALSE. !: (T) 3D tracer trends or (F) not + LOGICAL , PUBLIC :: ln_KE_trd = .FALSE. !: (T) 3D Kinetic Energy trends or (F) not + LOGICAL , PUBLIC :: ln_PE_trd = .FALSE. !: (T) 3D Potential Energy trends or (F) not + LOGICAL , PUBLIC :: ln_vor_trd = .FALSE. !: (T) 3D barotropic vorticity trends or (F) not + LOGICAL , PUBLIC :: ln_glo_trd = .FALSE. !: (T) global domain averaged diag for T, T^2, KE, and PE + LOGICAL , PUBLIC :: ln_dyn_mxl = .FALSE. !: (T) 2D tracer trends averaged over the mixed layer + LOGICAL , PUBLIC :: ln_tra_mxl = .FALSE. !: (T) 2D momentum trends averaged over the mixed layer + INTEGER , PUBLIC :: nn_trd = 10 !: time step frequency for ln_glo_trd=T only + + LOGICAL , PUBLIC :: l_trdtra !: tracers trend flag (set from namelist in trdini) + LOGICAL , PUBLIC :: l_trddyn !: momentum trend flag (set from namelist in trdini) + +# if ( defined key_trdtrc && defined key_xios ) || defined key_trdmxl_trc + LOGICAL , PUBLIC :: l_trdtrc = .TRUE. !: tracers trend flag +# else + LOGICAL , PUBLIC :: l_trdtrc = .FALSE. !: tracers trend flag +# endif + ! !!!* Active tracers trends indexes + INTEGER, PUBLIC, PARAMETER :: jptot_tra = 21 !: Total trend nb: change it when adding/removing one indice below + ! =============== ! + INTEGER, PUBLIC, PARAMETER :: jptra_xad = 1 !: x- horizontal advection + INTEGER, PUBLIC, PARAMETER :: jptra_yad = 2 !: y- horizontal advection + INTEGER, PUBLIC, PARAMETER :: jptra_zad = 3 !: z- vertical advection + INTEGER, PUBLIC, PARAMETER :: jptra_sad = 4 !: z- vertical advection + INTEGER, PUBLIC, PARAMETER :: jptra_totad = 5 !: total advection + INTEGER, PUBLIC, PARAMETER :: jptra_ldf = 6 !: lateral diffusion + INTEGER, PUBLIC, PARAMETER :: jptra_zdf = 7 !: vertical diffusion + INTEGER, PUBLIC, PARAMETER :: jptra_zdfp = 8 !: "PURE" vert. diffusion (ln_traldf_iso=T) + INTEGER, PUBLIC, PARAMETER :: jptra_evd = 9 !: EVD term (convection) + INTEGER, PUBLIC, PARAMETER :: jptra_bbc = 10 !: Bottom Boundary Condition (geoth. heating) + INTEGER, PUBLIC, PARAMETER :: jptra_bbl = 11 !: Bottom Boundary Layer (diffusive and/or advective) + INTEGER, PUBLIC, PARAMETER :: jptra_osm = 21 !: Non-local terms from OSMOSIS OBL model + INTEGER, PUBLIC, PARAMETER :: jptra_npc = 12 !: non-penetrative convection treatment + INTEGER, PUBLIC, PARAMETER :: jptra_dmp = 13 !: internal restoring (damping) + INTEGER, PUBLIC, PARAMETER :: jptra_qsr = 14 !: penetrative solar radiation + INTEGER, PUBLIC, PARAMETER :: jptra_nsr = 15 !: non solar radiation / C/D on salinity (+runoff if ln_rnf=T) + INTEGER, PUBLIC, PARAMETER :: jptra_atf = 16 !: Asselin time filter + INTEGER, PUBLIC, PARAMETER :: jptra_tot = 17 !: Model total trend + ! + ! !!!* Passive tracers trends indices (use if "key_top" defined) + INTEGER, PUBLIC, PARAMETER :: jptra_sms = 18 !: sources m. sinks + INTEGER, PUBLIC, PARAMETER :: jptra_radn = 19 !: corr. trn<0 in trcrad + INTEGER, PUBLIC, PARAMETER :: jptra_radb = 20 !: corr. trb<0 in trcrad (like atf) + ! + ! !!!* Momentum trends indices + INTEGER, PUBLIC, PARAMETER :: jptot_dyn = 13 !: Total trend nb: change it when adding/removing one indice below + ! =============== ! + INTEGER, PUBLIC, PARAMETER :: jpdyn_hpg = 1 !: hydrostatic pressure gradient + INTEGER, PUBLIC, PARAMETER :: jpdyn_spg = 2 !: surface pressure gradient + INTEGER, PUBLIC, PARAMETER :: jpdyn_keg = 3 !: kinetic energy gradient or horizontal advection + INTEGER, PUBLIC, PARAMETER :: jpdyn_rvo = 4 !: relative vorticity or metric term + INTEGER, PUBLIC, PARAMETER :: jpdyn_pvo = 5 !: planetary vorticity + INTEGER, PUBLIC, PARAMETER :: jpdyn_zad = 6 !: vertical advection + INTEGER, PUBLIC, PARAMETER :: jpdyn_ldf = 7 !: horizontal diffusion + INTEGER, PUBLIC, PARAMETER :: jpdyn_zdf = 8 !: vertical diffusion + INTEGER, PUBLIC, PARAMETER :: jpdyn_bfr = 9 !: bottom stress + INTEGER, PUBLIC, PARAMETER :: jpdyn_atf = 10 !: Asselin time filter + INTEGER, PUBLIC, PARAMETER :: jpdyn_tau = 11 !: surface stress + INTEGER, PUBLIC, PARAMETER :: jpdyn_bfri = 12 !: implicit bottom friction (ln_drgimp=.TRUE.) + INTEGER, PUBLIC, PARAMETER :: jpdyn_ken = 13 !: use for calculation of KE + ! + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trd_oce.F90 14239 2020-12-23 08:57:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trd_oce \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trddyn.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trddyn.F90 new file mode 100644 index 0000000..1f4976b --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trddyn.F90 @@ -0,0 +1,182 @@ +MODULE trddyn + !!====================================================================== + !! *** MODULE trddyn *** + !! Ocean diagnostics: ocean dynamic trends + !!===================================================================== + !! History : 3.5 ! 2012-02 (G. Madec) creation from trdmod: split DYN and TRA trends + !! and manage 3D trends output for U, V, and KE + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_dyn : manage the type of momentum trend diagnostics (3D I/O, domain averaged, KE) + !! trd_dyn_iom : output 3D momentum and/or tracer trends using IOM + !! trd_dyn_init : initialization step + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE phycst ! physical constants + USE sbc_oce ! surface boundary condition: ocean + USE zdf_oce ! ocean vertical physics: variables +!!gm USE zdfdrg ! ocean vertical physics: bottom friction + USE trd_oce ! trends: ocean variables + USE trdken ! trends: Kinetic ENergy + USE trdglo ! trends: global domain averaged + USE trdvor ! trends: vertical averaged vorticity + USE trdmxl ! trends: mixed layer averaged + ! + USE in_out_manager ! I/O manager + USE lbclnk ! lateral boundary condition + USE iom ! I/O manager library + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_dyn ! called by all dynXXX modules + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trddyn.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_dyn( putrd, pvtrd, ktrd, kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_mod *** + !! + !! ** Purpose : Dispatch momentum trend computation, e.g. 3D output, + !! integral constraints, barotropic vorticity, kinetic enrgy, + !! and/or mixed layer budget. + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V trends + INTEGER , INTENT(in ) :: ktrd ! trend index + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + !!---------------------------------------------------------------------- + ! + putrd(:,:,:) = putrd(:,:,:) * umask(:,:,:) ! mask the trends + pvtrd(:,:,:) = pvtrd(:,:,:) * vmask(:,:,:) + ! + +!!gm NB : here a lbc_lnk should probably be added + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! 3D output of momentum and/or tracers trends using IOM interface + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_dyn_trd ) CALL trd_dyn_iom( putrd, pvtrd, ktrd, kt, Kmm ) + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! Integral Constraints Properties for momentum and/or tracers trends + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_glo_trd ) CALL trd_glo( putrd, pvtrd, ktrd, 'DYN', kt, Kmm ) + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! Kinetic Energy trends + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF( ln_KE_trd ) CALL trd_ken( putrd, pvtrd, ktrd, kt, Kmm ) + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! Vorticity trends + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF( ln_vor_trd ) CALL trd_vor( putrd, pvtrd, ktrd, kt, Kmm ) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Mixed layer trends for active tracers + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +!!gm IF( ln_dyn_mxl ) CALL trd_mxl_dyn + ! + END SUBROUTINE trd_dyn + + + SUBROUTINE trd_dyn_iom( putrd, pvtrd, ktrd, kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_dyn_iom *** + !! + !! ** Purpose : output 3D trends using IOM + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V trends + INTEGER , INTENT(in ) :: ktrd ! trend index + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikbu, ikbv ! local integers + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2dx, z2dy ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3dx, z3dy ! 3D workspace + !!---------------------------------------------------------------------- + ! + SELECT CASE( ktrd ) + CASE( jpdyn_hpg ) ; CALL iom_put( "utrd_hpg", putrd ) ! hydrostatic pressure gradient + CALL iom_put( "vtrd_hpg", pvtrd ) + CASE( jpdyn_spg ) ; CALL iom_put( "utrd_spg", putrd ) ! surface pressure gradient + CALL iom_put( "vtrd_spg", pvtrd ) + CASE( jpdyn_pvo ) ; CALL iom_put( "utrd_pvo", putrd ) ! planetary vorticity + CALL iom_put( "vtrd_pvo", pvtrd ) + CASE( jpdyn_rvo ) ; CALL iom_put( "utrd_rvo", putrd ) ! relative vorticity (or metric term) + CALL iom_put( "vtrd_rvo", pvtrd ) + CASE( jpdyn_keg ) ; CALL iom_put( "utrd_keg", putrd ) ! Kinetic Energy gradient (or had) + CALL iom_put( "vtrd_keg", pvtrd ) + ALLOCATE( z3dx(jpi,jpj,jpk) , z3dy(jpi,jpj,jpk) ) + z3dx(:,:,:) = 0._wp ! U.dxU & V.dyV (approximation) + z3dy(:,:,:) = 0._wp + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! no mask as un,vn are masked + z3dx(ji,jj,jk) = uu(ji,jj,jk,Kmm) * ( uu(ji+1,jj,jk,Kmm) - uu(ji-1,jj,jk,Kmm) ) / ( 2._wp * e1u(ji,jj) ) + z3dy(ji,jj,jk) = vv(ji,jj,jk,Kmm) * ( vv(ji,jj+1,jk,Kmm) - vv(ji,jj-1,jk,Kmm) ) / ( 2._wp * e2v(ji,jj) ) + END_3D + CALL lbc_lnk( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) + CALL iom_put( "utrd_udx", z3dx ) + CALL iom_put( "vtrd_vdy", z3dy ) + DEALLOCATE( z3dx , z3dy ) + CASE( jpdyn_zad ) ; CALL iom_put( "utrd_zad", putrd ) ! vertical advection + CALL iom_put( "vtrd_zad", pvtrd ) + CASE( jpdyn_ldf ) ; CALL iom_put( "utrd_ldf", putrd ) ! lateral diffusion + CALL iom_put( "vtrd_ldf", pvtrd ) + CASE( jpdyn_zdf ) ; CALL iom_put( "utrd_zdf", putrd ) ! vertical diffusion + CALL iom_put( "vtrd_zdf", pvtrd ) + ! + ! ! wind stress trends + ALLOCATE( z2dx(jpi,jpj) , z2dy(jpi,jpj) ) + z2dx(:,:) = ( utau_b(:,:) + utau(:,:) ) / ( e3u(:,:,1,Kmm) * rho0 ) + z2dy(:,:) = ( vtau_b(:,:) + vtau(:,:) ) / ( e3v(:,:,1,Kmm) * rho0 ) + CALL iom_put( "utrd_tau", z2dx ) + CALL iom_put( "vtrd_tau", z2dy ) + DEALLOCATE( z2dx , z2dy ) +!!gm to be changed : computation should be done in dynzdf.F90 +!!gm + missing the top friction +! ! ! bottom stress tends (implicit case) +! IF( ln_drgimp ) THEN +! ALLOCATE( z3dx(jpi,jpj,jpk) , z3dy(jpi,jpj,jpk) ) +! z3dx(:,:,:) = 0._wp ; z3dy(:,:,:) = 0._wp ! after velocity known (now filed at this stage) +! DO jk = 1, jpkm1 +! DO jj = 2, jpjm1 +! DO ji = 2, jpim1 +! ikbu = mbku(ji,jj) ! deepest ocean u- & v-levels +! ikbv = mbkv(ji,jj) +! z3dx(ji,jj,jk) = 0.5 * ( rCdU_bot(ji+1,jj) + rCdU_bot(ji,jj) ) & +! & * uu(ji,jj,ikbu,Kmm) / e3u(ji,jj,ikbu,Kmm) +! z3dy(ji,jj,jk) = 0.5 * ( rCdU_bot(ji,jj+1) + rCdU_bot(ji,jj) ) & +! & * vv(ji,jj,ikbv,Kmm) / e3v(ji,jj,ikbv,Kmm) +! END DO +! END DO +! END DO +! CALL lbc_lnk( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) +! CALL iom_put( "utrd_bfr", z3dx ) +! CALL iom_put( "vtrd_bfr", z3dy ) +! DEALLOCATE( z3dx , z3dy ) +! ENDIF +!!gm end + CASE( jpdyn_bfr ) ! called if ln_drgimp=F + CALL iom_put( "utrd_bfr", putrd ) ! bottom friction (explicit case) + CALL iom_put( "vtrd_bfr", pvtrd ) + CASE( jpdyn_atf ) ; CALL iom_put( "utrd_atf", putrd ) ! asselin filter trends + CALL iom_put( "vtrd_atf", pvtrd ) + END SELECT + ! + END SUBROUTINE trd_dyn_iom + + !!====================================================================== +END MODULE trddyn \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdglo.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdglo.F90 new file mode 100644 index 0000000..08116dc --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdglo.F90 @@ -0,0 +1,547 @@ +MODULE trdglo + !!====================================================================== + !! *** MODULE trdglo *** + !! Ocean diagnostics: global domain averaged tracer and momentum trends + !!===================================================================== + !! History : 1.0 ! 2004-08 (C. Talandier) New trends organization + !! 3.5 ! 2012-02 (G. Madec) add 3D tracer zdf trend output using iom + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_glo : domain averaged budget of trends (including kinetic energy and T^2 trends) + !! glo_dyn_wri : print dynamic trends in ocean.output file + !! glo_tra_wri : print global T & T^2 trends in ocean.output file + !! trd_glo_init : initialization step + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE sbc_oce ! surface boundary condition: ocean + USE trd_oce ! trends: ocean variables + USE phycst ! physical constants + USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. + USE ldfdyn ! ocean dynamics: lateral physics + USE zdf_oce ! ocean vertical physics +!!gm USE zdfdrg ! ocean vertical physics: bottom friction + USE zdfddm ! ocean vertical physics: double diffusion + USE eosbn2 ! equation of state + USE phycst ! physical constants + ! + USE lib_mpp ! distibuted memory computing library + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_glo ! called by trdtra and trddyn modules + PUBLIC trd_glo_init ! called by trdini module + + ! !!! Variables used for diagnostics + REAL(wp) :: tvolt ! volume of the whole ocean computed at t-points + REAL(wp) :: tvolu ! volume of the whole ocean computed at u-points + REAL(wp) :: tvolv ! volume of the whole ocean computed at v-points + REAL(wp) :: rpktrd ! potential to kinetic energy conversion + REAL(wp) :: peke ! conversion potential energy - kinetic energy trend + + ! !!! domain averaged trends + REAL(wp), DIMENSION(jptot_tra) :: tmo, smo ! temperature and salinity trends + REAL(wp), DIMENSION(jptot_tra) :: t2 , s2 ! T^2 and S^2 trends + REAL(wp), DIMENSION(jptot_dyn) :: umo, vmo ! momentum trends + REAL(wp), DIMENSION(jptot_dyn) :: hke ! kinetic energy trends (u^2+v^2) + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdglo.F90 13497 2020-09-21 12:37:46Z techene $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_glo( ptrdx, ptrdy, ktrd, ctype, kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_glo *** + !! + !! ** Purpose : compute and print global domain averaged trends for + !! T, T^2, momentum, KE, and KE<->PE + !! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdx ! Temperature or U trend + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdy ! Salinity or V trend + INTEGER , INTENT(in ) :: ktrd ! tracer trend index + CHARACTER(len=3) , INTENT(in ) :: ctype ! momentum or tracers trends type (='DYN'/'TRA') + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + !! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikbu, ikbv ! local integers + REAL(wp):: zvm, zvt, zvs, z1_2rho0 ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: ztswu, ztswv, z2dx, z2dy ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF( MOD(kt,nn_trd) == 0 .OR. kt == nit000 .OR. kt == nitend ) THEN + ! + SELECT CASE( ctype ) + ! + CASE( 'TRA' ) !== Tracers (T & S) ==! + DO_3D( 1, 1, 1, 1, 1, jpkm1 ) ! global sum of mask volume trend and trend*T (including interior mask) + zvm = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) * tmask_i(ji,jj) + zvt = ptrdx(ji,jj,jk) * zvm + zvs = ptrdy(ji,jj,jk) * zvm + tmo(ktrd) = tmo(ktrd) + zvt + smo(ktrd) = smo(ktrd) + zvs + t2 (ktrd) = t2(ktrd) + zvt * ts(ji,jj,jk,jp_tem,Kmm) + s2 (ktrd) = s2(ktrd) + zvs * ts(ji,jj,jk,jp_sal,Kmm) + END_3D + ! ! linear free surface: diagnose advective flux trough the fixed k=1 w-surface + IF( ln_linssh .AND. ktrd == jptra_zad ) THEN + tmo(jptra_sad) = SUM( ww(:,:,1) * ts(:,:,1,jp_tem,Kmm) * e1e2t(:,:) * tmask_i(:,:) ) + smo(jptra_sad) = SUM( ww(:,:,1) * ts(:,:,1,jp_sal,Kmm) * e1e2t(:,:) * tmask_i(:,:) ) + t2 (jptra_sad) = SUM( ww(:,:,1) * ts(:,:,1,jp_tem,Kmm) * ts(:,:,1,jp_tem,Kmm) * e1e2t(:,:) * tmask_i(:,:) ) + s2 (jptra_sad) = SUM( ww(:,:,1) * ts(:,:,1,jp_sal,Kmm) * ts(:,:,1,jp_sal,Kmm) * e1e2t(:,:) * tmask_i(:,:) ) + ENDIF + ! + IF( ktrd == jptra_atf ) THEN ! last trend (asselin time filter) + ! + CALL glo_tra_wri( kt ) ! print the results in ocean.output + ! + tmo(:) = 0._wp ! prepare the next time step (domain averaged array reset to zero) + smo(:) = 0._wp + t2 (:) = 0._wp + s2 (:) = 0._wp + ! + ENDIF + ! + CASE( 'DYN' ) !== Momentum and KE ==! + DO_3D( 1, 0, 1, 0, 1, jpkm1 ) + zvt = ptrdx(ji,jj,jk) * tmask_i(ji+1,jj) * tmask_i(ji,jj) * umask(ji,jj,jk) & + & * e1e2u (ji,jj) * e3u(ji,jj,jk,Kmm) + zvs = ptrdy(ji,jj,jk) * tmask_i(ji,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) & + & * e1e2v (ji,jj) * e3u(ji,jj,jk,Kmm) + umo(ktrd) = umo(ktrd) + zvt + vmo(ktrd) = vmo(ktrd) + zvs + hke(ktrd) = hke(ktrd) + uu(ji,jj,jk,Kmm) * zvt + vv(ji,jj,jk,Kmm) * zvs + END_3D + ! + IF( ktrd == jpdyn_zdf ) THEN ! zdf trend: compute separately the surface forcing trend + z1_2rho0 = 0.5_wp / rho0 + DO_2D( 1, 0, 1, 0 ) + zvt = ( utau_b(ji,jj) + utau(ji,jj) ) * tmask_i(ji+1,jj) * tmask_i(ji,jj) * umask(ji,jj,jk) & + & * z1_2rho0 * e1e2u(ji,jj) + zvs = ( vtau_b(ji,jj) + vtau(ji,jj) ) * tmask_i(ji,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) & + & * z1_2rho0 * e1e2v(ji,jj) + umo(jpdyn_tau) = umo(jpdyn_tau) + zvt + vmo(jpdyn_tau) = vmo(jpdyn_tau) + zvs + hke(jpdyn_tau) = hke(jpdyn_tau) + uu(ji,jj,1,Kmm) * zvt + vv(ji,jj,1,Kmm) * zvs + END_2D + ENDIF + ! +!!gm miss placed calculation ===>>>> to be done in dynzdf.F90 +! IF( ktrd == jpdyn_atf ) THEN ! last trend (asselin time filter) +! ! +! IF( ln_drgimp ) THEN ! implicit drag case: compute separately the bottom friction +! z1_2rho0 = 0.5_wp / rho0 +! DO jj = 1, jpjm1 +! DO ji = 1, jpim1 +! ikbu = mbku(ji,jj) ! deepest ocean u- & v-levels +! ikbv = mbkv(ji,jj) +! zvt = 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * uu(ji,jj,ikbu,Kmm) * e1e2u(ji,jj) +! zvs = 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * vv(ji,jj,ikbv,Kmm) * e1e2v(ji,jj) +! umo(jpdyn_bfri) = umo(jpdyn_bfri) + zvt +! vmo(jpdyn_bfri) = vmo(jpdyn_bfri) + zvs +! hke(jpdyn_bfri) = hke(jpdyn_bfri) + uu(ji,jj,ikbu,Kmm) * zvt + vv(ji,jj,ikbv,Kmm) * zvs +! END DO +! END DO +! ENDIF +! +!!gm top drag case is missing +! +! ! +! CALL glo_dyn_wri( kt ) ! print the results in ocean.output +! ! +! umo(:) = 0._wp ! reset for the next time step +! vmo(:) = 0._wp +! hke(:) = 0._wp +! ! +! ENDIF +!!gm end + ! + END SELECT + ! + ENDIF + ! + END SUBROUTINE trd_glo + + + SUBROUTINE glo_dyn_wri( kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE glo_dyn_wri *** + !! + !! ** Purpose : write global averaged U, KE, PE<->KE trends in ocean.output + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kmm ! time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcof ! local scalar + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zkx, zky, zkz, zkepe + !!---------------------------------------------------------------------- + + ! I. Momentum trends + ! ------------------- + + IF( MOD( kt, nn_trd ) == 0 .OR. kt == nit000 .OR. kt == nitend ) THEN + + ! I.1 Conversion potential energy - kinetic energy + ! -------------------------------------------------- + ! c a u t i o n here, trends are computed at kt+1 (now , but after the swap) + zkx (:,:,:) = 0._wp + zky (:,:,:) = 0._wp + zkz (:,:,:) = 0._wp + zkepe(:,:,:) = 0._wp + + CALL eos( ts(:,:,:,:,Kmm), rhd, CASTSP(rhop) ) ! now potential density + + zcof = 0.5_wp / rho0 ! Density flux at w-point + zkz(:,:,1) = 0._wp + DO jk = 2, jpk + zkz(:,:,jk) = zcof * e1e2t(:,:) * ww(:,:,jk) * ( rhop(:,:,jk) + rhop(:,:,jk-1) ) * tmask_i(:,:) + END DO + + zcof = 0.5_wp / rho0 ! Density flux at u and v-points + DO_3D( 1, 0, 1, 0, 1, jpkm1 ) + zkx(ji,jj,jk) = zcof * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) & + & * uu(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji+1,jj,jk) ) + zky(ji,jj,jk) = zcof * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) & + & * vv(ji,jj,jk,Kmm) * ( rhop(ji,jj,jk) + rhop(ji,jj+1,jk) ) + END_3D + + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Density flux divergence at t-point + zkepe(ji,jj,jk) = - ( zkz(ji,jj,jk) - zkz(ji ,jj ,jk+1) & + & + zkx(ji,jj,jk) - zkx(ji-1,jj ,jk ) & + & + zky(ji,jj,jk) - zky(ji ,jj-1,jk ) ) & + & / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) * tmask(ji,jj,jk) * tmask_i(ji,jj) + END_3D + + ! I.2 Basin averaged kinetic energy trend + ! ---------------------------------------- + peke = 0._wp + DO jk = 1, jpkm1 + peke = peke + SUM( zkepe(:,:,jk) * gdept(:,:,jk,Kmm) * e1e2t(:,:) & + & * e3t(:,:,jk,Kmm) ) + END DO + peke = grav * peke + + ! I.3 Sums over the global domain + ! --------------------------------- + IF( lk_mpp ) THEN + CALL mpp_sum( 'trdglo', peke ) + CALL mpp_sum( 'trdglo', umo , jptot_dyn ) + CALL mpp_sum( 'trdglo', vmo , jptot_dyn ) + CALL mpp_sum( 'trdglo', hke , jptot_dyn ) + ENDIF + + ! I.2 Print dynamic trends in the ocean.output file + ! -------------------------------------------------- + + IF(lwp) THEN + WRITE (numout,*) + WRITE (numout,*) + WRITE (numout,9500) kt + WRITE (numout,9501) umo(jpdyn_hpg) / tvolu, vmo(jpdyn_hpg) / tvolv + WRITE (numout,9502) umo(jpdyn_keg) / tvolu, vmo(jpdyn_keg) / tvolv + WRITE (numout,9503) umo(jpdyn_rvo) / tvolu, vmo(jpdyn_rvo) / tvolv + WRITE (numout,9504) umo(jpdyn_pvo) / tvolu, vmo(jpdyn_pvo) / tvolv + WRITE (numout,9505) umo(jpdyn_zad) / tvolu, vmo(jpdyn_zad) / tvolv + WRITE (numout,9506) umo(jpdyn_ldf) / tvolu, vmo(jpdyn_ldf) / tvolv + WRITE (numout,9507) umo(jpdyn_zdf) / tvolu, vmo(jpdyn_zdf) / tvolv + WRITE (numout,9508) umo(jpdyn_spg) / tvolu, vmo(jpdyn_spg) / tvolv + WRITE (numout,9509) umo(jpdyn_bfr) / tvolu, vmo(jpdyn_bfr) / tvolv + WRITE (numout,9510) umo(jpdyn_atf) / tvolu, vmo(jpdyn_atf) / tvolv + WRITE (numout,9511) + WRITE (numout,9512) & + & ( umo(jpdyn_hpg) + umo(jpdyn_keg) + umo(jpdyn_rvo) + umo(jpdyn_pvo) & + & + umo(jpdyn_zad) + umo(jpdyn_ldf) + umo(jpdyn_zdf) + umo(jpdyn_spg) & + & + umo(jpdyn_bfr) + umo(jpdyn_atf) ) / tvolu, & + & ( vmo(jpdyn_hpg) + vmo(jpdyn_keg) + vmo(jpdyn_rvo) + vmo(jpdyn_pvo) & + & + vmo(jpdyn_zad) + vmo(jpdyn_ldf) + vmo(jpdyn_zdf) + vmo(jpdyn_spg) & + & + vmo(jpdyn_bfr) + vmo(jpdyn_atf) ) / tvolv + WRITE (numout,9513) umo(jpdyn_tau) / tvolu, vmo(jpdyn_tau) / tvolv +!!gm IF( ln_drgimp ) WRITE (numout,9514) umo(jpdyn_bfri) / tvolu, vmo(jpdyn_bfri) / tvolv + ENDIF + + 9500 FORMAT(' momentum trend at it= ', i6, ' :', /' ==============================') + 9501 FORMAT(' hydro pressure gradient u= ', e20.13, ' v= ', e20.13) + 9502 FORMAT(' ke gradient u= ', e20.13, ' v= ', e20.13) + 9503 FORMAT(' relative vorticity term u= ', e20.13, ' v= ', e20.13) + 9504 FORMAT(' planetary vorticity term u= ', e20.13, ' v= ', e20.13) + 9505 FORMAT(' vertical advection u= ', e20.13, ' v= ', e20.13) + 9506 FORMAT(' horizontal diffusion u= ', e20.13, ' v= ', e20.13) + 9507 FORMAT(' vertical diffusion u= ', e20.13, ' v= ', e20.13) + 9508 FORMAT(' surface pressure gradient u= ', e20.13, ' v= ', e20.13) + 9509 FORMAT(' explicit bottom friction u= ', e20.13, ' v= ', e20.13) + 9510 FORMAT(' Asselin time filter u= ', e20.13, ' v= ', e20.13) + 9511 FORMAT(' -----------------------------------------------------------------------------') + 9512 FORMAT(' total trend u= ', e20.13, ' v= ', e20.13) + 9513 FORMAT(' incl. surface wind stress u= ', e20.13, ' v= ', e20.13) + 9514 FORMAT(' bottom stress u= ', e20.13, ' v= ', e20.13) + + IF(lwp) THEN + WRITE (numout,*) + WRITE (numout,*) + WRITE (numout,9520) kt + WRITE (numout,9521) hke(jpdyn_hpg) / tvolt + WRITE (numout,9522) hke(jpdyn_keg) / tvolt + WRITE (numout,9523) hke(jpdyn_rvo) / tvolt + WRITE (numout,9524) hke(jpdyn_pvo) / tvolt + WRITE (numout,9525) hke(jpdyn_zad) / tvolt + WRITE (numout,9526) hke(jpdyn_ldf) / tvolt + WRITE (numout,9527) hke(jpdyn_zdf) / tvolt + WRITE (numout,9528) hke(jpdyn_spg) / tvolt + WRITE (numout,9529) hke(jpdyn_bfr) / tvolt + WRITE (numout,9530) hke(jpdyn_atf) / tvolt + WRITE (numout,9531) + WRITE (numout,9532) & + & ( hke(jpdyn_hpg) + hke(jpdyn_keg) + hke(jpdyn_rvo) + hke(jpdyn_pvo) & + & + hke(jpdyn_zad) + hke(jpdyn_ldf) + hke(jpdyn_zdf) + hke(jpdyn_spg) & + & + hke(jpdyn_bfr) + hke(jpdyn_atf) ) / tvolt + WRITE (numout,9533) hke(jpdyn_tau) / tvolt +!!gm IF( ln_drgimp ) WRITE (numout,9534) hke(jpdyn_bfri) / tvolt + ENDIF + + 9520 FORMAT(' kinetic energy trend at it= ', i6, ' :', /' ====================================') + 9521 FORMAT(' hydro pressure gradient u2= ', e20.13) + 9522 FORMAT(' ke gradient u2= ', e20.13) + 9523 FORMAT(' relative vorticity term u2= ', e20.13) + 9524 FORMAT(' planetary vorticity term u2= ', e20.13) + 9525 FORMAT(' vertical advection u2= ', e20.13) + 9526 FORMAT(' horizontal diffusion u2= ', e20.13) + 9527 FORMAT(' vertical diffusion u2= ', e20.13) + 9528 FORMAT(' surface pressure gradient u2= ', e20.13) + 9529 FORMAT(' explicit bottom friction u2= ', e20.13) + 9530 FORMAT(' Asselin time filter u2= ', e20.13) + 9531 FORMAT(' --------------------------------------------------') + 9532 FORMAT(' total trend u2= ', e20.13) + 9533 FORMAT(' incl. surface wind stress u2= ', e20.13) + 9534 FORMAT(' bottom stress u2= ', e20.13) + + IF(lwp) THEN + WRITE (numout,*) + WRITE (numout,*) + WRITE (numout,9540) kt + WRITE (numout,9541) ( hke(jpdyn_keg) + hke(jpdyn_rvo) + hke(jpdyn_zad) ) / tvolt + WRITE (numout,9542) ( hke(jpdyn_keg) + hke(jpdyn_zad) ) / tvolt + WRITE (numout,9543) ( hke(jpdyn_pvo) ) / tvolt + WRITE (numout,9544) ( hke(jpdyn_rvo) ) / tvolt + WRITE (numout,9545) ( hke(jpdyn_spg) ) / tvolt + WRITE (numout,9546) ( hke(jpdyn_ldf) ) / tvolt + WRITE (numout,9547) ( hke(jpdyn_zdf) ) / tvolt + WRITE (numout,9548) ( hke(jpdyn_hpg) ) / tvolt, rpktrd / tvolt + WRITE (numout,*) + WRITE (numout,*) + ENDIF + + 9540 FORMAT(' energetic consistency at it= ', i6, ' :', /' =========================================') + 9541 FORMAT(' 0 = non linear term (true if KE conserved) : ', e20.13) + 9542 FORMAT(' 0 = ke gradient + vertical advection : ', e20.13) + 9543 FORMAT(' 0 = coriolis term (true if KE conserving scheme) : ', e20.13) + 9544 FORMAT(' 0 = vorticity term (true if KE conserving scheme) : ', e20.13) + 9545 FORMAT(' 0 = surface pressure gradient ??? : ', e20.13) + 9546 FORMAT(' 0 < horizontal diffusion : ', e20.13) + 9547 FORMAT(' 0 < vertical diffusion : ', e20.13) + 9548 FORMAT(' pressure gradient u2 = - 1/rho0 u.dz(rhop) : ', e20.13, ' u.dz(rhop) =', e20.13) + ! + ! Save potential to kinetic energy conversion for next time step + rpktrd = peke + ! + ENDIF + ! + END SUBROUTINE glo_dyn_wri + + + SUBROUTINE glo_tra_wri( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE glo_tra_wri *** + !! + !! ** Purpose : write global domain averaged of T and T^2 trends in ocean.output + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: jk ! loop indices + !!---------------------------------------------------------------------- + + ! I. Tracers trends + ! ----------------- + + IF( MOD(kt,nn_trd) == 0 .OR. kt == nit000 .OR. kt == nitend ) THEN + + ! I.1 Sums over the global domain + ! ------------------------------- + IF( lk_mpp ) THEN + CALL mpp_sum( 'trdglo', tmo, jptot_tra ) + CALL mpp_sum( 'trdglo', smo, jptot_tra ) + CALL mpp_sum( 'trdglo', t2 , jptot_tra ) + CALL mpp_sum( 'trdglo', s2 , jptot_tra ) + ENDIF + + ! I.2 Print tracers trends in the ocean.output file + ! -------------------------------------------------- + + IF(lwp) THEN + WRITE (numout,*) + WRITE (numout,*) + WRITE (numout,9400) kt + WRITE (numout,9401) tmo(jptra_xad) / tvolt, smo(jptra_xad) / tvolt + WRITE (numout,9411) tmo(jptra_yad) / tvolt, smo(jptra_yad) / tvolt + WRITE (numout,9402) tmo(jptra_zad) / tvolt, smo(jptra_zad) / tvolt + WRITE (numout,9403) tmo(jptra_ldf) / tvolt, smo(jptra_ldf) / tvolt + WRITE (numout,9404) tmo(jptra_zdf) / tvolt, smo(jptra_zdf) / tvolt + WRITE (numout,9405) tmo(jptra_npc) / tvolt, smo(jptra_npc) / tvolt + WRITE (numout,9406) tmo(jptra_dmp) / tvolt, smo(jptra_dmp) / tvolt + WRITE (numout,9407) tmo(jptra_qsr) / tvolt + WRITE (numout,9408) tmo(jptra_nsr) / tvolt, smo(jptra_nsr) / tvolt + WRITE (numout,9409) + WRITE (numout,9410) ( tmo(jptra_xad) + tmo(jptra_yad) + tmo(jptra_zad) + tmo(jptra_ldf) + tmo(jptra_zdf) & + & + tmo(jptra_npc) + tmo(jptra_dmp) + tmo(jptra_qsr) + tmo(jptra_nsr) ) / tvolt, & + & ( smo(jptra_xad) + smo(jptra_yad) + smo(jptra_zad) + smo(jptra_ldf) + smo(jptra_zdf) & + & + smo(jptra_npc) + smo(jptra_dmp) + smo(jptra_nsr) ) / tvolt + ENDIF + +9400 FORMAT(' tracer trend at it= ',i6,' : temperature', & + ' salinity',/' ============================') +9401 FORMAT(' zonal advection ',e20.13,' ',e20.13) +9411 FORMAT(' meridional advection ',e20.13,' ',e20.13) +9402 FORMAT(' vertical advection ',e20.13,' ',e20.13) +9403 FORMAT(' horizontal diffusion ',e20.13,' ',e20.13) +9404 FORMAT(' vertical diffusion ',e20.13,' ',e20.13) +9405 FORMAT(' static instability mixing ',e20.13,' ',e20.13) +9406 FORMAT(' damping term ',e20.13,' ',e20.13) +9407 FORMAT(' penetrative qsr ',e20.13) +9408 FORMAT(' non solar radiation ',e20.13,' ',e20.13) +9409 FORMAT(' -------------------------------------------------------------------------') +9410 FORMAT(' total trend ',e20.13,' ',e20.13) + + + IF(lwp) THEN + WRITE (numout,*) + WRITE (numout,*) + WRITE (numout,9420) kt + WRITE (numout,9421) t2(jptra_xad) / tvolt, s2(jptra_xad) / tvolt + WRITE (numout,9431) t2(jptra_yad) / tvolt, s2(jptra_yad) / tvolt + WRITE (numout,9422) t2(jptra_zad) / tvolt, s2(jptra_zad) / tvolt + WRITE (numout,9423) t2(jptra_ldf) / tvolt, s2(jptra_ldf) / tvolt + WRITE (numout,9424) t2(jptra_zdf) / tvolt, s2(jptra_zdf) / tvolt + WRITE (numout,9425) t2(jptra_npc) / tvolt, s2(jptra_npc) / tvolt + WRITE (numout,9426) t2(jptra_dmp) / tvolt, s2(jptra_dmp) / tvolt + WRITE (numout,9427) t2(jptra_qsr) / tvolt + WRITE (numout,9428) t2(jptra_nsr) / tvolt, s2(jptra_nsr) / tvolt + WRITE (numout,9429) + WRITE (numout,9430) ( t2(jptra_xad) + t2(jptra_yad) + t2(jptra_zad) + t2(jptra_ldf) + t2(jptra_zdf) & + & + t2(jptra_npc) + t2(jptra_dmp) + t2(jptra_qsr) + t2(jptra_nsr) ) / tvolt, & + & ( s2(jptra_xad) + s2(jptra_yad) + s2(jptra_zad) + s2(jptra_ldf) + s2(jptra_zdf) & + & + s2(jptra_npc) + s2(jptra_dmp) + s2(jptra_nsr) ) / tvolt + ENDIF + +9420 FORMAT(' tracer**2 trend at it= ', i6, ' : temperature', & + ' salinity', /, ' ===============================') +9421 FORMAT(' zonal advection * t ', e20.13, ' ', e20.13) +9431 FORMAT(' meridional advection * t ', e20.13, ' ', e20.13) +9422 FORMAT(' vertical advection * t ', e20.13, ' ', e20.13) +9423 FORMAT(' horizontal diffusion * t ', e20.13, ' ', e20.13) +9424 FORMAT(' vertical diffusion * t ', e20.13, ' ', e20.13) +9425 FORMAT(' static instability mixing * t ', e20.13, ' ', e20.13) +9426 FORMAT(' damping term * t ', e20.13, ' ', e20.13) +9427 FORMAT(' penetrative qsr * t ', e20.13) +9428 FORMAT(' non solar radiation * t ', e20.13, ' ', e20.13) +9429 FORMAT(' -----------------------------------------------------------------------------') +9430 FORMAT(' total trend *t = ', e20.13, ' *s = ', e20.13) + + + IF(lwp) THEN + WRITE (numout,*) + WRITE (numout,*) + WRITE (numout,9440) kt + WRITE (numout,9441) ( tmo(jptra_xad)+tmo(jptra_yad)+tmo(jptra_zad) )/tvolt, & + & ( smo(jptra_xad)+smo(jptra_yad)+smo(jptra_zad) )/tvolt + WRITE (numout,9442) tmo(jptra_sad)/tvolt, smo(jptra_sad)/tvolt + WRITE (numout,9443) tmo(jptra_ldf)/tvolt, smo(jptra_ldf)/tvolt + WRITE (numout,9444) tmo(jptra_zdf)/tvolt, smo(jptra_zdf)/tvolt + WRITE (numout,9445) tmo(jptra_npc)/tvolt, smo(jptra_npc)/tvolt + WRITE (numout,9446) ( t2(jptra_xad)+t2(jptra_yad)+t2(jptra_zad) )/tvolt, & + & ( s2(jptra_xad)+s2(jptra_yad)+s2(jptra_zad) )/tvolt + WRITE (numout,9447) t2(jptra_ldf)/tvolt, s2(jptra_ldf)/tvolt + WRITE (numout,9448) t2(jptra_zdf)/tvolt, s2(jptra_zdf)/tvolt + WRITE (numout,9449) t2(jptra_npc)/tvolt, s2(jptra_npc)/tvolt + ENDIF + +9440 FORMAT(' tracer consistency at it= ',i6, & + ' : temperature',' salinity',/, & + ' ==================================') +9441 FORMAT(' 0 = horizontal+vertical advection + ',e20.13,' ',e20.13) +9442 FORMAT(' 1st lev vertical advection ',e20.13,' ',e20.13) +9443 FORMAT(' 0 = horizontal diffusion ',e20.13,' ',e20.13) +9444 FORMAT(' 0 = vertical diffusion ',e20.13,' ',e20.13) +9445 FORMAT(' 0 = static instability mixing ',e20.13,' ',e20.13) +9446 FORMAT(' 0 = horizontal+vertical advection * t ',e20.13,' ',e20.13) +9447 FORMAT(' 0 > horizontal diffusion * t ',e20.13,' ',e20.13) +9448 FORMAT(' 0 > vertical diffusion * t ',e20.13,' ',e20.13) +9449 FORMAT(' 0 > static instability mixing * t ',e20.13,' ',e20.13) + ! + ENDIF + ! + END SUBROUTINE glo_tra_wri + + + SUBROUTINE trd_glo_init( Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_glo_init *** + !! + !! ** Purpose : Read the namtrd namelist + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! time level index + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'trd_glo_init : integral constraints properties trends' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + + ! Total volume at t-points: + tvolt = 0._wp + DO jk = 1, jpkm1 + tvolt = tvolt + SUM( e1e2t(:,:) * e3t(:,:,jk,Kmm) * tmask(:,:,jk) * tmask_i(:,:) ) + END DO + CALL mpp_sum( 'trdglo', tvolt ) ! sum over the global domain + + IF(lwp) WRITE(numout,*) ' total ocean volume at T-point tvolt = ',tvolt + + ! Initialization of potential to kinetic energy conversion + rpktrd = 0._wp + + ! Total volume at u-, v- points: +!!gm : bug? je suis quasi sur que le produit des tmask_i ne correspond pas exactement au umask_i et vmask_i ! + tvolu = 0._wp + tvolv = 0._wp + + DO_3D( 0, 0, 0, 0, 1, jpk ) + tvolu = tvolu + e1u(ji,jj) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) & + & * tmask_i(ji+1,jj ) * tmask_i(ji,jj) * umask(ji,jj,jk) + tvolv = tvolv + e1v(ji,jj) * e2v(ji,jj) * e3v(ji,jj,jk,Kmm) & + & * tmask_i(ji ,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) + END_3D + CALL mpp_sum( 'trdglo', tvolu ) ! sums over the global domain + CALL mpp_sum( 'trdglo', tvolv ) + + IF(lwp) THEN + WRITE(numout,*) ' total ocean volume at U-point tvolu = ',tvolu + WRITE(numout,*) ' total ocean volume at V-point tvolv = ',tvolv + ENDIF + ! + END SUBROUTINE trd_glo_init + + !!====================================================================== +END MODULE trdglo \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdini.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdini.F90 new file mode 100644 index 0000000..385f2b9 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdini.F90 @@ -0,0 +1,111 @@ +MODULE trdini + !!====================================================================== + !! *** MODULE trdini *** + !! Ocean diagnostics: ocean tracers and dynamic trends + !!===================================================================== + !! History : 3.5 ! 2012-02 (G. Madec) add 3D trends output for T, S, U, V, PE and KE + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_init : initialization step + !!---------------------------------------------------------------------- + USE dom_oce ! ocean domain + USE domtile + USE trd_oce ! trends: ocean variables + USE trdken ! trends: 3D kinetic energy + USE trdpen ! trends: 3D potential energy + USE trdglo ! trends: global domain averaged tracers and dynamics + USE trdmxl ! trends: mixed layer averaged trends (tracer only) + USE trdvor ! trends: vertical averaged vorticity + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_init ! called by nemogcm.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdini.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_init( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_init *** + !! + !! ** Purpose : Initialization of trend diagnostics + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! time level index + INTEGER :: ios ! local integer + !! + NAMELIST/namtrd/ ln_dyn_trd, ln_KE_trd, ln_vor_trd, ln_dyn_mxl, & + & ln_tra_trd, ln_PE_trd, ln_glo_trd, ln_tra_mxl, nn_trd + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namtrd, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrd in reference namelist' ) + ! + READ ( numnam_cfg, namtrd, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrd in configuration namelist' ) + IF(lwm) WRITE( numond, namtrd ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'trd_init : Momentum/Tracers trends' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) ' Namelist namtrd : set trends parameters' + WRITE(numout,*) ' global domain averaged dyn & tra trends ln_glo_trd = ', ln_glo_trd + WRITE(numout,*) ' U & V trends: 3D output ln_dyn_trd = ', ln_dyn_trd + WRITE(numout,*) ' U & V trends: Mixed Layer averaged ln_dyn_mxl = ', ln_dyn_mxl + WRITE(numout,*) ' T & S trends: 3D output ln_tra_trd = ', ln_tra_trd + WRITE(numout,*) ' T & S trends: Mixed Layer averaged ln_tra_mxl = ', ln_tra_mxl + WRITE(numout,*) ' Kinetic Energy trends ln_KE_trd = ', ln_KE_trd + WRITE(numout,*) ' Potential Energy trends ln_PE_trd = ', ln_PE_trd + WRITE(numout,*) ' Barotropic vorticity trends ln_vor_trd = ', ln_vor_trd + ! + WRITE(numout,*) ' frequency of trends diagnostics (glo) nn_trd = ', nn_trd + ENDIF + ! + ! ! trend extraction flags + l_trdtra = .FALSE. ! tracers + IF ( ln_tra_trd .OR. ln_PE_trd .OR. ln_tra_mxl .OR. & + & ln_glo_trd ) l_trdtra = .TRUE. + ! + l_trddyn = .FALSE. ! momentum + IF ( ln_dyn_trd .OR. ln_KE_trd .OR. ln_dyn_mxl .OR. & + & ln_vor_trd .OR. ln_glo_trd ) l_trddyn = .TRUE. + ! + +!!gm check the stop below + IF( ln_dyn_mxl ) CALL ctl_stop( 'ML diag on momentum are not yet coded we stop' ) + ! + +!!gm end + IF( ln_tra_mxl .OR. ln_vor_trd ) CALL ctl_stop( 'ML tracer and Barotropic vorticity diags are still using old IOIPSL' ) +!!gm end + ! +! IF( .NOT.ln_linssh .AND. ( l_trdtra .OR. l_trddyn ) ) CALL ctl_stop( 'trend diagnostics with variable volume not validated' ) + + IF( ln_tile .AND. ( l_trdtra .OR. l_trddyn ) ) THEN + CALL ctl_warn('Tiling is not yet implemented for the trends diagnostics; ln_tile is forced to FALSE') + ln_tile = .FALSE. + CALL dom_tile_init + ENDIF + +!!gm : Potential BUG : 3D output only for vector invariant form! add a ctl_stop or code the flux form case +!!gm : bug/pb for vertical advection of tracer in vvl case: add T.dt[eta] in the output... + + ! ! diagnostic initialization + IF( ln_glo_trd ) CALL trd_glo_init( Kmm ) ! global domain averaged trends + IF( ln_tra_mxl ) CALL trd_mxl_init ! mixed-layer trends + IF( ln_vor_trd ) CALL trd_vor_init ! barotropic vorticity trends + IF( ln_KE_trd ) CALL trd_ken_init ! 3D Kinetic energy trends + IF( ln_PE_trd ) CALL trd_pen_init ! 3D Potential energy trends + ! + END SUBROUTINE trd_init + + !!====================================================================== +END MODULE trdini \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdken.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdken.F90 new file mode 100644 index 0000000..b23a4d6 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdken.F90 @@ -0,0 +1,249 @@ +MODULE trdken + !!====================================================================== + !! *** MODULE trdken *** + !! Ocean diagnostics: compute and output 3D kinetic energy trends + !!===================================================================== + !! History : 3.5 ! 2012-02 (G. Madec) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_ken : compute and output 3D Kinetic energy trends using IOM + !! trd_ken_init : initialisation + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE phycst ! physical constants + USE sbc_oce ! surface boundary condition: ocean + USE zdf_oce ! ocean vertical physics variables +!!gm USE zdfdrg ! ocean vertical physics: bottom friction + USE ldftra ! ocean active tracers lateral physics + USE trd_oce ! trends: ocean variables + USE trdvor ! ocean vorticity trends + USE trdglo ! trends:global domain averaged + USE trdmxl ! ocean active mixed layer tracers trends + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE ldfslp ! Isopycnal slopes + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_ken ! called by trddyn module + PUBLIC trd_ken_init ! called by trdini module + + INTEGER :: nkstp ! current time step + + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: bu, bv ! volume of u- and v-boxes + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: r1_bt ! inverse of t-box volume + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdken.F90 15104 2021-07-07 14:36:00Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trd_ken_alloc() + !!--------------------------------------------------------------------- + !! *** FUNCTION trd_ken_alloc *** + !!--------------------------------------------------------------------- + ALLOCATE( bu(jpi,jpj,jpk) , bv(jpi,jpj,jpk) , r1_bt(jpi,jpj,jpk) , STAT= trd_ken_alloc ) + ! + CALL mpp_sum ( 'trdken', trd_ken_alloc ) + IF( trd_ken_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_ken_alloc: failed to allocate arrays' ) + END FUNCTION trd_ken_alloc + + + SUBROUTINE trd_ken( putrd, pvtrd, ktrd, kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_ken *** + !! + !! ** Purpose : output 3D Kinetic Energy trends using IOM + !! + !! ** Method : - apply lbc to the input masked velocity trends + !! - compute the associated KE trend: + !! zke = 0.5 * ( mi-1[ uu(Kmm) * putrd * bu ] + mj-1[ vv(Kmm) * pvtrd * bv] ) / bt + !! where bu, bv, bt are the volume of u-, v- and t-boxes. + !! - vertical diffusion case (jpdyn_zdf): + !! diagnose separately the KE trend associated with wind stress + !! - bottom friction case (jpdyn_bfr): + !! explicit case (ln_drgimp=F): bottom trend put in the 1st level + !! of putrd, pvtrd + ! + ! + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V masked trends + INTEGER , INTENT(in ) :: ktrd ! trend index + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikbu , ikbv ! local integers + INTEGER :: ikbum1, ikbvm1 ! - - + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: z2dx, z2dy, zke2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zke ! 3D workspace + !!---------------------------------------------------------------------- + ! + CALL lbc_lnk( 'trdken', putrd, 'U', -1.0_dp , pvtrd, 'V', -1.0_dp ) ! lateral boundary conditions + ! + nkstp = kt + DO jk = 1, jpkm1 + bu (:,:,jk) = e1e2u(:,:) * e3u(:,:,jk,Kmm) + bv (:,:,jk) = e1e2v(:,:) * e3v(:,:,jk,Kmm) + r1_bt(:,:,jk) = r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) * tmask(:,:,jk) + END DO + ! + zke(:,:,jpk) = 0._wp + zke(1:nn_hls,:, : ) = 0._wp + zke(:,1:nn_hls, : ) = 0._wp + DO_3D( 0, nn_hls, 0, nn_hls, 1, jpkm1 ) + zke(ji,jj,jk) = 0.5_wp * rho0 *( uu(ji ,jj,jk,Kmm) * putrd(ji ,jj,jk) * bu(ji ,jj,jk) & + & + uu(ji-1,jj,jk,Kmm) * putrd(ji-1,jj,jk) * bu(ji-1,jj,jk) & + & + vv(ji,jj ,jk,Kmm) * pvtrd(ji,jj ,jk) * bv(ji,jj ,jk) & + & + vv(ji,jj-1,jk,Kmm) * pvtrd(ji,jj-1,jk) * bv(ji,jj-1,jk) ) * r1_bt(ji,jj,jk) + END_3D + ! + SELECT CASE( ktrd ) + CASE( jpdyn_hpg ) ; CALL iom_put( "ketrd_hpg" , zke ) ! hydrostatic pressure gradient + CASE( jpdyn_spg ) ; CALL iom_put( "ketrd_spg" , zke ) ! surface pressure gradient + CASE( jpdyn_pvo ) ; CALL iom_put( "ketrd_pvo" , zke ) ! planetary vorticity + CASE( jpdyn_rvo ) ; CALL iom_put( "ketrd_rvo" , zke ) ! relative vorticity (or metric term) + CASE( jpdyn_keg ) ; CALL iom_put( "ketrd_keg" , zke ) ! Kinetic Energy gradient (or had) + CASE( jpdyn_zad ) ; CALL iom_put( "ketrd_zad" , zke ) ! vertical advection + CASE( jpdyn_ldf ) ; CALL iom_put( "ketrd_ldf" , zke ) ! lateral diffusion + CASE( jpdyn_zdf ) ; CALL iom_put( "ketrd_zdf" , zke ) ! vertical diffusion + ! ! ! wind stress trends + ALLOCATE( z2dx(jpi,jpj) , z2dy(jpi,jpj) , zke2d(jpi,jpj) ) + z2dx(:,:) = uu(:,:,1,Kmm) * ( utau_b(:,:) + utau(:,:) ) * e1e2u(:,:) * umask(:,:,1) + z2dy(:,:) = vv(:,:,1,Kmm) * ( vtau_b(:,:) + vtau(:,:) ) * e1e2v(:,:) * vmask(:,:,1) + zke2d(1:nn_hls,:) = 0._wp ; zke2d(:,1:nn_hls) = 0._wp + DO_2D( 0, nn_hls, 0, nn_hls ) + zke2d(ji,jj) = r1_rho0 * 0.5_wp * ( z2dx(ji,jj) + z2dx(ji-1,jj) & + & + z2dy(ji,jj) + z2dy(ji,jj-1) ) * r1_bt(ji,jj,1) + END_2D + CALL iom_put( "ketrd_tau" , zke2d ) ! + DEALLOCATE( z2dx , z2dy , zke2d ) + CASE( jpdyn_bfr ) ; CALL iom_put( "ketrd_bfr" , zke ) ! bottom friction (explicit case) +!!gm TO BE DONE properly +!!gm only valid if ln_drgimp=F otherwise the bottom stress as to be recomputed at the end of the computation.... +! IF(.NOT. ln_drgimp) THEN +! DO jj = 1, jpj ! +! DO ji = 1, jpi +! ikbu = mbku(ji,jj) ! deepest ocean u- & v-levels +! ikbv = mbkv(ji,jj) +! z2dx(ji,jj) = uu(ji,jj,ikbu,Kmm) * bfrua(ji,jj) * uu(ji,jj,ikbu,Kmm) +! z2dy(ji,jj) = vv(ji,jj,ikbu,Kmm) * bfrva(ji,jj) * vv(ji,jj,ikbv,Kmm) +! END DO +! END DO +! zke2d(1,:) = 0._wp ; zke2d(:,1) = 0._wp +! DO jj = 2, jpj +! DO ji = 2, jpi +! zke2d(ji,jj) = 0.5_wp * ( z2dx(ji,jj) + z2dx(ji-1,jj) & +! & + z2dy(ji,jj) + z2dy(ji,jj-1) ) * r1_bt(ji,jj, BEURK!!! +! END DO +! END DO +! CALL iom_put( "ketrd_bfr" , zke2d ) ! bottom friction (explicit case) +! ENDIF +!!gm end + CASE( jpdyn_atf ) ; CALL iom_put( "ketrd_atf" , zke ) ! asselin filter trends +!! a faire !!!! idee changer dynnxt pour avoir un appel a jpdyn_bfr avant le swap !!! +!! reflechir a une possible sauvegarde du "vrai" uu(Kmm),vv(Kmm) pour le calcul de atf.... +! +! IF( ln_drgimp ) THEN ! bottom friction (implicit case) +! DO jj = 1, jpj ! after velocity known (now filed at this stage) +! DO ji = 1, jpi +! ikbu = mbku(ji,jj) ! deepest ocean u- & v-levels +! ikbv = mbkv(ji,jj) +! z2dx(ji,jj) = uu(ji,jj,ikbu,Kmm) * bfrua(ji,jj) * uu(ji,jj,ikbu,Kmm) / e3u(ji,jj,ikbu,Kmm) +! z2dy(ji,jj) = uu(ji,jj,ikbu,Kmm) * bfrva(ji,jj) * vv(ji,jj,ikbv,Kmm) / e3v(ji,jj,ikbv,Kmm) +! END DO +! END DO +! zke2d(1,:) = 0._wp ; zke2d(:,1) = 0._wp +! DO jj = 2, jpj +! DO ji = 2, jpi +! zke2d(ji,jj) = 0.5_wp * ( z2dx(ji,jj) + z2dx(ji-1,jj) & +! & + z2dy(ji,jj) + z2dy(ji,jj-1) ) +! END DO +! END DO +! CALL iom_put( "ketrd_bfri", zke2d ) +! ENDIF + CASE( jpdyn_ken ) ; ! kinetic energy + ! called in dynnxt.F90 before asselin time filter + ! with putrd=uu(Krhs) and pvtrd=vv(Krhs) + zke(:,:,:) = 0.5_wp * zke(:,:,:) + CALL iom_put( "KE", zke ) + ! + CALL ken_p2k( kt , zke, Kmm ) + CALL iom_put( "ketrd_convP2K", zke ) ! conversion -rau*g*w + ! + END SELECT + ! + END SUBROUTINE trd_ken + + + SUBROUTINE ken_p2k( kt , pconv, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE ken_p2k *** + !! + !! ** Purpose : compute rate of conversion from potential to kinetic energy + !! + !! ** Method : - compute conv defined as -rau*g*w on T-grid points + !! + !! ** Work only for full steps and partial steps (ln_hpg_zco or ln_hpg_zps) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pconv ! + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iku, ikv ! local integers + REAL(wp) :: zcoef ! local scalars + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zconv ! 3D workspace + !!---------------------------------------------------------------------- + ! + ! Local constant initialization + zcoef = - rho0 * grav * 0.5_wp + + ! Surface value (also valid in partial step case) + zconv(:,:,1) = zcoef * ( 2._wp * rhd(:,:,1) ) * ww(:,:,1) * e3w(:,:,1,Kmm) + + ! interior value (2=> use previous timestep ztn_mla = tb_mln + ! " " " tn_mln = tb_mlb (unfiltered tb!) + ! NB: tn_mln itself comes from the 2 time step before (ta_mla) + ! + ! atf trend : ztbf_mln - tb_mln ==>> use previous timestep tn_mla = tb_mln + ! need to compute tbf_mln, using the current tb + ! which is the before fitered tracer + ! + ! entrainement ent_2 : zta_mla - zta_mln ==>> need to compute zta_mla and zta_mln + ! + ! time averaging : mean: CALL trd_mean( kt, ptrd, ptrdm ) + ! and out put the starting mean value and the total trends + ! (i.e. difference between starting and ending values) + ! hat : CALL trd_hat ( kt, ptrd, ptrdm ) + ! and output the starting hat value and the total hat trends + ! + ! swaps : hmlb <== hmln <== zhmla + ! tb_mlb <== tn_mln <== zta_mla + ! tb_mln <== ztn_mla ==>> now T over after h, need to be computed here + ! to be used at next time step (unfiltered before) + ! + END SELECT + ! + END SUBROUTINE trd_tra_mxl + + + SUBROUTINE trd_mean( kt, ptrd, ptrdm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_mean *** + !! + !! ** Purpose : + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptrd ! trend at kt + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptrdm ! cumulative trends at kt + INTEGER , INTENT(in ) :: kt ! time step index + !!---------------------------------------------------------------------- + ! + IF ( kt == nn_it000 ) ptrdm(:,:,:) = 0._wp + ! + ptrdm(:,:,:) = ptrdm(:,:,:) + ptrd(:,:,:) + ! + IF ( MOD( kt - nn_it000 + 1, nn_trd ) == 0 ) THEN + ! + ! call iom put???? avec en argument le tableau de nom des trends? + ! + ENDIF + ! + END SUBROUTINE trd_mean + + + SUBROUTINE trd_mxl_zint( pttrdmxl, pstrdmxl, ktrd, ctype ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_mxl_zint *** + !! + !! ** Purpose : Compute the vertical average of the 3D fields given as arguments + !! to the subroutine. This vertical average is performed from ocean + !! surface down to a chosen control surface. + !! + !! ** Method/usage : + !! The control surface can be either a mixed layer depth (time varying) + !! or a fixed surface (jk level or bowl). + !! Choose control surface with nn_ctls in namelist NAMTRD : + !! nn_ctls = 0 : use mixed layer with density criterion + !! nn_ctls = 1 : read index from file 'ctlsurf_idx' + !! nn_ctls > 1 : use fixed level surface jk = nn_ctls + !! Note: in the remainder of the routine, the volume between the + !! surface and the control surface is called "mixed-layer" + !!---------------------------------------------------------------------- + INTEGER , INTENT( in ) :: ktrd ! ocean trend index + CHARACTER(len=2) , INTENT( in ) :: ctype ! 2D surface/bottom or 3D interior physics + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: pttrdmxl ! temperature trend + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: pstrdmxl ! salinity trend + ! + INTEGER :: ji, jj, jk, isum + REAL(wp), DIMENSION(jpi,jpj) :: zvlmsk + !!---------------------------------------------------------------------- + + ! I. Definition of control surface and associated fields + ! ------------------------------------------------------ + ! ==> only once per time step <== + + IF( icount == 1 ) THEN + ! + +!!gm BUG? +!!gm CAUTION: double check the definition of nmln it is the nb of w-level, not t-level I guess + + + ! ... Set nmxl(ji,jj) = index of first T point below control surf. or outside mixed-layer + IF( nn_ctls == 0 ) THEN ! * control surface = mixed-layer with density criterion + nmxl(:,:) = nmln(:,:) ! array nmln computed in zdfmxl.F90 + ELSEIF( nn_ctls == 1 ) THEN ! * control surface = read index from file + nmxl(:,:) = nbol(:,:) + ELSEIF( nn_ctls >= 2 ) THEN ! * control surface = model level + nn_ctls = MIN( nn_ctls, jpktrd - 1 ) + nmxl(:,:) = nn_ctls + 1 + ENDIF + + END IF + ! + END SUBROUTINE trd_mxl_zint + + + SUBROUTINE trd_mxl( kt, p2dt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_mxl *** + !! + !! ** Purpose : Compute and cumulate the mixed layer trends over an analysis + !! period, and write NetCDF outputs. + !! + !! ** Method/usage : + !! The stored trends can be chosen twofold (according to the ln_trdmxl_instant + !! logical namelist variable) : + !! 1) to explain the difference between initial and final + !! mixed-layer T & S (where initial and final relate to the + !! current analysis window, defined by nn_trd in the namelist) + !! 2) to explain the difference between the current and previous + !! TIME-AVERAGED mixed-layer T & S (where time-averaging is + !! performed over each analysis window). + !! + !! ** Consistency check : + !! If the control surface is fixed ( nn_ctls > 1 ), the residual term (dh/dt + !! entrainment) should be zero, at machine accuracy. Note that in the case + !! of time-averaged mixed-layer fields, this residual WILL NOT BE ZERO + !! over the first two analysis windows (except if restart). + !! N.B. For ORCA2_ICE, use e.g. nn_trd=5, rn_ucf=1., nn_ctls=8 + !! for checking residuals. + !! On a NEC-SX5 computer, this typically leads to: + !! O(1.e-20) temp. residuals (tml_res) when ln_trdmxl_instant=.false. + !! O(1.e-21) temp. residuals (tml_res) when ln_trdmxl_instant=.true. + !! + !! ** Action : + !! At each time step, mixed-layer averaged trends are stored in the + !! tmltrd(:,:,jpmxl_xxx) array (see trdmxl_oce.F90 for definitions of jpmxl_xxx). + !! This array is known when trd_mxl is called, at the end of the stp subroutine, + !! except for the purely vertical K_z diffusion term, which is embedded in the + !! lateral diffusion trend. + !! + !! In I), this K_z term is diagnosed and stored, thus its contribution is removed + !! from the lateral diffusion trend. + !! In II), the instantaneous mixed-layer T & S are computed, and misc. cumulative + !! arrays are updated. + !! In III), called only once per analysis window, we compute the total trends, + !! along with the residuals and the Asselin correction terms. + !! In IV), the appropriate trends are written in the trends NetCDF file. + !! + !! References : Vialard et al.,2001, JPO. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + REAL(wp), INTENT(in ) :: p2dt ! time step [s] + ! + INTEGER :: ji, jj, jk, jl, ik, it, itmod + LOGICAL :: lldebug = .TRUE. + REAL(wp) :: zavt, zfn, zfn2 + ! ! z(ts)mltot : dT/dt over the anlysis window (including Asselin) + ! ! z(ts)mlres : residual = dh/dt entrainment term + REAL(wp), DIMENSION(jpi,jpj ) :: ztmltot , zsmltot , ztmlres , zsmlres , ztmlatf , zsmlatf + REAL(wp), DIMENSION(jpi,jpj ) :: ztmltot2, zsmltot2, ztmlres2, zsmlres2, ztmlatf2, zsmlatf2, ztmltrdm2, zsmltrdm2 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmltrd2, zsmltrd2 ! only needed for mean diagnostics + !!---------------------------------------------------------------------- + + ! ====================================================================== + ! II. Cumulate the trends over the analysis window + ! ====================================================================== + + ztmltrd2(:,:,:) = 0.e0 ; zsmltrd2(:,:,:) = 0.e0 ! <<< reset arrays to zero + ztmltot2(:,:) = 0.e0 ; zsmltot2(:,:) = 0.e0 + ztmlres2(:,:) = 0.e0 ; zsmlres2(:,:) = 0.e0 + ztmlatf2(:,:) = 0.e0 ; zsmlatf2(:,:) = 0.e0 + + ! II.1 Set before values of vertically average T and S + ! ---------------------------------------------------- + IF( kt > nit000 ) THEN + ! ... temperature ... ... salinity ... + tmlb (:,:) = tml (:,:) ; smlb (:,:) = sml (:,:) + tmlatfn(:,:) = tmltrd(:,:,jpmxl_atf) ; smlatfn(:,:) = smltrd(:,:,jpmxl_atf) + END IF + + + ! II.3 Initialize mixed-layer "before" arrays for the 1rst analysis window + ! ------------------------------------------------------------------------ + IF( kt == 2 ) THEN ! i.e. ( .NOT. ln_rstart ).AND.( kt == nit000 + 1) + ! + ! ... temperature ... ... salinity ... + tmlbb (:,:) = tmlb (:,:) ; smlbb (:,:) = smlb (:,:) + tmlbn (:,:) = tml (:,:) ; smlbn (:,:) = sml (:,:) + tmlatfb(:,:) = tmlatfn(:,:) ; smlatfb(:,:) = smlatfn(:,:) + + tmltrd_csum_ub (:,:,:) = 0.e0 ; smltrd_csum_ub (:,:,:) = 0.e0 + tmltrd_atf_sumb(:,:) = 0.e0 ; smltrd_atf_sumb(:,:) = 0.e0 + + hmxlbn(:,:) = hmxl(:,:) + + IF( sn_cfctl%l_prtctl ) THEN + WRITE(numout,*) ' we reach kt == nit000 + 1 = ', nit000+1 + CALL prt_ctl(tab2d_1=REAL(tmlbb ,dp) , clinfo1=' tmlbb - : ', mask1=tmask) + CALL prt_ctl(tab2d_1=REAL(tmlbn ,dp) , clinfo1=' tmlbn - : ', mask1=tmask) + CALL prt_ctl(tab2d_1=REAL(tmlatfb ,dp), clinfo1=' tmlatfb - : ', mask1=tmask) + END IF + ! + END IF + + IF( ( ln_rstart ) .AND. ( kt == nit000 ) .AND. sn_cfctl%l_prtctl ) THEN + IF( ln_trdmxl_instant ) THEN + WRITE(numout,*) ' restart from kt == nit000 = ', nit000 + CALL prt_ctl(tab2d_1=REAL(tmlbb ,dp) , clinfo1=' tmlbb - : ', mask1=tmask) + CALL prt_ctl(tab2d_1=REAL(tmlbn ,dp) , clinfo1=' tmlbn - : ', mask1=tmask) + CALL prt_ctl(tab2d_1=REAL(tmlatfb ,dp), clinfo1=' tmlatfb - : ', mask1=tmask) + ELSE + WRITE(numout,*) ' restart from kt == nit000 = ', nit000 + CALL prt_ctl(tab2d_1=REAL(tmlbn ,dp) , clinfo1=' tmlbn - : ', mask1=tmask) + CALL prt_ctl(tab2d_1=REAL(hmxlbn ,dp) , clinfo1=' hmxlbn - : ', mask1=tmask) + CALL prt_ctl(tab2d_1=REAL(tml_sumb ,dp) , clinfo1=' tml_sumb - : ', mask1=tmask) + CALL prt_ctl(tab2d_1=REAL(tmltrd_atf_sumb,dp), clinfo1=' tmltrd_atf_sumb - : ', mask1=tmask) + CALL prt_ctl(tab3d_1=REAL(tmltrd_csum_ub,dp) , clinfo1=' tmltrd_csum_ub - : ', mask1=tmask, kdim=1) + END IF + END IF + + ! II.4 Cumulated trends over the analysis period + ! ---------------------------------------------- + ! + ! [ 1rst analysis window ] [ 2nd analysis window ] + ! + ! o---[--o-----o-----o-----o--]-[--o-----o-----o-----o-----o--]---o-----o--> time steps + ! nn_trd 2*nn_trd etc. + ! 1 2 3 4 =5 e.g. =10 + ! + IF( ( kt >= 2 ).OR.( ln_rstart ) ) THEN + ! + nmoymltrd = nmoymltrd + 1 + + ! ... Cumulate over BOTH physical contributions AND over time steps + DO jl = 1, jpltrd + tmltrdm(:,:) = tmltrdm(:,:) + tmltrd(:,:,jl) + smltrdm(:,:) = smltrdm(:,:) + smltrd(:,:,jl) + END DO + + ! ... Special handling of the Asselin trend + tmlatfm(:,:) = tmlatfm(:,:) + tmlatfn(:,:) + smlatfm(:,:) = smlatfm(:,:) + smlatfn(:,:) + + ! ... Trends associated with the time mean of the ML T/S + tmltrd_sum (:,:,:) = tmltrd_sum (:,:,:) + tmltrd (:,:,:) ! tem + tmltrd_csum_ln(:,:,:) = tmltrd_csum_ln(:,:,:) + tmltrd_sum(:,:,:) + tml_sum (:,:) = tml_sum (:,:) + tml (:,:) + smltrd_sum (:,:,:) = smltrd_sum (:,:,:) + smltrd (:,:,:) ! sal + smltrd_csum_ln(:,:,:) = smltrd_csum_ln(:,:,:) + smltrd_sum(:,:,:) + sml_sum (:,:) = sml_sum (:,:) + sml (:,:) + hmxl_sum (:,:) = hmxl_sum (:,:) + hmxl (:,:) ! rmxl + ! + END IF + + ! ====================================================================== + ! III. Prepare fields for output (get here ONCE PER ANALYSIS PERIOD) + ! ====================================================================== + + ! Convert to appropriate physical units + ! N.B. It may be useful to check IOIPSL time averaging with : + ! tmltrd (:,:,:) = 1. ; smltrd (:,:,:) = 1. + tmltrd(:,:,:) = tmltrd(:,:,:) * rn_ucf ! (actually needed for 1:jpltrd-1, but trdmxl(:,:,jpltrd) + smltrd(:,:,:) = smltrd(:,:,:) * rn_ucf ! is no longer used, and is reset to 0. at next time step) + + ! define time axis + it = kt + itmod = kt - nit000 + 1 + + MODULO_NTRD : IF( MOD( itmod, nn_trd ) == 0 ) THEN ! nitend MUST be multiple of nn_trd + ! + ztmltot (:,:) = 0.e0 ; zsmltot (:,:) = 0.e0 ! reset arrays to zero + ztmlres (:,:) = 0.e0 ; zsmlres (:,:) = 0.e0 + ztmltot2(:,:) = 0.e0 ; zsmltot2(:,:) = 0.e0 + ztmlres2(:,:) = 0.e0 ; zsmlres2(:,:) = 0.e0 + + zfn = REAL( nmoymltrd, wp ) ; zfn2 = zfn * zfn + + ! III.1 Prepare fields for output ("instantaneous" diagnostics) + ! ------------------------------------------------------------- + + !-- Compute total trends + ztmltot(:,:) = ( tml(:,:) - tmlbn(:,:) + tmlb(:,:) - tmlbb(:,:) ) / p2dt + zsmltot(:,:) = ( sml(:,:) - smlbn(:,:) + smlb(:,:) - smlbb(:,:) ) / p2dt + + !-- Compute residuals + ztmlres(:,:) = ztmltot(:,:) - ( tmltrdm(:,:) - tmlatfn(:,:) + tmlatfb(:,:) ) + zsmlres(:,:) = zsmltot(:,:) - ( smltrdm(:,:) - smlatfn(:,:) + smlatfb(:,:) ) + + !-- Diagnose Asselin trend over the analysis window + ztmlatf(:,:) = tmlatfm(:,:) - tmlatfn(:,:) + tmlatfb(:,:) + zsmlatf(:,:) = smlatfm(:,:) - smlatfn(:,:) + smlatfb(:,:) + + !-- Lateral boundary conditions + ! ... temperature ... ... salinity ... + CALL lbc_lnk( 'trdmxl', ztmltot , 'T', 1.0_wp, zsmltot , 'T', 1.0_wp, & + & ztmlres , 'T', 1.0_wp, zsmlres , 'T', 1.0_wp, & + & ztmlatf , 'T', 1.0_wp, zsmlatf , 'T', 1.0_wp ) + + + ! III.2 Prepare fields for output ("mean" diagnostics) + ! ---------------------------------------------------- + + !-- Update the ML depth time sum (to build the Leap-Frog time mean) + hmxl_sum(:,:) = hmxlbn(:,:) + 2 * ( hmxl_sum(:,:) - hmxl(:,:) ) + hmxl(:,:) + + !-- Compute temperature total trends + tml_sum (:,:) = tmlbn(:,:) + 2 * ( tml_sum(:,:) - tml(:,:) ) + tml(:,:) + ztmltot2(:,:) = ( tml_sum(:,:) - tml_sumb(:,:) ) / p2dt ! now in degC/s + + !-- Compute salinity total trends + sml_sum (:,:) = smlbn(:,:) + 2 * ( sml_sum(:,:) - sml(:,:) ) + sml(:,:) + zsmltot2(:,:) = ( sml_sum(:,:) - sml_sumb(:,:) ) / p2dt ! now in psu/s + + !-- Compute temperature residuals + DO jl = 1, jpltrd + ztmltrd2(:,:,jl) = tmltrd_csum_ub(:,:,jl) + tmltrd_csum_ln(:,:,jl) + END DO + + ztmltrdm2(:,:) = 0.e0 + DO jl = 1, jpltrd + ztmltrdm2(:,:) = ztmltrdm2(:,:) + ztmltrd2(:,:,jl) + END DO + + ztmlres2(:,:) = ztmltot2(:,:) - & + ( ztmltrdm2(:,:) - tmltrd_sum(:,:,jpmxl_atf) + tmltrd_atf_sumb(:,:) ) + + !-- Compute salinity residuals + DO jl = 1, jpltrd + zsmltrd2(:,:,jl) = smltrd_csum_ub(:,:,jl) + smltrd_csum_ln(:,:,jl) + END DO + + zsmltrdm2(:,:) = 0. + DO jl = 1, jpltrd + zsmltrdm2(:,:) = zsmltrdm2(:,:) + zsmltrd2(:,:,jl) + END DO + + zsmlres2(:,:) = zsmltot2(:,:) - & + ( zsmltrdm2(:,:) - smltrd_sum(:,:,jpmxl_atf) + smltrd_atf_sumb(:,:) ) + + !-- Diagnose Asselin trend over the analysis window + ztmlatf2(:,:) = ztmltrd2(:,:,jpmxl_atf) - tmltrd_sum(:,:,jpmxl_atf) + tmltrd_atf_sumb(:,:) + zsmlatf2(:,:) = zsmltrd2(:,:,jpmxl_atf) - smltrd_sum(:,:,jpmxl_atf) + smltrd_atf_sumb(:,:) + + !-- Lateral boundary conditions + ! ... temperature ... ... salinity ... + CALL lbc_lnk( 'trdmxl', ztmltot2, 'T', 1.0_wp, zsmltot2, 'T', 1.0_wp, & + & ztmlres2, 'T', 1.0_wp, zsmlres2, 'T', 1.0_wp ) + ! + CALL lbc_lnk( 'trdmxl', ztmltrd2(:,:,:), 'T', 1.0_wp, zsmltrd2(:,:,:), 'T', 1.0_wp ) ! / in the NetCDF trends file + + ! III.3 Time evolution array swap + ! ------------------------------- + + ! For T/S instantaneous diagnostics + ! ... temperature ... ... salinity ... + tmlbb (:,:) = tmlb (:,:) ; smlbb (:,:) = smlb (:,:) + tmlbn (:,:) = tml (:,:) ; smlbn (:,:) = sml (:,:) + tmlatfb(:,:) = tmlatfn(:,:) ; smlatfb(:,:) = smlatfn(:,:) + + ! For T mean diagnostics + tmltrd_csum_ub (:,:,:) = zfn * tmltrd_sum(:,:,:) - tmltrd_csum_ln(:,:,:) + tml_sumb (:,:) = tml_sum(:,:) + tmltrd_atf_sumb(:,:) = tmltrd_sum(:,:,jpmxl_atf) + + ! For S mean diagnostics + smltrd_csum_ub (:,:,:) = zfn * smltrd_sum(:,:,:) - smltrd_csum_ln(:,:,:) + sml_sumb (:,:) = sml_sum(:,:) + smltrd_atf_sumb(:,:) = smltrd_sum(:,:,jpmxl_atf) + + ! ML depth + hmxlbn (:,:) = hmxl (:,:) + + IF( sn_cfctl%l_prtctl ) THEN + IF( ln_trdmxl_instant ) THEN + CALL prt_ctl(tab2d_1=REAL(tmlbb,dp) , clinfo1=' tmlbb - : ', mask1=tmask) + CALL prt_ctl(tab2d_1=REAL(tmlbn ,dp) , clinfo1=' tmlbn - : ', mask1=tmask) + CALL prt_ctl(tab2d_1=REAL(tmlatfb,dp) , clinfo1=' tmlatfb - : ', mask1=tmask) + ELSE + CALL prt_ctl(tab2d_1=REAL(tmlbn ,dp) , clinfo1=' tmlbn - : ', mask1=tmask) + CALL prt_ctl(tab2d_1=REAL(hmxlbn ,dp) , clinfo1=' hmxlbn - : ', mask1=tmask) + CALL prt_ctl(tab2d_1=REAL(tml_sumb ,dp) , clinfo1=' tml_sumb - : ', mask1=tmask) + CALL prt_ctl(tab2d_1=REAL(tmltrd_atf_sumb,dp), clinfo1=' tmltrd_atf_sumb - : ', mask1=tmask) + CALL prt_ctl(tab3d_1=REAL(tmltrd_csum_ub ,dp), clinfo1=' tmltrd_csum_ub - : ', mask1=tmask, kdim=1) + END IF + END IF + + ! III.4 Convert to appropriate physical units + ! ------------------------------------------- + + ! ... temperature ... ... salinity ... + ztmltot (:,:) = ztmltot(:,:) * rn_ucf/zfn ; zsmltot (:,:) = zsmltot(:,:) * rn_ucf/zfn + ztmlres (:,:) = ztmlres(:,:) * rn_ucf/zfn ; zsmlres (:,:) = zsmlres(:,:) * rn_ucf/zfn + ztmlatf (:,:) = ztmlatf(:,:) * rn_ucf/zfn ; zsmlatf (:,:) = zsmlatf(:,:) * rn_ucf/zfn + + tml_sum (:,:) = tml_sum (:,:) / (2*zfn) ; sml_sum (:,:) = sml_sum (:,:) / (2*zfn) + ztmltot2(:,:) = ztmltot2(:,:) * rn_ucf/zfn2 ; zsmltot2(:,:) = zsmltot2(:,:) * rn_ucf/zfn2 + ztmltrd2(:,:,:) = ztmltrd2(:,:,:)* rn_ucf/zfn2 ; zsmltrd2(:,:,:) = zsmltrd2(:,:,:)* rn_ucf/zfn2 + ztmlatf2(:,:) = ztmlatf2(:,:) * rn_ucf/zfn2 ; zsmlatf2(:,:) = zsmlatf2(:,:) * rn_ucf/zfn2 + ztmlres2(:,:) = ztmlres2(:,:) * rn_ucf/zfn2 ; zsmlres2(:,:) = zsmlres2(:,:) * rn_ucf/zfn2 + + hmxl_sum(:,:) = hmxl_sum(:,:) / (2*zfn) ! similar to tml_sum and sml_sum + + ! * Debugging information * + IF( lldebug ) THEN + ! + WRITE(numout,*) + WRITE(numout,*) 'trd_mxl : write trends in the Mixed Layer for debugging process:' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' TRA kt = ', kt, 'nmoymltrd = ', nmoymltrd + WRITE(numout,*) + WRITE(numout,*) ' >>>>>>>>>>>>>>>>>> TRA TEMPERATURE <<<<<<<<<<<<<<<<<<' + WRITE(numout,*) ' TRA ztmlres : ', SUM(ztmlres(:,:)) + WRITE(numout,*) ' TRA ztmltot : ', SUM(ztmltot(:,:)) + WRITE(numout,*) ' TRA tmltrdm : ', SUM(tmltrdm(:,:)) + WRITE(numout,*) ' TRA tmlatfb : ', SUM(tmlatfb(:,:)) + WRITE(numout,*) ' TRA tmlatfn : ', SUM(tmlatfn(:,:)) + DO jl = 1, jpltrd + WRITE(numout,*) ' * TRA TREND INDEX jpmxl_xxx = jl = ', jl, & + & ' tmltrd : ', SUM(tmltrd(:,:,jl)) + END DO + WRITE(numout,*) ' TRA ztmlres (jpi/2,jpj/2) : ', ztmlres (jpi/2,jpj/2) + WRITE(numout,*) ' TRA ztmlres2(jpi/2,jpj/2) : ', ztmlres2(jpi/2,jpj/2) + WRITE(numout,*) + WRITE(numout,*) ' >>>>>>>>>>>>>>>>>> TRA SALINITY <<<<<<<<<<<<<<<<<<' + WRITE(numout,*) ' TRA zsmlres : ', SUM(zsmlres(:,:)) + WRITE(numout,*) ' TRA zsmltot : ', SUM(zsmltot(:,:)) + WRITE(numout,*) ' TRA smltrdm : ', SUM(smltrdm(:,:)) + WRITE(numout,*) ' TRA smlatfb : ', SUM(smlatfb(:,:)) + WRITE(numout,*) ' TRA smlatfn : ', SUM(smlatfn(:,:)) + DO jl = 1, jpltrd + WRITE(numout,*) ' * TRA TREND INDEX jpmxl_xxx = jl = ', jl, & + & ' smltrd : ', SUM(smltrd(:,:,jl)) + END DO + WRITE(numout,*) ' TRA zsmlres (jpi/2,jpj/2) : ', zsmlres (jpi/2,jpj/2) + WRITE(numout,*) ' TRA zsmlres2(jpi/2,jpj/2) : ', zsmlres2(jpi/2,jpj/2) + ! + END IF + ! + END IF MODULO_NTRD + + ! ====================================================================== + ! IV. Write trends in the NetCDF file + ! ====================================================================== + + !-- Write the trends for T/S instantaneous diagnostics + + IF( ln_trdmxl_instant ) THEN + + CALL iom_put( "mxl_depth", hmxl(:,:) ) + + !................................. ( ML temperature ) ................................... + + !-- Output the fields + CALL iom_put( "tml" , tml (:,:) ) + CALL iom_put( "tml_tot" , ztmltot(:,:) ) + CALL iom_put( "tml_res" , ztmlres(:,:) ) + + DO jl = 1, jpltrd - 1 + CALL iom_put( trim("tml"//ctrd(jl,2)), tmltrd (:,:,jl) ) + END DO + + CALL iom_put( trim("tml"//ctrd(jpmxl_atf,2)), ztmlatf(:,:) ) + + !.................................. ( ML salinity ) ..................................... + + !-- Output the fields + CALL iom_put( "sml" , sml (:,:) ) + CALL iom_put( "sml_tot", zsmltot(:,:) ) + CALL iom_put( "sml_res", zsmlres(:,:) ) + + DO jl = 1, jpltrd - 1 + CALL iom_put( trim("sml"//ctrd(jl,2)), smltrd(:,:,jl) ) + END DO + + CALL iom_put( trim("sml"//ctrd(jpmxl_atf,2)), zsmlatf(:,:) ) + + + + ELSE !-- Write the trends for T/S mean diagnostics + + CALL iom_put( "mxl_depth", hmxl_sum(:,:) ) + + !................................. ( ML temperature ) ................................... + + !-- Output the fields + CALL iom_put( "tml" , tml_sum (:,:) ) + CALL iom_put( "tml_tot" , ztmltot2(:,:) ) + CALL iom_put( "tml_res" , ztmlres2(:,:) ) + + DO jl = 1, jpltrd - 1 + CALL iom_put( trim("tml"//ctrd(jl,2)), ztmltrd2(:,:,jl) ) + END DO + + CALL iom_put( trim("tml"//ctrd(jpmxl_atf,2)), ztmlatf2(:,:) ) + + !.................................. ( ML salinity ) ..................................... + + !-- Output the fields + CALL iom_put( "sml" , sml_sum (:,:) ) + CALL iom_put( "sml_tot", zsmltot2(:,:) ) + CALL iom_put( "sml_res", zsmlres2(:,:) ) + + DO jl = 1, jpltrd - 1 + CALL iom_put( trim("sml"//ctrd(jl,2)), zsmltrd2(:,:,jl) ) + END DO + + CALL iom_put( trim("sml"//ctrd(jpmxl_atf,2)), zsmlatf2(:,:) ) + ! + END IF + ! + + IF( MOD( itmod, nn_trd ) == 0 ) THEN + ! + ! III.5 Reset cumulative arrays to zero + ! ------------------------------------- + nmoymltrd = 0 + + ! ... temperature ... ... salinity ... + tmltrdm (:,:) = 0.e0 ; smltrdm (:,:) = 0.e0 + tmlatfm (:,:) = 0.e0 ; smlatfm (:,:) = 0.e0 + tml_sum (:,:) = 0.e0 ; sml_sum (:,:) = 0.e0 + tmltrd_csum_ln (:,:,:) = 0.e0 ; smltrd_csum_ln (:,:,:) = 0.e0 + tmltrd_sum (:,:,:) = 0.e0 ; smltrd_sum (:,:,:) = 0.e0 + + hmxl_sum (:,:) = 0.e0 + ! + END IF + + ! ====================================================================== + ! V. Write restart file + ! ====================================================================== + + IF( lrst_oce ) CALL trd_mxl_rst_write( kt ) + + ! + END SUBROUTINE trd_mxl + + + SUBROUTINE trd_mxl_init + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_mxl_init *** + !! + !! ** Purpose : computation of vertically integrated T and S budgets + !! from ocean surface down to control surface (NetCDF output) + !!---------------------------------------------------------------------- + INTEGER :: jl ! dummy loop indices + INTEGER :: inum ! logical unit + INTEGER :: ios ! local integer + REAL(dp) :: zjulian, zsto, zout + CHARACTER (LEN=40) :: clop + CHARACTER (LEN=12) :: clmxl, cltu, clsu + !! + NAMELIST/namtrd_mxl/ nn_trd , cn_trdrst_in , ln_trdmxl_restart, & + & nn_ctls, cn_trdrst_out, ln_trdmxl_instant, rn_ucf, rn_rho_c + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namtrd_mxl, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrd_mxl in reference namelist' ) + + READ ( numnam_cfg, namtrd_mxl, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtrd_mxl in configuration namelist' ) + IF(lwm) WRITE( numond, namtrd_mxl ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' trd_mxl_init : Mixed-layer trends' + WRITE(numout,*) ' ~~~~~~~~~~' + WRITE(numout,*) ' Namelist namtrd : set trends parameters' + WRITE(numout,*) ' frequency of trends diagnostics (glo) nn_trd = ', nn_trd + WRITE(numout,*) ' density criteria used to defined the MLD rn_rho_c = ', rn_rho_c + WRITE(numout,*) ' control surface type (mld) nn_ctls = ', nn_ctls + WRITE(numout,*) ' restart for ML diagnostics ln_trdmxl_restart = ', ln_trdmxl_restart + WRITE(numout,*) ' instantaneous or mean ML T/S ln_trdmxl_instant = ', ln_trdmxl_instant + WRITE(numout,*) ' unit conversion factor rn_ucf = ', rn_ucf + WRITE(numout,*) ' criteria to compute the MLD rn_rho_c = ', rn_rho_c + ENDIF + + + + ! I.1 Check consistency of user defined preferences + ! ------------------------------------------------- + + IF ( rn_rho_c /= rho_c ) CALL ctl_warn( 'Unless you have good reason to do so, you should use the value ', & + & 'defined in zdfmxl.F90 module to calculate the mixed layer depth' ) + + IF( MOD( nitend, nn_trd ) /= 0 ) THEN + WRITE(ctmp1,*) ' Your nitend parameter, nitend = ', nitend + WRITE(ctmp2,*) ' is no multiple of the trends diagnostics frequency ' + WRITE(ctmp3,*) ' you defined, nn_trd = ', nn_trd + WRITE(ctmp4,*) ' This will not allow you to restart from this simulation. ' + WRITE(ctmp5,*) ' You should reconsider this choice. ' + WRITE(ctmp6,*) + WRITE(ctmp7,*) ' N.B. the nitend parameter is also constrained to be a ' + WRITE(ctmp8,*) ' multiple of the nn_fsbc parameter ' + CALL ctl_stop( ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) + END IF + + ! ! allocate trdmxl arrays + IF( trd_mxl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trd_mxl_init : unable to allocate trdmxl arrays' ) + IF( trdmxl_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trd_mxl_init : unable to allocate trdmxl_oce arrays' ) + + + + nkstp = nit000 - 1 ! current time step indicator initialization + + + + + ! I.2 Initialize arrays to zero or read a restart file + ! ---------------------------------------------------- + + nmoymltrd = 0 + + ! ... temperature ... ... salinity ... + tml (:,:) = 0.e0 ; sml (:,:) = 0.e0 ! inst. + tmltrdm (:,:) = 0.e0 ; smltrdm (:,:) = 0.e0 + tmlatfm (:,:) = 0.e0 ; smlatfm (:,:) = 0.e0 + tml_sum (:,:) = 0.e0 ; sml_sum (:,:) = 0.e0 ! mean + tmltrd_sum (:,:,:) = 0.e0 ; smltrd_sum (:,:,:) = 0.e0 + tmltrd_csum_ln (:,:,:) = 0.e0 ; smltrd_csum_ln (:,:,:) = 0.e0 + + hmxl (:,:) = 0.e0 + hmxl_sum (:,:) = 0.e0 + + IF( ln_rstart .AND. ln_trdmxl_restart ) THEN + CALL trd_mxl_rst_read + ELSE + ! ... temperature ... ... salinity ... + tmlb (:,:) = 0.e0 ; smlb (:,:) = 0.e0 ! inst. + tmlbb (:,:) = 0.e0 ; smlbb (:,:) = 0.e0 + tmlbn (:,:) = 0.e0 ; smlbn (:,:) = 0.e0 + tml_sumb (:,:) = 0.e0 ; sml_sumb (:,:) = 0.e0 ! mean + tmltrd_csum_ub (:,:,:) = 0.e0 ; smltrd_csum_ub (:,:,:) = 0.e0 + tmltrd_atf_sumb(:,:) = 0.e0 ; smltrd_atf_sumb(:,:) = 0.e0 + END IF + + icount = 1 ; ionce = 1 ! open specifier + + ! I.3 Read control surface from file ctlsurf_idx + ! ---------------------------------------------- + + IF( nn_ctls == 1 ) THEN + CALL ctl_opn( inum, 'ctlsurf_idx', 'OLD', 'UNFORMATTED', 'SEQUENTIAL', -1, numout, lwp ) + READ ( inum, * ) nbol + CLOSE( inum ) + END IF + + ! ====================================================================== + ! II. netCDF output initialization + ! ====================================================================== + + ! clmxl = legend root for netCDF output + IF( nn_ctls == 0 ) THEN ! control surface = mixed-layer with density criterion + clmxl = 'Mixed Layer ' ! (array nmln computed in zdfmxl.F90) + ELSE IF( nn_ctls == 1 ) THEN ! control surface = read index from file + clmxl = ' Bowl ' + ELSE IF( nn_ctls >= 2 ) THEN ! control surface = model level + WRITE(clmxl,'(A10,I2,1X)') 'Levels 1 -', nn_ctls + END IF + + + + ! II.3 Define the T grid trend file (nidtrd) + ! ------------------------------------------ + !-- Define long and short names for the NetCDF output variables + ! ==> choose them according to trdmxl_oce.F90 <== + + ctrd(jpmxl_xad,1) = " Zonal advection" ; ctrd(jpmxl_xad,2) = "_xad" + ctrd(jpmxl_yad,1) = " Meridional advection" ; ctrd(jpmxl_yad,2) = "_yad" + ctrd(jpmxl_zad,1) = " Vertical advection" ; ctrd(jpmxl_zad,2) = "_zad" + ctrd(jpmxl_ldf,1) = " Lateral diffusion" ; ctrd(jpmxl_ldf,2) = "_ldf" + ctrd(jpmxl_for,1) = " Forcing" ; ctrd(jpmxl_for,2) = "_for" + ctrd(jpmxl_zdf,1) = " Vertical diff. (Kz)" ; ctrd(jpmxl_zdf,2) = "_zdf" + ctrd(jpmxl_bbc,1) = " Geothermal flux" ; ctrd(jpmxl_bbc,2) = "_bbc" + ctrd(jpmxl_bbl,1) = " Adv/diff. Bottom boundary layer" ; ctrd(jpmxl_bbl,2) = "_bbl" + ctrd(jpmxl_dmp,1) = " Tracer damping" ; ctrd(jpmxl_dmp,2) = "_dmp" + ctrd(jpmxl_npc,1) = " Non penetrative convec. adjust." ; ctrd(jpmxl_npc,2) = "_npc" + ctrd(jpmxl_atf,1) = " Asselin time filter" ; ctrd(jpmxl_atf,2) = "_atf" + + + !-- Define physical units + IF ( rn_ucf == 1. ) THEN ; cltu = "degC/s" ; clsu = "p.s.u./s" + ELSEIF ( rn_ucf == 3600.*24.) THEN ; cltu = "degC/day" ; clsu = "p.s.u./day" + ELSE ; cltu = "unknown?" ; clsu = "unknown?" + END IF + ! + END SUBROUTINE trd_mxl_init + + !!====================================================================== +END MODULE trdmxl diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdmxl_oce.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdmxl_oce.F90 new file mode 100644 index 0000000..e19659e --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdmxl_oce.F90 @@ -0,0 +1,135 @@ +MODULE trdmxl_oce + !!====================================================================== + !! *** MODULE trdmxl_oce *** + !! Ocean trends : set tracer and momentum trend variables + !!====================================================================== + !! History : 1.0 ! 2004-08 (C. Talandier) New trends organization + !! 3.5 ! 2012-02 (G. Madec) suppress the trend keys + new trdmxl formulation + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + + IMPLICIT NONE + PRIVATE + + PUBLIC trdmxl_oce_alloc ! Called in trdmxl.F90 + + ! !* mixed layer trend indices + INTEGER, PUBLIC, PARAMETER :: jpltrd = 12 !: number of mixed-layer trends arrays + INTEGER, PUBLIC :: jpktrd !: max level for mixed-layer trends diag. + ! + INTEGER, PUBLIC, PARAMETER :: jpmxl_xad = 1 !: i-componant of advection + INTEGER, PUBLIC, PARAMETER :: jpmxl_yad = 2 !: j-componant of advection + INTEGER, PUBLIC, PARAMETER :: jpmxl_zad = 3 !: k-component of advection + INTEGER, PUBLIC, PARAMETER :: jpmxl_ldf = 4 !: lateral diffusion (geopot. or iso-neutral) + INTEGER, PUBLIC, PARAMETER :: jpmxl_zdf = 5 !: vertical diffusion + INTEGER, PUBLIC, PARAMETER :: jpmxl_npc = 6 !: non penetrative convective adjustment + INTEGER, PUBLIC, PARAMETER :: jpmxl_bbc = 7 !: geothermal flux + INTEGER, PUBLIC, PARAMETER :: jpmxl_bbl = 8 !: bottom boundary layer (advective/diffusive) + INTEGER, PUBLIC, PARAMETER :: jpmxl_for = 9 !: forcing + INTEGER, PUBLIC, PARAMETER :: jpmxl_dmp = 10 !: internal restoring trend + INTEGER, PUBLIC, PARAMETER :: jpmxl_zdfp = 11 !: ! iso-neutral diffusion:"pure" vertical diffusion + INTEGER, PUBLIC, PARAMETER :: jpmxl_atf = 12 !: asselin trend (**MUST BE THE LAST ONE**) + ! !!* Namelist namtrd_mxl: trend diagnostics in the mixed layer * + INTEGER , PUBLIC :: nn_ctls = 0 !: control surface type for trends vertical integration + REAL(wp) , PUBLIC :: rn_rho_c = 0.01 !: density criteria for MLD definition + REAL(wp) , PUBLIC :: rn_ucf = 1. !: unit conversion factor (for netCDF trends outputs) + ! =1. (=86400.) for degC/s (degC/day) and psu/s (psu/day) + CHARACTER(len=32), PUBLIC :: cn_trdrst_in = "restart_mxl" !: suffix of ocean restart name (input) + CHARACTER(len=32), PUBLIC :: cn_trdrst_out = "restart_mxl" !: suffix of ocean restart name (output) + LOGICAL , PUBLIC :: ln_trdmxl_instant = .FALSE. !: flag to diagnose inst./mean ML T/S trends + LOGICAL , PUBLIC :: ln_trdmxl_restart = .FALSE. !: flag to restart mixed-layer diagnostics + + + !! Arrays used for diagnosing mixed-layer trends + !!--------------------------------------------------------------------- + CHARACTER(LEN=80) , PUBLIC :: clname, ctrd(jpltrd+1,2) + + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmxl !: mixed layer depth indexes + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nbol !: mixed-layer depth indexes when read from file + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wkx !: + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: & + hmxl , & !: mixed layer depth (m) corresponding to nmld + tml , sml , & !: \ "now" mixed layer temperature/salinity + tmlb , smlb , & !: / and associated "before" fields + tmlbb , smlbb, & !: \ idem, but valid at the 1rst time step of the + tmlbn , smlbn, & !: / current analysis window + tmltrdm, smltrdm, & !: total cumulative trends over the analysis window + tml_sum, & !: mixed layer T, summed over the current analysis period + tml_sumb, & !: idem, but from the previous analysis period + tmltrd_atf_sumb, & !: Asselin trends, summed over the previous analysis period + sml_sum, & !: + sml_sumb, & !: ( idem for salinity ) + smltrd_atf_sumb, & !: + hmxl_sum, hmxlbn !: needed to compute the leap-frog time mean of the ML depth + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: & + tmlatfb, tmlatfn , & !: "before" Asselin contribution at begining of the averaging + smlatfb, smlatfn, & !: period (i.e. last contrib. from previous such period) and + !: "now" Asselin contribution to the ML temp. & salinity trends + tmlatfm, smlatfm !: accumulator for Asselin trends (needed for storage only) + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: & + tmltrd, & !: \ physical contributions to the total trend (for T/S), + smltrd, & !: / cumulated over the current analysis window + tmltrd_sum, & !: sum of these trends over the analysis period + tmltrd_csum_ln, & !: now cumulated sum of the trends over the "lower triangle" + tmltrd_csum_ub, & !: before (prev. analysis period) cumulated sum over the upper triangle + smltrd_sum, & !: + smltrd_csum_ln, & !: ( idem for salinity ) + smltrd_csum_ub !: + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdmxl_oce.F90 10425 2018-12-19 21:54:16Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trdmxl_oce_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION trdmxl_oce_alloc *** + !!---------------------------------------------------------------------- + USE lib_mpp + INTEGER :: ierr(5) + !!---------------------------------------------------------------------- + + ! Initialise jpktrd here as can no longer do it in MODULE body since + ! jpk is now a variable. + jpktrd = jpk !: max level for mixed-layer trends diag. + + ierr(:) = 0 + + ALLOCATE( nmxl (jpi,jpj) , nbol (jpi,jpj), & + & wkx (jpi,jpj,jpk), hmxl (jpi,jpj), & + & tml (jpi,jpj) , sml (jpi,jpj), & + & tmlb (jpi,jpj) , smlb (jpi,jpj), & + & tmlbb(jpi,jpj) , smlbb(jpi,jpj), STAT = ierr(1) ) + + ALLOCATE( tmlbn(jpi,jpj) , smlbn(jpi,jpj), & + & tmltrdm(jpi,jpj), smltrdm(jpi,jpj), & + & tml_sum(jpi,jpj), tml_sumb(jpi,jpj),& + & tmltrd_atf_sumb(jpi,jpj) , STAT=ierr(2) ) + + ALLOCATE( sml_sum(jpi,jpj), sml_sumb(jpi,jpj), & + & smltrd_atf_sumb(jpi,jpj), & + & hmxl_sum(jpi,jpj), hmxlbn(jpi,jpj), & + & tmlatfb(jpi,jpj), tmlatfn(jpi,jpj), STAT = ierr(3) ) + + ALLOCATE( smlatfb(jpi,jpj), smlatfn(jpi,jpj), & + & tmlatfm(jpi,jpj), smlatfm(jpi,jpj), & + & tmltrd(jpi,jpj,jpltrd), smltrd(jpi,jpj,jpltrd), STAT=ierr(4)) + + ALLOCATE( tmltrd_sum(jpi,jpj,jpltrd),tmltrd_csum_ln(jpi,jpj,jpltrd), & + & tmltrd_csum_ub(jpi,jpj,jpltrd), smltrd_sum(jpi,jpj,jpltrd), & + & smltrd_csum_ln(jpi,jpj,jpltrd), smltrd_csum_ub(jpi,jpj,jpltrd), STAT=ierr(5) ) + ! + trdmxl_oce_alloc = MAXVAL( ierr ) + CALL mpp_sum ( 'trdmxl_oce', trdmxl_oce_alloc ) + IF( trdmxl_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trdmxl_oce_alloc: failed to allocate arrays' ) + ! + END FUNCTION trdmxl_oce_alloc + + !!====================================================================== +END MODULE trdmxl_oce \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdmxl_rst.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdmxl_rst.F90 new file mode 100644 index 0000000..89a6c5d --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdmxl_rst.F90 @@ -0,0 +1,190 @@ +MODULE trdmxl_rst + !!================================================================================= + !! *** MODULE trdmxl_rst *** + !! Ocean dynamic : Input/Output files for restart on mixed-layer diagnostics + !!================================================================================= + !! History : 1.0 ! 2005-05 (C. Deltel) Original code + !!--------------------------------------------------------------------------------- + + !!--------------------------------------------------------------------------------- + !! trd_mxl_rst_write : write mixed layer trend restart + !! trd_mxl_rst_read : read mixed layer trend restart + !!--------------------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE trd_oce ! trends: ocean variables + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE restart ! only for lrst_oce + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_mxl_rst_read ! routine called by trd_mxl_init + PUBLIC trd_mxl_rst_write ! routine called by step.F90 + + INTEGER :: nummxlw ! logical unit for mxl restart + + !!--------------------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdmxl_rst.F90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!--------------------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_mxl_rst_write( kt ) + !!-------------------------------------------------------------------------------- + !! *** SUBROUTINE trd_mxl_rst_wri *** + !! + !! ** Purpose : Write mixed-layer diagnostics restart fields. + !!-------------------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + CHARACTER (len=35) :: charout + INTEGER :: jk ! loop indice + CHARACTER(LEN=20) :: clkt ! ocean time-step deine as a character + CHARACTER(LEN=50) :: clname ! output restart file name + CHARACTER(LEN=256) :: clpath ! full path to restart file + !!-------------------------------------------------------------------------------- + + IF( .NOT. ln_rst_list .AND. nn_stock == -1 ) RETURN ! we will never do any restart + + ! to get better performances with NetCDF format: + ! we open and define the ocean restart_mxl file one time step before writing the data (-> at nitrst - 1) + ! except if we write ocean restart_mxl files every time step or if an ocean restart_mxl file was writen at nitend - 1 + IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. ( kt == nitend .AND. MOD( nitend - 1, nn_stock ) == 0 ) ) THEN + ! beware of the format used to write kt (default is i8.8, that should be large enough...) + IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst + ELSE ; WRITE(clkt, '(i8.8)') nitrst + ENDIF + ! create the file + clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_trdrst_out) + clpath = TRIM(cn_ocerst_outdir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' open ocean restart_mxl NetCDF file: '//clname + IF( kt == nitrst - 1 ) THEN ; WRITE(numout,*) ' kt = nitrst - 1 = ', kt,' date= ', ndastp + ELSE ; WRITE(numout,*) ' kt = ' , kt,' date= ', ndastp + ENDIF + ENDIF + + CALL iom_open( TRIM(clpath)//TRIM(clname), nummxlw, ldwrt = .TRUE. ) + ENDIF + + IF( kt == nitrst .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'trdmxl_rst: output for ML diags. restart, with trd_mxl_rst_write routine kt =', kt + WRITE(numout,*) '~~~~~~~~~~' + WRITE(numout,*) + ENDIF + + IF( ln_trdmxl_instant ) THEN + !-- Temperature + CALL iom_rstput( kt, nitrst, nummxlw, 'tmlbb' , tmlbb ) + CALL iom_rstput( kt, nitrst, nummxlw, 'tmlbn' , tmlbn ) + CALL iom_rstput( kt, nitrst, nummxlw, 'tmlatfb' , tmlatfb ) + + !-- Salinity + CALL iom_rstput( kt, nitrst, nummxlw, 'smlbb' , smlbb ) + CALL iom_rstput( kt, nitrst, nummxlw, 'smlbn' , smlbn ) + CALL iom_rstput( kt, nitrst, nummxlw, 'smlatfb' , smlatfb ) + ELSE + CALL iom_rstput( kt, nitrst, nummxlw, 'hmxlbn' , hmxlbn ) + + !-- Temperature + CALL iom_rstput( kt, nitrst, nummxlw, 'tmlbn' , tmlbn ) + CALL iom_rstput( kt, nitrst, nummxlw, 'tml_sumb' , tml_sumb ) + DO jk = 1, jpltrd + IF( jk < 10 ) THEN ; WRITE(charout,FMT="('tmltrd_csum_ub_', I1)") jk + ELSE ; WRITE(charout,FMT="('tmltrd_csum_ub_', I2)") jk + ENDIF + CALL iom_rstput( kt, nitrst, nummxlw, charout, tmltrd_csum_ub(:,:,jk) ) + ENDDO + CALL iom_rstput( kt, nitrst, nummxlw, 'tmltrd_atf_sumb' , tmltrd_atf_sumb ) + + !-- Salinity + CALL iom_rstput( kt, nitrst, nummxlw, 'smlbn' , smlbn ) + CALL iom_rstput( kt, nitrst, nummxlw, 'sml_sumb' , sml_sumb ) + DO jk = 1, jpltrd + IF( jk < 10 ) THEN ; WRITE(charout,FMT="('smltrd_csum_ub_', I1)") jk + ELSE ; WRITE(charout,FMT="('smltrd_csum_ub_', I2)") jk + ENDIF + CALL iom_rstput( kt, nitrst, nummxlw, charout , smltrd_csum_ub(:,:,jk) ) + ENDDO + CALL iom_rstput( kt, nitrst, nummxlw, 'smltrd_atf_sumb' , smltrd_atf_sumb ) + ENDIF + ! + IF( kt == nitrst ) THEN + CALL iom_close( nummxlw ) ! close the restart file (only at last time step) + lrst_oce = .FALSE. + ENDIF + ! + END SUBROUTINE trd_mxl_rst_write + + + SUBROUTINE trd_mxl_rst_read + !!---------------------------------------------------------------------------- + !! *** SUBROUTINE trd_mxl_rst_lec *** + !! + !! ** Purpose : Read file for mixed-layer diagnostics restart. + !!---------------------------------------------------------------------------- + INTEGER :: inum ! temporary logical unit + ! + CHARACTER (len=35) :: charout + INTEGER :: jk ! loop indice + LOGICAL :: llok + CHARACTER(LEN=256) :: clpath ! full path to restart file + !!----------------------------------------------------------------------------- + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' trd_mxl_rst_read : read the NetCDF mixed layer trend restart file' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~' + ENDIF + + clpath = TRIM(cn_ocerst_indir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + CALL iom_open( TRIM(clpath)//TRIM(cn_trdrst_in), inum ) + + IF( ln_trdmxl_instant ) THEN + !-- Temperature + CALL iom_get( inum, jpdom_auto, 'tmlbb' , tmlbb ) + CALL iom_get( inum, jpdom_auto, 'tmlbn' , tmlbn ) + CALL iom_get( inum, jpdom_auto, 'tmlatfb' , tmlatfb ) + ! + !-- Salinity + CALL iom_get( inum, jpdom_auto, 'smlbb' , smlbb ) + CALL iom_get( inum, jpdom_auto, 'smlbn' , smlbn ) + CALL iom_get( inum, jpdom_auto, 'smlatfb' , smlatfb ) + ELSE + CALL iom_get( inum, jpdom_auto, 'hmxlbn' , hmxlbn ) ! needed for hmxl_sum + ! + !-- Temperature + CALL iom_get( inum, jpdom_auto, 'tmlbn' , tmlbn ) ! needed for tml_sum + CALL iom_get( inum, jpdom_auto, 'tml_sumb' , tml_sumb ) + DO jk = 1, jpltrd + IF( jk < 10 ) THEN ; WRITE(charout,FMT="('tmltrd_csum_ub_', I1)") jk + ELSE ; WRITE(charout,FMT="('tmltrd_csum_ub_', I2)") jk + ENDIF + CALL iom_get( inum, jpdom_auto, charout, tmltrd_csum_ub(:,:,jk) ) + END DO + CALL iom_get( inum, jpdom_auto, 'tmltrd_atf_sumb' , tmltrd_atf_sumb) + ! + !-- Salinity + CALL iom_get( inum, jpdom_auto, 'smlbn' , smlbn ) ! needed for sml_sum + CALL iom_get( inum, jpdom_auto, 'sml_sumb' , sml_sumb ) + DO jk = 1, jpltrd + IF( jk < 10 ) THEN ; WRITE(charout,FMT="('smltrd_csum_ub_', I1)") jk + ELSE ; WRITE(charout,FMT="('smltrd_csum_ub_', I2)") jk + ENDIF + CALL iom_get( inum, jpdom_auto, charout, smltrd_csum_ub(:,:,jk) ) + END DO + CALL iom_get( inum, jpdom_auto, 'smltrd_atf_sumb' , smltrd_atf_sumb) + ! + CALL iom_close( inum ) + ENDIF + ! + END SUBROUTINE trd_mxl_rst_read + + !!================================================================================= +END MODULE trdmxl_rst \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdpen.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdpen.F90 new file mode 100644 index 0000000..5ff1dd3 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdpen.F90 @@ -0,0 +1,149 @@ +MODULE trdpen + !!====================================================================== + !! *** MODULE trdpen *** + !! Ocean diagnostics: Potential Energy trends + !!===================================================================== + !! History : 3.5 ! 2012-02 (G. Madec) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_pen : compute and output Potential Energy trends from T & S trends + !! trd_pen_init : initialisation of PE trends + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean domain + USE sbc_oce ! surface boundary condition: ocean + USE zdf_oce ! ocean vertical physics + USE trd_oce ! trends: ocean variables + USE eosbn2 ! equation of state and related derivatives + USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. + USE zdfddm ! vertical physics: double diffusion + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_pen ! called by all trdtra module + PUBLIC trd_pen_init ! called by all nemogcm module + + INTEGER :: nkstp ! current time step + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: rab_pe ! partial derivatives of PE anomaly with respect to T and S + + !! * Substitutions +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdpen.F90 13237 2020-07-03 09:12:53Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + INTEGER FUNCTION trd_pen_alloc() + !!--------------------------------------------------------------------- + !! *** FUNCTION trd_tra_alloc *** + !!--------------------------------------------------------------------- + ALLOCATE( rab_pe(jpi,jpj,jpk,jpts) , STAT= trd_pen_alloc ) + ! + CALL mpp_sum ( 'trdpen', trd_pen_alloc ) + IF( trd_pen_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_pen_alloc: failed to allocate arrays' ) + END FUNCTION trd_pen_alloc + + + SUBROUTINE trd_pen( ptrdx, ptrdy, ktrd, kt, pdt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_tra_mng *** + !! + !! ** Purpose : Dispatch all trends computation, e.g. 3D output, integral + !! constraints, barotropic vorticity, kinetic enrgy, + !! potential energy, and/or mixed layer budget. + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(in) :: ptrdx, ptrdy ! Temperature & Salinity trends + INTEGER , INTENT(in) :: ktrd ! tracer trend index + INTEGER , INTENT(in) :: kt ! time step index + INTEGER , INTENT(in) :: Kmm ! time level index + REAL(wp) , INTENT(in) :: pdt ! time step [s] + ! + INTEGER :: jk ! dummy loop indices + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpe ! 3D workspace + !!---------------------------------------------------------------------- + ! + zpe(:,:,:) = 0._wp + ! + IF( kt /= nkstp ) THEN ! full eos: set partial derivatives at the 1st call of kt time step + nkstp = kt + CALL eos_pen( ts(:,:,:,:,Kmm), rab_pe, zpe, Kmm ) + CALL iom_put( "alphaPE", rab_pe(:,:,:,jp_tem) ) + CALL iom_put( "betaPE" , rab_pe(:,:,:,jp_sal) ) + CALL iom_put( "PEanom" , zpe ) + ENDIF + ! + zpe(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + zpe(:,:,jk) = ( - ( rab_n(:,:,jk,jp_tem) + rab_pe(:,:,jk,jp_tem) ) * ptrdx(:,:,jk) & + & + ( rab_n(:,:,jk,jp_sal) + rab_pe(:,:,jk,jp_sal) ) * ptrdy(:,:,jk) ) + END DO + + SELECT CASE ( ktrd ) + CASE ( jptra_xad ) ; CALL iom_put( "petrd_xad", zpe ) ! zonal advection + CASE ( jptra_yad ) ; CALL iom_put( "petrd_yad", zpe ) ! merid. advection + CASE ( jptra_zad ) ; CALL iom_put( "petrd_zad", zpe ) ! vertical advection + IF( ln_linssh ) THEN ! cst volume : adv flux through z=0 surface + ALLOCATE( z2d(jpi,jpj) ) + z2d(:,:) = ww(:,:,1) * ( & + & - ( rab_n(:,:,1,jp_tem) + rab_pe(:,:,1,jp_tem) ) * ts(:,:,1,jp_tem,Kmm) & + & + ( rab_n(:,:,1,jp_sal) + rab_pe(:,:,1,jp_sal) ) * ts(:,:,1,jp_sal,Kmm) & + & ) / e3t(:,:,1,Kmm) + CALL iom_put( "petrd_sad" , z2d ) + DEALLOCATE( z2d ) + ENDIF + CASE ( jptra_ldf ) ; CALL iom_put( "petrd_ldf" , zpe ) ! lateral diffusion + CASE ( jptra_zdf ) ; CALL iom_put( "petrd_zdf" , zpe ) ! lateral diffusion (K_z) + CASE ( jptra_zdfp ) ; CALL iom_put( "petrd_zdfp", zpe ) ! vertical diffusion (K_z) + CASE ( jptra_dmp ) ; CALL iom_put( "petrd_dmp" , zpe ) ! internal 3D restoring (tradmp) + CASE ( jptra_bbl ) ; CALL iom_put( "petrd_bbl" , zpe ) ! bottom boundary layer + CASE ( jptra_npc ) ; CALL iom_put( "petrd_npc" , zpe ) ! non penetr convect adjustment + CASE ( jptra_nsr ) ; CALL iom_put( "petrd_nsr" , zpe ) ! surface forcing + runoff (ln_rnf=T) + CASE ( jptra_qsr ) ; CALL iom_put( "petrd_qsr" , zpe ) ! air-sea : penetrative sol radiat + CASE ( jptra_bbc ) ; CALL iom_put( "petrd_bbc" , zpe ) ! bottom bound cond (geoth flux) + CASE ( jptra_atf ) ; CALL iom_put( "petrd_atf" , zpe ) ! asselin time filter (last trend) + ! + END SELECT + ! + ! + END SUBROUTINE trd_pen + + + SUBROUTINE trd_pen_init + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_pen_init *** + !! + !! ** Purpose : initialisation of 3D Kinetic Energy trend diagnostic + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'trd_pen_init : 3D Potential ENergy trends' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + ! ! allocate box volume arrays + IF ( trd_pen_alloc() /= 0 ) CALL ctl_stop('trd_pen_alloc: failed to allocate arrays') + ! + rab_pe(:,:,:,:) = 0._wp + ! + IF( .NOT.ln_linssh ) CALL ctl_stop('trd_pen_init : PE trends not coded for variable volume') + ! + nkstp = nit000 - 1 + ! + END SUBROUTINE trd_pen_init + + !!====================================================================== +END MODULE trdpen \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdtra.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdtra.F90 new file mode 100644 index 0000000..155ba37 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdtra.F90 @@ -0,0 +1,373 @@ +MODULE trdtra + !!====================================================================== + !! *** MODULE trdtra *** + !! Ocean diagnostics: ocean tracers trends pre-processing + !!===================================================================== + !! History : 3.3 ! 2010-06 (C. Ethe) creation for the TRA/TRC merge + !! 3.5 ! 2012-02 (G. Madec) update the comments + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_tra : pre-process the tracer trends + !! trd_tra_adv : transform a div(U.T) trend into a U.grad(T) trend + !! trd_tra_mng : tracer trend manager: dispatch to the diagnostic modules + !! trd_tra_iom : output 3D tracer trends using IOM + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean domain + USE sbc_oce ! surface boundary condition: ocean + USE zdf_oce ! ocean vertical physics + USE trd_oce ! trends: ocean variables + USE trdtrc ! ocean passive mixed layer tracers trends + USE trdglo ! trends: global domain averaged + USE trdpen ! trends: Potential ENergy + USE trdmxl ! ocean active mixed layer tracers trends + USE ldftra ! ocean active tracers lateral physics + USE ldfslp + USE zdfddm ! vertical physics: double diffusion + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_tra ! called by all tra_... modules + + REAL(dp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: trdtx, trdty, trdt ! use to store the temperature trends + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_evd ! store avt_evd to calculate EVD trend + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdtra.F90 14174 2020-12-15 18:25:18Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trd_tra_alloc() + !!--------------------------------------------------------------------- + !! *** FUNCTION trd_tra_alloc *** + !!--------------------------------------------------------------------- + ALLOCATE( trdtx(jpi,jpj,jpk) , trdty(jpi,jpj,jpk) , trdt(jpi,jpj,jpk) , avt_evd(jpi,jpj,jpk), STAT= trd_tra_alloc ) + ! + CALL mpp_sum ( 'trdtra', trd_tra_alloc ) + IF( trd_tra_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_tra_alloc: failed to allocate arrays' ) + END FUNCTION trd_tra_alloc + + + SUBROUTINE trd_tra( kt, Kmm, Krhs, ctype, ktra, ktrd, ptrd, pu, ptra ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_tra *** + !! + !! ** Purpose : pre-process tracer trends + !! + !! ** Method : - mask the trend + !! - advection (ptra present) converte the incoming flux (U.T) + !! into trend (U.T => -U.grat(T)=div(U.T)-T.div(U)) through a + !! call to trd_tra_adv + !! - 'TRA' case : regroup T & S trends + !! - send the trends to trd_tra_mng (trdtrc) for further processing + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! time step + CHARACTER(len=3) , INTENT(in) :: ctype ! tracers trends type 'TRA'/'TRC' + INTEGER , INTENT(in) :: ktra ! tracer index + INTEGER , INTENT(in) :: ktrd ! tracer trend index + INTEGER , INTENT(in) :: Kmm, Krhs ! time level indices + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: ptrd ! tracer trend or flux + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pu ! now velocity + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: ptra ! now tracer variable + ! + INTEGER :: jk ! loop indices + INTEGER :: i01 ! 0 or 1 + REAL(dp), DIMENSION(jpi,jpj,jpk) :: ztrds ! 3D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwt, zws! 3D workspace + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt! 3D workspace + !!---------------------------------------------------------------------- + ! + IF( .NOT. ALLOCATED( trdtx ) ) THEN ! allocate trdtra arrays + IF( trd_tra_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trd_tra : unable to allocate arrays' ) + avt_evd(:,:,:) = 0._wp + ENDIF + ! + i01 = COUNT( (/ PRESENT(pu) .OR. ( ktrd /= jptra_xad .AND. ktrd /= jptra_yad .AND. ktrd /= jptra_zad ) /) ) + ! + IF( ctype == 'TRA' .AND. ktra == jp_tem ) THEN !== Temperature trend ==! + ! + SELECT CASE( ktrd*i01 ) + ! ! advection: transform the advective flux into a trend + CASE( jptra_xad ) ; CALL trd_tra_adv( ptrd, pu, ptra, 'X', trdtx, Kmm ) + CASE( jptra_yad ) ; CALL trd_tra_adv( ptrd, pu, ptra, 'Y', trdty, Kmm ) + CASE( jptra_zad ) ; CALL trd_tra_adv( ptrd, pu, ptra, 'Z', trdt, Kmm ) + CASE( jptra_bbc, & ! qsr, bbc: on temperature only, send to trd_tra_mng + & jptra_qsr ) ; trdt(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) + ztrds(:,:,:) = 0._wp + CALL trd_tra_mng( trdt, ztrds, ktrd, kt, Kmm ) + !!gm Gurvan, verify the jptra_evd trend please ! + CASE( jptra_evd ) ; avt_evd(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) + CASE DEFAULT ! other trends: masked trends + trdt(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) ! mask & store + END SELECT + ! + ENDIF + + IF( ctype == 'TRA' .AND. ktra == jp_sal ) THEN !== Salinity trends ==! + ! + SELECT CASE( ktrd*i01 ) + ! ! advection: transform the advective flux into a trend + ! ! and send T & S trends to trd_tra_mng + CASE( jptra_xad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'X' , ztrds, Kmm ) + CALL trd_tra_mng( trdtx, ztrds, ktrd, kt, Kmm ) + CASE( jptra_yad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'Y' , ztrds, Kmm ) + CALL trd_tra_mng( trdty, ztrds, ktrd, kt, Kmm ) + CASE( jptra_zad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'Z' , ztrds, Kmm ) + CALL trd_tra_mng( trdt , ztrds, ktrd, kt, Kmm ) + CASE( jptra_zdfp ) ! diagnose the "PURE" Kz trend (here: just before the swap) + ! ! iso-neutral diffusion case otherwise jptra_zdf is "PURE" + ALLOCATE( zwt(jpi,jpj,jpk), zws(jpi,jpj,jpk), ztrdt(jpi,jpj,jpk) ) + ! + zwt(:,:, 1 ) = 0._wp ; zws(:,:, 1 ) = 0._wp ! vertical diffusive fluxes + zwt(:,:,jpk) = 0._wp ; zws(:,:,jpk) = 0._wp + DO jk = 2, jpk + zwt(:,:,jk) = avt(:,:,jk) * ( ts(:,:,jk-1,jp_tem,Krhs) - ts(:,:,jk,jp_tem,Krhs) ) & + & / e3w(:,:,jk,Kmm) * tmask(:,:,jk) + zws(:,:,jk) = avs(:,:,jk) * ( ts(:,:,jk-1,jp_sal,Krhs) - ts(:,:,jk,jp_sal,Krhs) ) & + & / e3w(:,:,jk,Kmm) * tmask(:,:,jk) + END DO + ! + ztrdt(:,:,jpk) = 0._wp ; ztrds(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / e3t(:,:,jk,Kmm) + ztrds(:,:,jk) = ( zws(:,:,jk) - zws(:,:,jk+1) ) / e3t(:,:,jk,Kmm) + END DO + CALL trd_tra_mng( ztrdt, ztrds, jptra_zdfp, kt, Kmm ) + ! + ! ! Also calculate EVD trend at this point. + zwt(:,:,:) = 0._wp ; zws(:,:,:) = 0._wp ! vertical diffusive fluxes + DO jk = 2, jpk + zwt(:,:,jk) = avt_evd(:,:,jk) * ( ts(:,:,jk-1,jp_tem,Krhs) - ts(:,:,jk,jp_tem,Krhs) ) & + & / e3w(:,:,jk,Kmm) * tmask(:,:,jk) + zws(:,:,jk) = avt_evd(:,:,jk) * ( ts(:,:,jk-1,jp_sal,Krhs) - ts(:,:,jk,jp_sal,Krhs) ) & + & / e3w(:,:,jk,Kmm) * tmask(:,:,jk) + END DO + ! + ztrdt(:,:,jpk) = 0._wp ; ztrds(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / e3t(:,:,jk,Kmm) + ztrds(:,:,jk) = ( zws(:,:,jk) - zws(:,:,jk+1) ) / e3t(:,:,jk,Kmm) + END DO + CALL trd_tra_mng( ztrdt, ztrds, jptra_evd, kt, Kmm ) + ! + DEALLOCATE( zwt, zws, ztrdt ) + ! + CASE DEFAULT ! other trends: mask and send T & S trends to trd_tra_mng + ztrds(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) + CALL trd_tra_mng( trdt, ztrds, ktrd, kt, Kmm ) + END SELECT + ENDIF + + IF( ctype == 'TRC' ) THEN !== passive tracer trend ==! + ! + SELECT CASE( ktrd*i01 ) + ! ! advection: transform the advective flux into a masked trend + CASE( jptra_xad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'X', ztrds, Kmm ) + CASE( jptra_yad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'Y', ztrds, Kmm ) + CASE( jptra_zad ) ; CALL trd_tra_adv( ptrd , pu , ptra, 'Z', ztrds, Kmm ) + CASE DEFAULT ! other trends: just masked + ztrds(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) + END SELECT + ! ! send trend to trd_trc + CALL trd_trc( ztrds, ktra, ktrd, kt, Kmm ) + ! + ENDIF + ! + END SUBROUTINE trd_tra + + + SUBROUTINE trd_tra_adv( pf, pu, pt, cdir, ptrd, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_tra_adv *** + !! + !! ** Purpose : transformed a advective flux into a masked advective trends + !! + !! ** Method : use the following transformation: -div(U.T) = - U grad(T) + T.div(U) + !! i-advective trends = -un. di-1[T] = -( di-1[fi] - tn di-1[un] ) + !! j-advective trends = -un. di-1[T] = -( dj-1[fi] - tn dj-1[un] ) + !! k-advective trends = -un. di+1[T] = -( dk+1[fi] - tn dk+1[un] ) + !! where fi is the incoming advective flux. + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pf ! advective flux in one direction + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pu ! now velocity in one direction + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pt ! now or before tracer + CHARACTER(len=1) , INTENT(in ) :: cdir ! X/Y/Z direction + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT( out) :: ptrd ! advective trend in one direction + INTEGER, INTENT(in) :: Kmm ! time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ii, ij, ik ! index shift as function of the direction + !!---------------------------------------------------------------------- + ! + SELECT CASE( cdir ) ! shift depending on the direction + CASE( 'X' ) ; ii = 1 ; ij = 0 ; ik = 0 ! i-trend + CASE( 'Y' ) ; ii = 0 ; ij = 1 ; ik = 0 ! j-trend + CASE( 'Z' ) ; ii = 0 ; ij = 0 ; ik =-1 ! k-trend + END SELECT + ! + ! ! set to zero uncomputed values + ptrd(jpi,:,:) = 0._wp ; ptrd(1,:,:) = 0._wp + ptrd(:,jpj,:) = 0._wp ; ptrd(:,1,:) = 0._wp + ptrd(:,:,jpk) = 0._wp + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! advective trend + ptrd(ji,jj,jk) = - ( pf (ji,jj,jk) - pf (ji-ii,jj-ij,jk-ik) & + & - ( pu(ji,jj,jk) - pu(ji-ii,jj-ij,jk-ik) ) * pt(ji,jj,jk) ) & + & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) + END_3D + ! + END SUBROUTINE trd_tra_adv + + + SUBROUTINE trd_tra_mng( ptrdx, ptrdy, ktrd, kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_tra_mng *** + !! + !! ** Purpose : Dispatch all tracer trends computation, e.g. 3D output, + !! integral constraints, potential energy, and/or + !! mixed layer budget. + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdx ! Temperature or U trend + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdy ! Salinity or V trend + INTEGER , INTENT(in ) :: ktrd ! tracer trend index + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + !!---------------------------------------------------------------------- + + ! ! 3D output of tracers trends using IOM interface + IF( ln_tra_trd ) CALL trd_tra_iom ( ptrdx, ptrdy, ktrd, kt, Kmm ) + + ! ! Integral Constraints Properties for tracers trends !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_glo_trd ) CALL trd_glo( ptrdx, ptrdy, ktrd, 'TRA', kt, Kmm ) + + ! ! Potential ENergy trends + IF( ln_PE_trd ) CALL trd_pen( ptrdx, ptrdy, ktrd, kt, rDt, Kmm ) + + ! ! Mixed layer trends for active tracers + IF( ln_tra_mxl ) THEN + !----------------------------------------------------------------------------------------------- + ! W.A.R.N.I.N.G : + ! jptra_ldf : called by traldf.F90 + ! at this stage we store: + ! - the lateral geopotential diffusion (here, lateral = horizontal) + ! - and the iso-neutral diffusion if activated + ! jptra_zdf : called by trazdf.F90 + ! * in case of iso-neutral diffusion we store the vertical diffusion component in the + ! lateral trend including the K_z contrib, which will be removed later (see trd_mxl) + !----------------------------------------------------------------------------------------------- + + SELECT CASE ( ktrd ) + CASE ( jptra_xad ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_xad, '3D' ) ! zonal advection + CASE ( jptra_yad ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_yad, '3D' ) ! merid. advection + CASE ( jptra_zad ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_zad, '3D' ) ! vertical advection + CASE ( jptra_ldf ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_ldf, '3D' ) ! lateral diffusion + CASE ( jptra_bbl ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_bbl, '3D' ) ! bottom boundary layer + CASE ( jptra_zdf ) + IF( ln_traldf_iso ) THEN ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_ldf, '3D' ) ! lateral diffusion (K_z) + ELSE ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_zdf, '3D' ) ! vertical diffusion (K_z) + ENDIF + CASE ( jptra_dmp ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_dmp, '3D' ) ! internal 3D restoring (tradmp) + CASE ( jptra_qsr ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_for, '3D' ) ! air-sea : penetrative sol radiat + CASE ( jptra_nsr ) ; ptrdx(:,:,2:jpk) = 0._wp ; ptrdy(:,:,2:jpk) = 0._wp + CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_for, '2D' ) ! air-sea : non penetr sol radiation + CASE ( jptra_bbc ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_bbc, '3D' ) ! bottom bound cond (geoth flux) + CASE ( jptra_npc ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_npc, '3D' ) ! non penetr convect adjustment + CASE ( jptra_atf ) ; CALL trd_mxl_zint( ptrdx, ptrdy, jpmxl_atf, '3D' ) ! asselin time filter (last trend) + ! + CALL trd_mxl( kt, rDt ) ! trends: Mixed-layer (output) + END SELECT + ! + ENDIF + ! + END SUBROUTINE trd_tra_mng + + + SUBROUTINE trd_tra_iom( ptrdx, ptrdy, ktrd, kt, Kmm ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_tra_iom *** + !! + !! ** Purpose : output 3D tracer trends using IOM + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdx ! Temperature or U trend + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: ptrdy ! Salinity or V trend + INTEGER , INTENT(in ) :: ktrd ! tracer trend index + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + !! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikbu, ikbv ! local integers + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2dx, z2dy ! 2D workspace + !!---------------------------------------------------------------------- + ! +!!gm Rq: mask the trends already masked in trd_tra, but lbc_lnk should probably be added + ! + ! Trends evaluated every time step that could go to the standard T file and can be output every ts into a 1ts file if 1ts output is selected + SELECT CASE( ktrd ) + ! This total trend is done every time step + CASE( jptra_tot ) ; CALL iom_put( "ttrd_tot" , ptrdx ) ! model total trend + CALL iom_put( "strd_tot" , ptrdy ) + END SELECT + ! + ! These trends are done every second time step. When 1ts output is selected must go different (2ts) file from standard T-file + IF( MOD( kt, 2 ) == 0 ) THEN + SELECT CASE( ktrd ) + CASE( jptra_xad ) ; CALL iom_put( "ttrd_xad" , ptrdx ) ! x- horizontal advection + CALL iom_put( "strd_xad" , ptrdy ) + CASE( jptra_yad ) ; CALL iom_put( "ttrd_yad" , ptrdx ) ! y- horizontal advection + CALL iom_put( "strd_yad" , ptrdy ) + CASE( jptra_zad ) ; CALL iom_put( "ttrd_zad" , ptrdx ) ! z- vertical advection + CALL iom_put( "strd_zad" , ptrdy ) + IF( ln_linssh ) THEN ! cst volume : adv flux through z=0 surface + ALLOCATE( z2dx(jpi,jpj), z2dy(jpi,jpj) ) + z2dx(:,:) = ww(:,:,1) * ts(:,:,1,jp_tem,Kmm) / e3t(:,:,1,Kmm) + z2dy(:,:) = ww(:,:,1) * ts(:,:,1,jp_sal,Kmm) / e3t(:,:,1,Kmm) + CALL iom_put( "ttrd_sad", z2dx ) + CALL iom_put( "strd_sad", z2dy ) + DEALLOCATE( z2dx, z2dy ) + ENDIF + CASE( jptra_totad ) ; CALL iom_put( "ttrd_totad", ptrdx ) ! total advection + CALL iom_put( "strd_totad", ptrdy ) + CASE( jptra_ldf ) ; CALL iom_put( "ttrd_ldf" , ptrdx ) ! lateral diffusion + CALL iom_put( "strd_ldf" , ptrdy ) + CASE( jptra_zdf ) ; CALL iom_put( "ttrd_zdf" , ptrdx ) ! vertical diffusion (including Kz contribution) + CALL iom_put( "strd_zdf" , ptrdy ) + CASE( jptra_zdfp ) ; CALL iom_put( "ttrd_zdfp" , ptrdx ) ! PURE vertical diffusion (no isoneutral contribution) + CALL iom_put( "strd_zdfp" , ptrdy ) + CASE( jptra_evd ) ; CALL iom_put( "ttrd_evd" , ptrdx ) ! EVD trend (convection) + CALL iom_put( "strd_evd" , ptrdy ) + CASE( jptra_dmp ) ; CALL iom_put( "ttrd_dmp" , ptrdx ) ! internal restoring (damping) + CALL iom_put( "strd_dmp" , ptrdy ) + CASE( jptra_bbl ) ; CALL iom_put( "ttrd_bbl" , ptrdx ) ! bottom boundary layer + CALL iom_put( "strd_bbl" , ptrdy ) + CASE( jptra_npc ) ; CALL iom_put( "ttrd_npc" , ptrdx ) ! static instability mixing + CALL iom_put( "strd_npc" , ptrdy ) + CASE( jptra_bbc ) ; CALL iom_put( "ttrd_bbc" , ptrdx ) ! geothermal heating (only on temperature) + CASE( jptra_nsr ) ; CALL iom_put( "ttrd_qns" , ptrdx(:,:,1) ) ! surface forcing + runoff (ln_rnf=T) + CALL iom_put( "strd_cdt" , ptrdy(:,:,1) ) ! output as 2D surface fields + CASE( jptra_qsr ) ; CALL iom_put( "ttrd_qsr" , ptrdx ) ! penetrative solar radiat. (only on temperature) + END SELECT + ! the Asselin filter trend is also every other time step but needs to be lagged one time step + ! Even when 1ts output is selected can go to the same (2ts) file as the trends plotted every even time step. + ELSE IF( MOD( kt, 2 ) == 1 ) THEN + SELECT CASE( ktrd ) + CASE( jptra_atf ) ; CALL iom_put( "ttrd_atf" , ptrdx ) ! asselin time Filter + CALL iom_put( "strd_atf" , ptrdy ) + END SELECT + END IF + ! + END SUBROUTINE trd_tra_iom + + !!====================================================================== +END MODULE trdtra \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdtrc.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdtrc.F90 new file mode 100644 index 0000000..f4200fe --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdtrc.F90 @@ -0,0 +1,25 @@ +MODULE trdtrc + USE par_kind + !!====================================================================== + !! *** MODULE trdtrc *** + !! Dummy module + !!====================================================================== + !!---------------------------------------------------------------------- + !! Dummy module NO TOP use + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_trc( ptrtrd, kjn, ktrd, kt, Kmm ) + INTEGER :: kt, kjn, ktrd + INTEGER :: Kmm ! time level index + REAL(dp), DIMENSION(:,:,:) :: ptrtrd + WRITE(*,*) 'trd_trc : You should not have seen this print! error?', ptrtrd(1,1,1) + WRITE(*,*) ' " " : You should not have seen this print! error?', kjn, ktrd, kt + END SUBROUTINE trd_trc + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdtrc.F90 13226 2020-07-02 14:24:31Z orioltp $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trdtrc diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdvor.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdvor.F90 new file mode 100644 index 0000000..c6fb760 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdvor.F90 @@ -0,0 +1,545 @@ +MODULE trdvor + !!====================================================================== + !! *** MODULE trdvor *** + !! Ocean diagnostics: momentum trends + !!===================================================================== + !! History : 1.0 ! 2006-01 (L. Brunier, A-M. Treguier) Original code + !! 2.0 ! 2008-04 (C. Talandier) New trends organization + !! 3.5 ! 2012-02 (G. Madec) regroup beta.V computation with pvo trend + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_vor : momentum trends averaged over the depth + !! trd_vor_zint : vorticity vertical integration + !! trd_vor_init : initialization step + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE trd_oce ! trends: ocean variables + USE zdf_oce ! ocean vertical physics + USE sbc_oce ! surface boundary condition: ocean + USE phycst ! Define parameters for the routines + USE ldfdyn ! ocean active tracers: lateral physics + USE dianam ! build the name of file (routine) + USE zdfmxl ! mixed layer depth + ! + USE in_out_manager ! I/O manager + USE ioipsl ! NetCDF library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + INTERFACE trd_vor_zint + MODULE PROCEDURE trd_vor_zint_2d, trd_vor_zint_3d + END INTERFACE + + PUBLIC trd_vor ! routine called by trddyn.F90 + PUBLIC trd_vor_init ! routine called by opa.F90 + PUBLIC trd_vor_alloc ! routine called by nemogcm.F90 + + INTEGER :: nh_t, nmoydpvor, nidvor, nhoridvor, ndimvor1, icount ! needs for IOIPSL output + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndexvor1 ! needed for IOIPSL output + INTEGER :: ndebug ! (0/1) set it to 1 in case of problem to have more print + + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avr ! average + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrb ! before vorticity (kt-1) + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrbb ! vorticity at begining of the nn_write-1 timestep averaging period + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrbn ! after vorticity at time step after the + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: rotot ! begining of the NN_WRITE-1 timesteps + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrtot ! + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: vor_avrres ! + REAL(dp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: vortrd ! curl of trends + + CHARACTER(len=12) :: cvort + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdvor.F90 15033 2021-06-21 10:24:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trd_vor_alloc() + !!---------------------------------------------------------------------------- + !! *** ROUTINE trd_vor_alloc *** + !!---------------------------------------------------------------------------- + ALLOCATE( vor_avr (jpi,jpj) , vor_avrb(jpi,jpj) , vor_avrbb (jpi,jpj) , & + & vor_avrbn (jpi,jpj) , rotot (jpi,jpj) , vor_avrtot(jpi,jpj) , & + & vor_avrres(jpi,jpj) , vortrd (jpi,jpj,jpltot_vor) , & + & ndexvor1 (jpi*jpj) , STAT= trd_vor_alloc ) + ! + CALL mpp_sum ( 'trdvor', trd_vor_alloc ) + IF( trd_vor_alloc /= 0 ) CALL ctl_stop( 'STOP', 'trd_vor_alloc: failed to allocate arrays' ) + END FUNCTION trd_vor_alloc + + + SUBROUTINE trd_vor( putrd, pvtrd, ktrd, kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_vor *** + !! + !! ** Purpose : computation of cumulated trends over analysis period + !! and make outputs (NetCDF format) + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V trends + INTEGER , INTENT(in ) :: ktrd ! trend index + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: ztswu, ztswv ! 2D workspace + !!---------------------------------------------------------------------- + + CALL lbc_lnk( 'trdvor', putrd, 'U', -1.0_dp , pvtrd, 'V', -1.0_dp ) ! lateral boundary condition + + SELECT CASE( ktrd ) + CASE( jpdyn_hpg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_prg, Kmm ) ! Hydrostatique Pressure Gradient + CASE( jpdyn_keg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_keg, Kmm ) ! KE Gradient + CASE( jpdyn_rvo ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_rvo, Kmm ) ! Relative Vorticity + CASE( jpdyn_pvo ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_pvo, Kmm ) ! Planetary Vorticity Term + CASE( jpdyn_ldf ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_ldf, Kmm ) ! Horizontal Diffusion + CASE( jpdyn_zad ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_zad, Kmm ) ! Vertical Advection + CASE( jpdyn_spg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_spg, Kmm ) ! Surface Pressure Grad. + CASE( jpdyn_zdf ) ! Vertical Diffusion + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! wind stress trends + ztswu(ji,jj) = 0.5 * ( utau_b(ji,jj) + utau(ji,jj) ) / ( e3u(ji,jj,1,Kmm) * rho0 ) + ztswv(ji,jj) = 0.5 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / ( e3v(ji,jj,1,Kmm) * rho0 ) + END_2D + CALL trd_vor_zint( putrd, pvtrd, jpvor_zdf, Kmm ) ! zdf trend including surf./bot. stresses + CALL trd_vor_zint( ztswu, ztswv, jpvor_swf, Kmm ) ! surface wind stress + CASE( jpdyn_bfr ) + CALL trd_vor_zint( putrd, pvtrd, jpvor_bfr, Kmm ) ! Bottom stress + ! + CASE( jpdyn_atf ) ! last trends: perform the output of 2D vorticity trends + CALL trd_vor_iom( kt, Kmm ) + END SELECT + ! + END SUBROUTINE trd_vor + + + SUBROUTINE trd_vor_zint_2d( putrdvor, pvtrdvor, ktrd, Kmm ) + !!---------------------------------------------------------------------------- + !! *** ROUTINE trd_vor_zint *** + !! + !! ** Purpose : computation of vertically integrated vorticity budgets + !! from ocean surface down to control surface (NetCDF output) + !! + !! ** Method/usage : integration done over nn_write-1 time steps + !! + !! ** Action : trends : + !! vortrd (,, 1) = Pressure Gradient Trend + !! vortrd (,, 2) = KE Gradient Trend + !! vortrd (,, 3) = Relative Vorticity Trend + !! vortrd (,, 4) = Coriolis Term Trend + !! vortrd (,, 5) = Horizontal Diffusion Trend + !! vortrd (,, 6) = Vertical Advection Trend + !! vortrd (,, 7) = Vertical Diffusion Trend + !! vortrd (,, 8) = Surface Pressure Grad. Trend + !! vortrd (,, 9) = Beta V + !! vortrd (,,10) = forcing term + !! vortrd (,,11) = bottom friction term + !! rotot(,) : total cumulative trends over nn_write-1 time steps + !! vor_avrtot(,) : first membre of vrticity equation + !! vor_avrres(,) : residual = dh/dt entrainment + !! + !! trends output in netCDF format using ioipsl + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: ktrd ! ocean trend index + INTEGER , INTENT(in) :: Kmm ! time level index + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: putrdvor ! u vorticity trend + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pvtrdvor ! v vorticity trend + ! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ikbu, ikbv ! local integers + REAL(wp), DIMENSION(jpi,jpj) :: zudpvor, zvdpvor ! total cmulative trends + !!---------------------------------------------------------------------- + + ! ===================================== + ! I vertical integration of 2D trends + ! ===================================== + + SELECT CASE( ktrd ) + ! + CASE( jpvor_bfr ) ! bottom friction + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ikbu = mbkv(ji,jj) + ikbv = mbkv(ji,jj) + zudpvor(ji,jj) = putrdvor(ji,jj) * e3u(ji,jj,ikbu,Kmm) * e1u(ji,jj) * umask(ji,jj,ikbu) + zvdpvor(ji,jj) = pvtrdvor(ji,jj) * e3v(ji,jj,ikbv,Kmm) * e2v(ji,jj) * vmask(ji,jj,ikbv) + END_2D + ! + CASE( jpvor_swf ) ! wind stress + zudpvor(:,:) = putrdvor(:,:) * e3u(:,:,1,Kmm) * e1u(:,:) * umask(:,:,1) + zvdpvor(:,:) = pvtrdvor(:,:) * e3v(:,:,1,Kmm) * e2v(:,:) * vmask(:,:,1) + ! + END SELECT + + ! Average except for Beta.V + zudpvor(:,:) = zudpvor(:,:) * r1_hu(:,:,Kmm) + zvdpvor(:,:) = zvdpvor(:,:) * r1_hv(:,:,Kmm) + + ! Curl + DO_2D( 0, 0, 0, 0 ) + vortrd(ji,jj,ktrd) = ( zvdpvor(ji+1,jj) - zvdpvor(ji,jj) & + & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) & + & / ( e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,1) + END_2D + + IF( ndebug /= 0 ) THEN + IF(lwp) WRITE(numout,*) ' debuging trd_vor_zint: I done' + CALL FLUSH(numout) + ENDIF + ! + END SUBROUTINE trd_vor_zint_2d + + + SUBROUTINE trd_vor_zint_3d( putrdvor, pvtrdvor, ktrd , Kmm ) + !!---------------------------------------------------------------------------- + !! *** ROUTINE trd_vor_zint *** + !! + !! ** Purpose : computation of vertically integrated vorticity budgets + !! from ocean surface down to control surface (NetCDF output) + !! + !! ** Method/usage : integration done over nn_write-1 time steps + !! + !! ** Action : trends : + !! vortrd (,,1) = Pressure Gradient Trend + !! vortrd (,,2) = KE Gradient Trend + !! vortrd (,,3) = Relative Vorticity Trend + !! vortrd (,,4) = Coriolis Term Trend + !! vortrd (,,5) = Horizontal Diffusion Trend + !! vortrd (,,6) = Vertical Advection Trend + !! vortrd (,,7) = Vertical Diffusion Trend + !! vortrd (,,8) = Surface Pressure Grad. Trend + !! vortrd (,,9) = Beta V + !! vortrd (,,10) = forcing term + !! vortrd (,,11) = bottom friction term + !! rotot(,) : total cumulative trends over nn_write-1 time steps + !! vor_avrtot(,) : first membre of vrticity equation + !! vor_avrres(,) : residual = dh/dt entrainment + !! + !! trends output in netCDF format using ioipsl + !!---------------------------------------------------------------------- + ! + INTEGER , INTENT(in) :: ktrd ! ocean trend index + INTEGER , INTENT(in) :: Kmm ! time level index + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: putrdvor ! u vorticity trend + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pvtrdvor ! v vorticity trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: zudpvor, zvdpvor ! total cmulative trends + !!---------------------------------------------------------------------- + + ! ===================================== + ! I vertical integration of 3D trends + ! ===================================== + ! putrdvor and pvtrdvor terms + DO jk = 1,jpk + zudpvor(:,:) = zudpvor(:,:) + putrdvor(:,:,jk) * e3u(:,:,jk,Kmm) * e1u(:,:) * umask(:,:,jk) + zvdpvor(:,:) = zvdpvor(:,:) + pvtrdvor(:,:,jk) * e3v(:,:,jk,Kmm) * e2v(:,:) * vmask(:,:,jk) + END DO + + ! Planetary vorticity: 2nd computation (Beta.V term) store the vertical sum + ! as Beta.V term need intergration, not average + IF( ktrd == jpvor_pvo ) THEN + DO_2D( 0, 0, 0, 0 ) + vortrd(ji,jj,jpvor_bev) = ( zvdpvor(ji+1,jj) - zvdpvor(ji,jj) & + & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) & + & / ( e1f(ji,jj) * e2f(ji,jj) ) * r1_hu(ji,jj,Kmm) * fmask(ji,jj,1) + END_2D + ENDIF + ! + ! Average + zudpvor(:,:) = zudpvor(:,:) * r1_hu(:,:,Kmm) + zvdpvor(:,:) = zvdpvor(:,:) * r1_hv(:,:,Kmm) + ! + ! Curl + DO_2D( 0, 0, 0, 0 ) + vortrd(ji,jj,ktrd) = ( zvdpvor(ji+1,jj) - zvdpvor(ji,jj) & + & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) & + & / ( e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,1) + END_2D + + IF( ndebug /= 0 ) THEN + IF(lwp) WRITE(numout,*) ' debuging trd_vor_zint: I done' + CALL FLUSH(numout) + ENDIF + ! + END SUBROUTINE trd_vor_zint_3d + + + SUBROUTINE trd_vor_iom( kt , Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_vor *** + !! + !! ** Purpose : computation of cumulated trends over analysis period + !! and make outputs (NetCDF format) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! time step + INTEGER , INTENT(in ) :: Kmm ! time level index + ! + INTEGER :: ji, jj, jk, jl ! dummy loop indices + INTEGER :: it, itmod ! local integers + REAL(wp) :: zmean ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zuu, zvv + !!---------------------------------------------------------------------- + + ! ================= + ! I. Initialization + ! ================= + + + ! I.1 set before values of vertically average u and v + ! --------------------------------------------------- + + IF( kt > nit000 ) vor_avrb(:,:) = vor_avr(:,:) + + ! I.2 vertically integrated vorticity + ! ---------------------------------- + + vor_avr (:,:) = 0._wp + zuu (:,:) = 0._wp + zvv (:,:) = 0._wp + vor_avrtot(:,:) = 0._wp + vor_avrres(:,:) = 0._wp + + ! Vertically averaged velocity + DO jk = 1, jpk - 1 + zuu(:,:) = zuu(:,:) + e1u(:,:) * uu(:,:,jk,Kmm) * e3u(:,:,jk,Kmm) + zvv(:,:) = zvv(:,:) + e2v(:,:) * vv(:,:,jk,Kmm) * e3v(:,:,jk,Kmm) + END DO + + zuu(:,:) = zuu(:,:) * r1_hu(:,:,Kmm) + zvv(:,:) = zvv(:,:) * r1_hv(:,:,Kmm) + + ! Curl + DO_2D( 0, 0, 0, 0 ) + vor_avr(ji,jj) = ( ( zvv(ji+1,jj) - zvv(ji,jj) ) & + & - ( zuu(ji,jj+1) - zuu(ji,jj) ) ) & + & / ( e1f(ji,jj) * e2f(ji,jj) ) * fmask(ji,jj,1) + END_2D + + ! ================================= + ! II. Cumulated trends + ! ================================= + + ! II.1 set `before' mixed layer values for kt = nit000+1 + ! ------------------------------------------------------ + IF( kt == nit000+1 ) THEN + vor_avrbb(:,:) = vor_avrb(:,:) + vor_avrbn(:,:) = vor_avr (:,:) + ENDIF + + ! II.2 cumulated trends over analysis period (kt=2 to nn_write) + ! ---------------------- + ! trends cumulated over nn_write-2 time steps + + IF( kt >= nit000+2 ) THEN + nmoydpvor = nmoydpvor + 1 + DO jl = 1, jpltot_vor + IF( jl /= 9 ) THEN + rotot(:,:) = rotot(:,:) + vortrd(:,:,jl) + ENDIF + END DO + ENDIF + + ! ============================================= + ! III. Output in netCDF + residual computation + ! ============================================= + + ! define time axis + it = kt + itmod = kt - nit000 + 1 + + IF( MOD( it, nn_trd ) == 0 ) THEN + + ! III.1 compute total trend + ! ------------------------ + zmean = 1._wp / ( REAL( nmoydpvor, wp ) * 2._wp * rn_Dt ) + vor_avrtot(:,:) = ( vor_avr(:,:) - vor_avrbn(:,:) + vor_avrb(:,:) - vor_avrbb(:,:) ) * zmean + + + ! III.2 compute residual + ! --------------------- + zmean = 1._wp / REAL( nmoydpvor, wp ) + vor_avrres(:,:) = vor_avrtot(:,:) - rotot(:,:) / zmean + + ! Boundary conditions + CALL lbc_lnk( 'trdvor', vor_avrtot, 'F', 1.0_wp , vor_avrres, 'F', 1.0_wp ) + + + ! III.3 time evolution array swap + ! ------------------------------ + vor_avrbb(:,:) = vor_avrb(:,:) + vor_avrbn(:,:) = vor_avr (:,:) + ! + nmoydpvor = 0 + ! + ENDIF + + ! III.4 write trends to output + ! --------------------------- + + IF( kt >= nit000+1 ) THEN + + IF( lwp .AND. MOD( itmod, nn_trd ) == 0 ) THEN + WRITE(numout,*) '' + WRITE(numout,*) 'trd_vor : write trends in the NetCDF file at kt = ', kt + WRITE(numout,*) '~~~~~~~ ' + ENDIF + + CALL histwrite( nidvor,"sovortPh",it,vortrd(:,:,jpvor_prg),ndimvor1,ndexvor1) ! grad Ph + CALL histwrite( nidvor,"sovortEk",it,vortrd(:,:,jpvor_keg),ndimvor1,ndexvor1) ! Energy + CALL histwrite( nidvor,"sovozeta",it,vortrd(:,:,jpvor_rvo),ndimvor1,ndexvor1) ! rel vorticity + CALL histwrite( nidvor,"sovortif",it,vortrd(:,:,jpvor_pvo),ndimvor1,ndexvor1) ! coriolis + CALL histwrite( nidvor,"sovodifl",it,vortrd(:,:,jpvor_ldf),ndimvor1,ndexvor1) ! lat diff + CALL histwrite( nidvor,"sovoadvv",it,vortrd(:,:,jpvor_zad),ndimvor1,ndexvor1) ! vert adv + CALL histwrite( nidvor,"sovodifv",it,vortrd(:,:,jpvor_zdf),ndimvor1,ndexvor1) ! vert diff + CALL histwrite( nidvor,"sovortPs",it,vortrd(:,:,jpvor_spg),ndimvor1,ndexvor1) ! grad Ps + CALL histwrite( nidvor,"sovortbv",it,vortrd(:,:,jpvor_bev),ndimvor1,ndexvor1) ! beta.V + CALL histwrite( nidvor,"sovowind",it,vortrd(:,:,jpvor_swf),ndimvor1,ndexvor1) ! wind stress + CALL histwrite( nidvor,"sovobfri",it,vortrd(:,:,jpvor_bfr),ndimvor1,ndexvor1) ! bottom friction + CALL histwrite( nidvor,"1st_mbre",it,REAL(vor_avrtot,dp) ,ndimvor1,ndexvor1) ! First membre + CALL histwrite( nidvor,"sovorgap",it,REAL(vor_avrres,dp) ,ndimvor1,ndexvor1) ! gap between 1st and 2 nd mbre + ! + IF( ndebug /= 0 ) THEN + WRITE(numout,*) ' debuging trd_vor: III.4 done' + CALL FLUSH(numout) + ENDIF + ! + ENDIF + ! + IF( MOD( it, nn_trd ) == 0 ) rotot(:,:)=0 + ! + IF( kt == nitend ) CALL histclo( nidvor ) + ! + END SUBROUTINE trd_vor_iom + + + SUBROUTINE trd_vor_init + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_vor_init *** + !! + !! ** Purpose : computation of vertically integrated T and S budgets + !! from ocean surface down to control surface (NetCDF output) + !!---------------------------------------------------------------------- + REAL(dp) :: zjulian, zsto, zout + CHARACTER (len=40) :: clhstnam + CHARACTER (len=40) :: clop + !!---------------------------------------------------------------------- + + ! =================== + ! I. initialization + ! =================== + + cvort='averaged-vor' + + ! Open specifier + ndebug = 0 ! set it to 1 in case of problem to have more Print + + IF(lwp) THEN + WRITE(numout,*) ' ' + WRITE(numout,*) ' trd_vor_init: vorticity trends' + WRITE(numout,*) ' ~~~~~~~~~~~~' + WRITE(numout,*) ' ' + WRITE(numout,*) ' ##########################################################################' + WRITE(numout,*) ' CAUTION: The interpretation of the vorticity trends is' + WRITE(numout,*) ' not obvious, please contact Anne-Marie TREGUIER at: treguier@ifremer.fr ' + WRITE(numout,*) ' ##########################################################################' + WRITE(numout,*) ' ' + ENDIF + + IF( trd_vor_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trd_vor_init : unable to allocate trdvor arrays' ) + + + ! cumulated trends array init + nmoydpvor = 0 + rotot(:,:)=0 + vor_avrtot(:,:)=0 + vor_avrres(:,:)=0 + + IF( ndebug /= 0 ) THEN + WRITE(numout,*) ' debuging trd_vor_init: I. done' + CALL FLUSH(numout) + ENDIF + + ! ================================= + ! II. netCDF output initialization + ! ================================= + + !----------------------------------------- + ! II.1 Define frequency of output and means + ! ----------------------------------------- + IF( ln_mskland ) THEN ; clop = "only(x)" ! put 1.e+20 on land (very expensive!!) + ELSE ; clop = "x" ! no use of the mask value (require less cpu time) + ENDIF +#if defined key_diainstant + zsto = nn_write*rn_Dt + clop = "inst("//TRIM(clop)//")" +#else + zsto = rn_Dt + clop = "ave("//TRIM(clop)//")" +#endif + zout = nn_trd*rn_Dt + + IF(lwp) WRITE(numout,*) ' netCDF initialization' + + ! II.2 Compute julian date from starting date of the run + ! ------------------------ + CALL ymds2ju( nyear, nmonth, nday, REAL(rn_Dt,dp), zjulian ) + zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment + IF(lwp) WRITE(numout,*)' ' + IF(lwp) WRITE(numout,*)' Date 0 used :',nit000, & + & ' YEAR ', nyear,' MONTH ' , nmonth, & + & ' DAY ' , nday, 'Julian day : ', zjulian + + ! II.3 Define the T grid trend file (nidvor) + ! --------------------------------- + CALL dia_nam( clhstnam, nn_trd, 'vort' ) ! filename + IF(lwp) WRITE(numout,*) ' Name of NETCDF file ', clhstnam + CALL histbeg( clhstnam, jpi, REAL(glamf,dp), jpj, REAL(gphif,dp),1, jpi, & ! Horizontal grid : glamt and gphit + & 1, jpj, nit000-1, zjulian, REAL(rn_Dt,dp), nh_t, nidvor, domain_id=nidom, snc4chunks=snc4set ) + CALL wheneq( jpi*jpj, fmask, 1, 1., ndexvor1, ndimvor1 ) ! surface + + ! Declare output fields as netCDF variables + CALL histdef( nidvor, "sovortPh", cvort//"grad Ph" , "s-2", & ! grad Ph + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovortEk", cvort//"Energy", "s-2", & ! Energy + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovozeta", cvort//"rel vorticity", "s-2", & ! rel vorticity + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovortif", cvort//"coriolis", "s-2", & ! coriolis + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovodifl", cvort//"lat diff ", "s-2", & ! lat diff + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovoadvv", cvort//"vert adv", "s-2", & ! vert adv + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovodifv", cvort//"vert diff" , "s-2", & ! vert diff + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovortPs", cvort//"grad Ps", "s-2", & ! grad Ps + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovortbv", cvort//"Beta V", "s-2", & ! beta.V + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovowind", cvort//"wind stress", "s-2", & ! wind stress + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovobfri", cvort//"bottom friction", "s-2", & ! bottom friction + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "1st_mbre", cvort//"1st mbre", "s-2", & ! First membre + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histdef( nidvor, "sovorgap", cvort//"gap", "s-2", & ! gap between 1st and 2 nd mbre + & jpi,jpj,nh_t,1,1,1,-99,32,clop,zsto,zout) + CALL histend( nidvor, snc4set ) + + IF( ndebug /= 0 ) THEN + WRITE(numout,*) ' debuging trd_vor_init: II. done' + CALL FLUSH(numout) + ENDIF + ! + END SUBROUTINE trd_vor_init + + !!====================================================================== +END MODULE trdvor diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdvor_oce.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdvor_oce.F90 new file mode 100644 index 0000000..273c09c --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/TRD/trdvor_oce.F90 @@ -0,0 +1,34 @@ +MODULE trdvor_oce + !!====================================================================== + !! *** MODULE trdvor_oce *** + !! Ocean trends : set vorticity trend variables + !!====================================================================== + !! History : 1.0 ! 04-2006 (L. Brunier, A-M. Treguier) Original code + !!---------------------------------------------------------------------- + + USE par_oce ! ocean parameters + + IMPLICIT NONE + PRIVATE + + ! !!* vorticity trends index + INTEGER, PUBLIC, PARAMETER :: jpltot_vor = 11 !: Number of vorticity trend terms + ! + INTEGER, PUBLIC, PARAMETER :: jpvor_prg = 1 !: Pressure Gradient Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_keg = 2 !: KE Gradient Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_rvo = 3 !: Relative Vorticity Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_pvo = 4 !: Planetary Vorticity Term Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_ldf = 5 !: Horizontal Diffusion Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_zad = 6 !: Vertical Advection Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_zdf = 7 !: Vertical Diffusion Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_spg = 8 !: Surface Pressure Grad. Trend + INTEGER, PUBLIC, PARAMETER :: jpvor_bev = 9 !: Beta V + INTEGER, PUBLIC, PARAMETER :: jpvor_swf = 10 !: wind stress forcing term + INTEGER, PUBLIC, PARAMETER :: jpvor_bfr = 11 !: bottom friction term + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trdvor_oce.F90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trdvor_oce \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/README.rst b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/README.rst new file mode 100644 index 0000000..1560de3 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/README.rst @@ -0,0 +1,283 @@ +****************************** +Setting up a new configuration +****************************** + +.. todo:: + + + +.. contents:: + :local: + +Starting from an existing configuration +======================================= + +There are three options to build a new configuration from an existing one. + +Option 1: Duplicate an existing configuration +--------------------------------------------- + +The NEMO so-called Reference Configurations cover a number of major features for NEMO setup +(global, regional, 1D, using embedded zoom with AGRIF...) + +One can create a new configuration by duplicating one of the reference configurations +(``ORCA2_ICE_PISCES`` in the following example) + +.. code-block:: console + + $ ./makenemo –n 'ORCA2_ICE_PISCES_MINE' -r 'ORCA2_ICE_PISCES' -m 'my_arch' + +Option 2: Duplicate with differences +------------------------------------ + +Create and compile a new configuration based on a reference configuration +(``ORCA2_ICE_PISCES`` in the following example) but with different pre-processor options. +For this either add ``add_key`` or ``del_key`` keys as required; e.g. + +.. code-block:: console + + $ ./makenemo –n 'ORCA2_ICE_PISCES_MINE' -r 'ORCA2_ICE_PISCES' -m 'my_arch' del_key 'key_xios' add_key 'key_diahth' + +Option 3: Use the SIREN tools to subset an existing model +--------------------------------------------------------- + +Define a regional configuration which is a {sub,super}-set of an existing configuration. + +This last option employs the SIREN software tools that are included in the standard distribution. +The software is written in Fortran 95 and available in the :file:`./tools/SIREN` directory. +SIREN allows you to create your own regional configuration embedded in a wider one. + +SIREN is a set of programs to create all the input files you need to +run a NEMO regional configuration. + +:Demo: Set of GLORYS files (GLObal ReanalYSis on the ORCA025 grid), + as well as examples of namelists are available `here`_. +:Doc: :forge:`chrome/site/doc/SIREN/html/index.html` +:Support: Any questions or comments regarding the use of SIREN should be posted in + :forge:`the corresponding forum `. + +.. _here: https://prodn.idris.fr/thredds/catalog/ipsl_public/rron463/catalog.html + +Option 4: Use the nesting tools to create embedded zooms or regional configurations from an existing grid +--------------------------------------------------------------------------------------------------------- +(see :download:`NESTING README <../../../tools/NESTING/README>`). + + +Creating a completely new configuration +======================================= + +From NEMO version 4.0 there are two ways to build configurations from scratch. +The appropriate method to use depends largely on the target configuration. +Method 1 is for more complex/realistic global or regional configurations and +method 2 is intended for simpler, idealised configurations whose +domains and characteristics can be described in simple geometries and formulae. + +Option 1: Create and use a domain configuration file +---------------------------------------------------- + +This method is used by each of the reference configurations, +so that downloading their input files linked to their description can help. +Although starting from scratch, +it is advisable to create the directory structure to house your new configuration by +duplicating the closest reference configuration to your target application. +For example, if your application requires both ocean ice and passive tracers, +then use the ``ORCA2_ICE_PISCES`` as template, +and execute following command to build your ``MY_NEW_CONFIG`` configuration: + +.. code-block:: sh + + $ ./makenemo –n 'MY_NEW_CONFIG' -r 'ORCA2_ICE_PISCES' -m 'my_arch' + +where ``MY_NEW_CONFIG`` can be substituted with +a suitably descriptive name for your new configuration. + +The purpose of this step is simply to create and populate the appropriate :file:`WORK`, +:file:`MY_SRC` and :file:`EXP00` subdirectories for your new configuration. +Other choices for the base reference configuration might be + +:GYRE: If your target application is ocean-only +:AMM12: If your target application is regional with open boundaries + +All the domain information for your new configuration will be contained within +a netcdf file called :file:`domain_cfg.nc` which you will need to create and +place in the :file:`./cfgs/MY_NEW_CONFIG/EXP00` sub-directory. +Firstly though, ensure that your configuration is set to use such a file by checking that + +.. code-block:: fortran + + ln_read_cfg = .true. + +in :file:`./cfgs/MY_NEW_CONFIG/EXP00/namelist_cfg` + +Create the :file:`domain_cfg.nc` file which must contain the following fields + +.. code-block:: c + + /* configuration name, configuration resolution */ + int ORCA, ORCA_index + /* lateral global domain b.c. */ + int Iperio, Jperio, NFoldT, NFoldF + /* flags for z-coord, z-coord with partial steps and s-coord */ + int ln_zco, ln_zps, ln_sco + /* flag for ice shelf cavities */ + int ln_isfcav + /* geographic position */ + double glamt, glamu, glamv, glamf + /* geographic position */ + double gphit, gphiu, gphiv, gphif + /* Coriolis parameter (if not on the sphere) */ + double iff, ff_f, ff_t + /* horizontal scale factors */ + double e1t, e1u, e1v, e1f + /* horizontal scale factors */ + double e2t, e2u, e2v, e2f + /* U and V surfaces (if grid size reduction in some straits) */ + double ie1e2u_v, e1e2u, e1e2v + /* reference vertical scale factors at T and W points */ + double e3t_1d, e3w_1d + /* vertical scale factors 3D coordinate at T,U,V,F and W points */ + double e3t_0, e3u_0, e3v_0, e3f_0, e3w_0 + /* vertical scale factors 3D coordinate at UW and VW points */ + double e3uw_0, e3vw_0 + /* last wet T-points, 1st wet T-points (for ice shelf cavities) */ + int bottom_level, top_level + +There are two options for creating a :file:`domain_cfg.nc` file: + +- Users can use tools of their own choice to build a :file:`domain_cfg.nc` with all mandatory fields. +- Users can adapt and apply the supplied tool available in :file:`./tools/DOMAINcfg`. + This tool is based on code extracted from NEMO version 3.6 and will allow similar choices for + the horizontal and vertical grids that were available internally to that version. + See :ref:`tools ` for details. + +Option 2: Adapt the usr_def configuration module of NEMO for you own purposes +----------------------------------------------------------------------------- + +This method is intended for configuring easily simple/idealised configurations which +are often used as demonstrators or for process evaluation and comparison. +This method can be used whenever the domain geometry has a simple mathematical description and +the ocean initial state and boundary forcing is described analytically. +As a start, consider the case of starting a completely new ocean-only test case based on +the ``LOCK_EXCHANGE`` example. + +.. note:: + + We probably need an even more basic example than this with only one namelist and + minimal changes to the usrdef modules + +Firstly, construct the directory structure, starting in the :file:`cfgs` directory: + +.. code-block:: console + + $ ./makenemo -n 'MY_NEW_TEST' -t 'LOCK_EXCHANGE' -m 'my_arch' + +where the ``-t`` option has been used to locate the new configuration in +the :file:`tests` subdirectory +(it is recommended practice to keep full configurations and idealised cases clearly distinguishable). +This command will create (amongst others) the following files and directories:: + + ./tests/MY_NEW_TEST: + BLD EXP00 MY_SRC WORK cpp_MY_NEW_TEST.fcm + + ./tests/MY_NEW_TEST/EXP00: + context_nemo.xml domain_def_nemo.xml field_def_nemo-oce.xml file_def_nemo-oce.xml iodef.xml + namelist_cfg namelist_ref + + ./tests/MY_NEW_TEST/MY_SRC: + usrdef_hgr.F90 usrdef_nam.F90 usrdef_zgr.F90 usrdef_istate.F90 usrdef_sbc.F90 zdfini.F90 + +The key to setting up an idealised configuration lies in +adapting a small set of short Fortran 90 modules which +should be dropped into the :file:`MY_SRC` directory. +Here the ``LOCK_EXCHANGE`` example is using 5 such routines but the full set that is available in +the :file:`src/OCE/USR` directory is:: + + ./src/OCE/USR: + usrdef_closea.F90 usrdef_fmask.F90 usrdef_hgr.F90 usrdef_istate.F90 + usrdef_nam.F90 usrdef_sbc.F90 usrdef_zgr.F90 + +Before discussing these in more detail it is worth noting the various namelist controls that +engage the different user-defined aspects. +These controls are set using two new logical switches or are implied by the settings of existing ones. +For example, the mandatory requirement for an idealised configuration is to provide routines which +define the horizontal and vertical domains. +Templates for these are provided in the :file:`usrdef_hgr.F90` and :file:`usrdef_zgr.F90` modules. +The application of these modules is activated whenever: + +.. code-block:: fortran + + ln_read_cfg = .false. + +in any configuration's :file:`namelist_cfg` file. +This setting also activates the reading of an optional ``&nam_usrdef`` namelist which can be used to +supply configuration specific settings. +These need to be declared and read in the :file:`usrdef_nam.F90` module. + +Another explicit control is available in the ``&namsbc`` namelist which +activates the use of analytical forcing. +With + +.. code-block:: fortran + + ln_usr = .true. + +Other usrdef modules are activated by less explicit means. +For example, code in :file:`usrdef_istate.F90` is used to +define initial temperature and salinity fields if + +.. code-block:: fortran + + ln_tsd_init = .false. + +in the ``&namtsd`` namelist. +The remaining modules, namely :file:`usrdef_closea.F90` :file:`usrdef_fmask.F90` are specific to +ORCA configurations and set local variations of some specific fields for +the various resolutions of the global models. +They do not need to be considered here in the context of idealised cases but +it is worth noting that all configuration specific code has now been isolated in the usrdef modules. +In the case of these last two modules, they are activated only if an ORCA configuration is detected. +Currently, +this requires a specific integer variable named ``ORCA`` to be set in a :file:`domain_cfg.nc` file. + +.. note:: + + This would be less confusing if the ``cn_cfg`` string is read directly as + a character attribue from the :file:`domain_cfg.nc`. + +So, in most cases, the set up of idealised model configurations can be completed by +copying the template routines from :file:`./src/OCE/USR` into +your new :file:`./cfgs/MY_NEW_TEST/MY_SRC` directory and +editing the appropriate modules as needed. +The default set are those used for the GYRE reference configuration. +The contents of :file:`MY_SRC` directories from other idealised configurations may provide +more convenient templates if they share common characteristics with your target application. + +Whatever the starting point, +it should not require too many changes or additional lines of code to produce routines in +:file:`./src/OCE/USR` that define analytically the domain, +the initial state and the surface boundary conditions for your new configuration. + +To summarize, the base set of modules is: + +:usrdef_hgr.F90: Define horizontal grid +:usrdef_zgr.F90: Define vertical grid +:usrdef_sbc.F90: Provides at each time-step the surface boundary condition, + i.e. the momentum, heat and freshwater fluxes +:usrdef_istate.F90: Defines initialization of the dynamics and tracers +:usrdef_nam.F90: Configuration-specific namelist processing to + set any associated run-time parameters + +with two specialised ORCA modules +(not related to idealised configurations but used to isolate configuration specific code that +is used in ORCA2 reference configurations and established global configurations using +the ORCA tripolar grid): + +:usrdef_fmask.F90: only used in ORCA configurations for + alteration of f-point land/ocean mask in some straits +:usrdef_closea.F90: only used in ORCA configurations for + specific treatments associated with closed seas + +From version 4.0, the NEMO release includes a :file:`tests` subdirectory containing available and +up to date :doc:`test cases ` build by the community. +These will not be fully supported as are NEMO reference configurations, +but should provide a source of raw material. diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_fmask.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_fmask.F90 new file mode 100644 index 0000000..b8b43fb --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_fmask.F90 @@ -0,0 +1,160 @@ +MODULE usrdef_fmask + !!====================================================================== + !! *** MODULE usrdef_fmask *** + !! + !! === ORCA configuration === + !! (2 and 1 degrees) + !! + !! User defined : alteration of land/sea f-point mask in some straits + !!====================================================================== + !! History : 4.0 ! 2016-06 (G. Madec, S. Flavoni) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_fmask : alteration of f-point land/ocean mask in some straits + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! Massively Parallel Processing library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_fmask ! routine called by dommsk.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_fmask.F90 13435 2020-08-25 14:48:42Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_fmask( cd_cfg, kcfg, pfmsk ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_msk *** + !! + !! ** Purpose : User defined alteration of the lateral boundary + !! condition on velocity. + !! + !! ** Method : Local change of the value of fmask at lateral ocean/land + !! boundary in straits in order to increase the viscous + !! boundary layer and thus reduce the transport through the + !! corresponding straits. + !! Here only alterations in ORCA R2 and R1 cases + !! + !! ** Action : fmask : land/ocean mask at f-point with increased value + !! in some user defined straits + !!---------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cd_cfg ! configuration name + INTEGER , INTENT(in ) :: kcfg ! configuration identifier + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pfmsk ! Ocean/Land f-point mask including lateral boundary cond. + ! + INTEGER :: iif, iil, ii0, ii1, ii ! local integers + INTEGER :: ijf, ijl, ij0, ij1 ! - - + INTEGER :: isrow ! index for ORCA1 starting row + !!---------------------------------------------------------------------- + ! + IF( TRIM( cd_cfg ) == "orca" .OR. TRIM( cd_cfg ) == "ORCA" ) THEN !== ORCA Configurations ==! + ! + SELECT CASE ( kcfg ) + ! + CASE( 2 ) ! R2 case + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_fmask : ORCA_R2: increase lateral friction near the following straits:' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' + ! + IF(lwp) WRITE(numout,*) ' Gibraltar ' + ij0 = 101 + nn_hls ; ij1 = 101 + nn_hls ! Gibraltar strait : partial slip (pfmsk=0.5) + ii0 = 139 + nn_hls - 1 ; ii1 = 140 + nn_hls - 1 + pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp + ij0 = 102 + nn_hls ; ij1 = 102 + nn_hls + ii0 = 139 + nn_hls - 1 ; ii1 = 140 + nn_hls - 1 + pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp + ! + IF(lwp) WRITE(numout,*) ' Bab el Mandeb ' + ij0 = 87 + nn_hls ; ij1 = 88 + nn_hls ! Bab el Mandeb : partial slip (pfmsk=1) + ii0 = 160 + nn_hls - 1 ; ii1 = 160 + nn_hls - 1 + pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp + ij0 = 88 + nn_hls ; ij1 = 88 + nn_hls + ii0 = 159 + nn_hls - 1 ; ii1 = 159 + nn_hls - 1 + pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp + ! + ! We keep this as an example but it is instable in this case + !IF(lwp) WRITE(numout,*) ' Danish straits ' + ! ij0 = 115 ; ij1 = 115 ! Danish straits : strong slip (pfmsk > 2) + ! ii0 = 145 ; ii1 = 146 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 4._wp + ! ij0 = 116 ; ij1 = 116 + ! ii0 = 145 ; ii1 = 146 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 4._wp + ! + CASE( 1 ) ! R1 case + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_fmask : ORCA_R1: increase lateral friction near the following straits:' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' +!!gm ! This dirty section will be suppressed by simplification process: +!!gm ! all this will come back in input files +!!gm ! Currently these hard-wired indices relate to configuration with extend grid (jpjglo=332) + ! + isrow = 332 - (Nj0glo + 1) ! was 332 - jpjglo -> jpjglo_old_version = Nj0glo + 1 + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' orca_r1: increase friction near the following straits : ' + IF(lwp) WRITE(numout,*) ' Gibraltar ' + ii0 = 282 + nn_hls - 1 ; ii1 = 283 + nn_hls - 1 ! Gibraltar Strait + ij0 = 241 + nn_hls - isrow ; ij1 = 241 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' Bhosporus ' + ii0 = 314 + nn_hls - 1 ; ii1 = 315 + nn_hls - 1 ! Bhosporus Strait + ij0 = 248 + nn_hls - isrow ; ij1 = 248 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' Makassar (Top) ' + ii0 = 48 + nn_hls - 1 ; ii1 = 48 + nn_hls - 1 ! Makassar Strait (Top) + ij0 = 189 + nn_hls - isrow ; ij1 = 190 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp + ! + IF(lwp) WRITE(numout,*) ' Lombok ' + ii0 = 44 + nn_hls - 1 ; ii1 = 44 + nn_hls - 1 ! Lombok Strait + ij0 = 164 + nn_hls - isrow ; ij1 = 165 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' Ombai ' + ii0 = 53 + nn_hls - 1 ; ii1 = 53 + nn_hls - 1 ! Ombai Strait + ij0 = 164 + nn_hls - isrow ; ij1 = 165 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' Timor Passage ' + ii0 = 56 + nn_hls - 1 ; ii1 = 56 + nn_hls - 1 ! Timor Passage + ij0 = 164 + nn_hls - isrow ; ij1 = 165 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' West Halmahera ' + ii0 = 58 + nn_hls - 1 ; ii1 = 58 + nn_hls - 1 ! West Halmahera Strait + ij0 = 181 + nn_hls - isrow ; ij1 = 182 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp + ! + IF(lwp) WRITE(numout,*) ' East Halmahera ' + ii0 = 55 + nn_hls - 1 ; ii1 = 55 + nn_hls - 1 ! East Halmahera Strait + ij0 = 181 + nn_hls - isrow ; ij1 = 182 + nn_hls - isrow + pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp + ! + CASE DEFAULT + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_fmask : ORCA_R', kcfg,' : NO alteration of fmask in specific straits ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' + END SELECT + ELSE + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_fmask : NO alteration of fmask in specific straits ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + ! + CALL lbc_lnk( 'usrdef_fmask', pfmsk, 'F', 1._wp ) ! Lateral boundary conditions on fmask + ! + END SUBROUTINE usr_def_fmask + + !!====================================================================== +END MODULE usrdef_fmask \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_hgr.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_hgr.F90 new file mode 100644 index 0000000..9359175 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_hgr.F90 @@ -0,0 +1,175 @@ +MODULE usrdef_hgr + !!====================================================================== + !! *** MODULE usrdef_hgr *** + !! + !! === GYRE configuration === + !! + !! User defined : mesh and Coriolis parameter of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_hgr : initialize the horizontal mesh + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + USE usrdef_nam ! + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_hgr ! called in domhgr.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_hgr.F90 14223 2020-12-19 10:22:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_hgr( plamt , plamu , plamv , plamf , & ! geographic position (required) + & pphit , pphiu , pphiv , pphif , & ! + & kff , pff_f , pff_t , & ! Coriolis parameter (if domain not on the sphere) + & pe1t , pe1u , pe1v , pe1f , & ! scale factors (required) + & pe2t , pe2u , pe2v , pe2f , & ! + & ke1e2u_v , pe1e2u , pe1e2v ) ! u- & v-surfaces (if gridsize reduction is used in strait(s)) + !!---------------------------------------------------------------------- + !! *** ROUTINE usr_def_hgr *** + !! + !! ** Purpose : user defined mesh and Coriolis parameter + !! + !! ** Method : set all intent(out) argument to a proper value + !! + !! Here GYRE configuration : + !! Rectangular mid-latitude domain + !! - with axes rotated by 45 degrees + !! - a constant horizontal resolution of 106 km + !! - on a beta-plane + !! + !! ** Action : - define longitude & latitude of t-, u-, v- and f-points (in degrees) + !! - define coriolis parameter at f-point if the domain in not on the sphere (on beta-plane) + !! - define i- & j-scale factors at t-, u-, v- and f-points (in meters) + !! - define u- & v-surfaces (if gridsize reduction is used in some straits) (in m2) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), INTENT(out) :: plamt, plamu, plamv, plamf ! longitude outputs [degrees] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pphit, pphiu, pphiv, pphif ! latitude outputs [degrees] + INTEGER , INTENT(out) :: kff ! =1 Coriolis parameter computed here, =0 otherwise + REAL(wp), DIMENSION(:,:), INTENT(out) :: pff_f, pff_t ! Coriolis factor at f-point [1/s] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1v! i-scale factors [m] + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe1t, pe1u, pe1f! i-scale factors [m] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe2u! j-scale factors [m] + REAL(dp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2v, pe2f! j-scale factors [m] + INTEGER , INTENT(out) :: ke1e2u_v ! =1 u- & v-surfaces computed here, =0 otherwise + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if reduction in strait) [m2] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zlam1, zlam0, zcos_alpha, zim1 , zjm1 , ze1 , ze1deg, zf0 ! local scalars + REAL(wp) :: zphi1, zphi0, zsin_alpha, zim05, zjm05, zbeta, znorme ! - - + !!------------------------------------------------------------------------------- + ! + ! !== beta-plane with regular grid-spacing and rotated domain ==! (GYRE configuration) + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_hgr : GYRE configuration (beta-plane with rotated regular grid-spacing)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ! + ! !== grid point position ==! + ! + zlam1 = -85._wp ! position of gridpoint (i,j) = (1,jpjglo) + zphi1 = 29._wp + ! + ze1 = 106000._wp / REAL( nn_GYRE , wp ) ! gridspacing in meters + ! + zsin_alpha = - SQRT( 2._wp ) * 0.5_wp ! angle: 45 degrees + zcos_alpha = SQRT( 2._wp ) * 0.5_wp + ze1deg = ze1 / (ra * rad) + zlam0 = zlam1 + zcos_alpha * ze1deg * REAL( Ni0glo - 2, wp ) + zphi0 = zphi1 + zsin_alpha * ze1deg * REAL( Nj0glo - 2, wp ) + +#if defined key_agrif + ! ! Upper left longitude and latitude from parent: + ! Laurent: Should be modify in case of an east-west cyclic parent grid + IF (.NOT.Agrif_root()) THEN + zlam0 = zlam1 + Agrif_irhox() * REAL(Agrif_Parent(Ni0glo) -2, wp) * ze1deg * zcos_alpha & + & + ( Agrif_Ix()*Agrif_irhox()-(0.5_wp+nbghostcells)) * ze1deg * zcos_alpha & + & + ( Agrif_Iy()*Agrif_irhoy()-(0.5_wp+nbghostcells)) * ze1deg * zsin_alpha + zphi0 = zphi1 + Agrif_irhoy() * REAL(Agrif_Parent(Nj0glo) -2, wp) * ze1deg * zsin_alpha & + & - ( Agrif_Ix()*Agrif_irhox()-nbghostcells ) * ze1deg * zsin_alpha & + & + ( Agrif_Iy()*Agrif_irhoy()-nbghostcells ) * ze1deg * zcos_alpha + ENDIF +#endif + ! + IF( ln_bench ) THEN ! benchmark: forced the resolution to be 106 km + ze1 = 106000._wp ! but keep (lat,lon) at the right nn_GYRE resolution + CALL ctl_warn( ' GYRE used as Benchmark: e1=e2=106km, no need to adjust rn_Dt, ahm,aht ' ) + ENDIF + IF( lwp ) THEN + WRITE(numout,*) 'ze1', ze1, 'cosalpha', zcos_alpha, 'sinalpha', zsin_alpha + WRITE(numout,*) 'ze1deg', ze1deg, 'zlam0', zlam0, 'zphi0', zphi0 + ENDIF + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + zim1 = REAL( mig0(ji), wp ) - 1. ; zim05 = REAL( mig0(ji), wp ) - 1.5 + zjm1 = REAL( mjg0(jj), wp ) - 1. ; zjm05 = REAL( mjg0(jj), wp ) - 1.5 + ! + !glamt(i,j) longitude at T-point + !gphit(i,j) latitude at T-point + plamt(ji,jj) = zlam0 + zim05 * ze1deg * zcos_alpha + zjm05 * ze1deg * zsin_alpha + pphit(ji,jj) = zphi0 - zim05 * ze1deg * zsin_alpha + zjm05 * ze1deg * zcos_alpha + ! + !glamu(i,j) longitude at U-point + !gphiu(i,j) latitude at U-point + plamu(ji,jj) = zlam0 + zim1 * ze1deg * zcos_alpha + zjm05 * ze1deg * zsin_alpha + pphiu(ji,jj) = zphi0 - zim1 * ze1deg * zsin_alpha + zjm05 * ze1deg * zcos_alpha + ! + !glamv(i,j) longitude at V-point + !gphiv(i,j) latitude at V-point + plamv(ji,jj) = zlam0 + zim05 * ze1deg * zcos_alpha + zjm1 * ze1deg * zsin_alpha + pphiv(ji,jj) = zphi0 - zim05 * ze1deg * zsin_alpha + zjm1 * ze1deg * zcos_alpha + ! + !glamf(i,j) longitude at F-point + !gphif(i,j) latitude at F-point + plamf(ji,jj) = zlam0 + zim1 * ze1deg * zcos_alpha + zjm1 * ze1deg * zsin_alpha + pphif(ji,jj) = zphi0 - zim1 * ze1deg * zsin_alpha + zjm1 * ze1deg * zcos_alpha + END_2D + ! + ! !== Horizontal scale factors ==! (in meters) + ! + ! ! constant grid spacing + pe1t(:,:) = ze1 ; pe2t(:,:) = ze1 + pe1u(:,:) = ze1 ; pe2u(:,:) = ze1 + pe1v(:,:) = ze1 ; pe2v(:,:) = ze1 + pe1f(:,:) = ze1 ; pe2f(:,:) = ze1 + ! + ! ! NO reduction of grid size in some straits + ke1e2u_v = 0 ! ==>> u_ & v_surfaces will be computed in dom_ghr routine + pe1e2u(:,:) = 0._wp ! CAUTION: set to zero to avoid error with some compilers that + pe1e2v(:,:) = 0._wp ! require an initialization of INTENT(out) arguments + ! + ! + ! !== Coriolis parameter ==! + kff = 1 ! indicate not to compute ff afterward + ! + zbeta = 2. * omega * COS( rad * zphi1 ) / ra ! beta at latitude zphi1 + !SF we overwrite zphi0 (south point in latitude) used just above to define pphif (value of zphi0=15.5190567531966) + !SF for computation of Coriolis we keep the parameter of Hazeleger, W., and S. S. Drijfhout, JPO 1998. + zphi0 = 15._wp ! latitude of the most southern grid point + zf0 = 2. * omega * SIN( rad * zphi0 ) ! compute f0 1st point south + ! + pff_f(:,:) = ( zf0 + zbeta * ABS( pphif(:,:) - zphi0 ) * rad * ra ) ! f = f0 +beta* y ( y=0 at south) + pff_t(:,:) = ( zf0 + zbeta * ABS( pphit(:,:) - zphi0 ) * rad * ra ) ! f = f0 +beta* y ( y=0 at south) + ! + IF(lwp) WRITE(numout,*) ' beta-plane used. beta = ', zbeta, ' 1/(s.m)' + ! + END SUBROUTINE usr_def_hgr + + !!====================================================================== +END MODULE usrdef_hgr \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_istate.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_istate.F90 new file mode 100644 index 0000000..fde9ea5 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_istate.F90 @@ -0,0 +1,105 @@ +MODULE usrdef_istate + !!====================================================================== + !! *** MODULE usrdef_istate *** + !! + !! === GYRE configuration === + !! + !! User defined : set the initial state of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni) Original code + !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_istate : initial state in Temperature and salinity + !!---------------------------------------------------------------------- + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_istate ! called in istate.F90 + PUBLIC usr_def_istate_ssh ! called by domqco.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_istate.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE usr_def_istate *** + !! + !! ** Purpose : Initialization of the dynamics and tracers + !! Here GYRE configuration example : (double gyre with rotated domain) + !! + !! ** Method : - set temprature field + !! - set salinity field + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pdept ! depth of t-point [m] + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pts ! T & S fields [Celsius ; g/kg] + REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] + REAL(dp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate : analytical definition of initial state ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ Ocean at rest, with an horizontally uniform T and S profiles' + ! + pu (:,:,:) = 0._wp ! ocean at rest + pv (:,:,:) = 0._wp + ! + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) ! horizontally uniform T & S profiles + pts(ji,jj,jk,jp_tem) = ( ( 16. - 12. * TANH( (pdept(ji,jj,jk) - 400) / 700 ) ) & + & * (-TANH( (500. - pdept(ji,jj,jk)) / 150. ) + 1.) / 2. & + & + ( 15. * ( 1. - TANH( (pdept(ji,jj,jk)-50.) / 1500.) ) & + & - 1.4 * TANH((pdept(ji,jj,jk)-100.) / 100.) & + & + 7. * (1500. - pdept(ji,jj,jk) ) / 1500.) & + & * (-TANH( (pdept(ji,jj,jk) - 500.) / 150.) + 1.) / 2. ) * ptmask(ji,jj,jk) + + pts(ji,jj,jk,jp_sal) = ( ( 36.25 - 1.13 * TANH( (pdept(ji,jj,jk) - 305) / 460 ) ) & + & * (-TANH((500. - pdept(ji,jj,jk)) / 150.) + 1.) / 2 & + & + ( 35.55 + 1.25 * (5000. - pdept(ji,jj,jk)) / 5000. & + & - 1.62 * TANH( (pdept(ji,jj,jk) - 60. ) / 650. ) & + & + 0.2 * TANH( (pdept(ji,jj,jk) - 35. ) / 100. ) & + & + 0.2 * TANH( (pdept(ji,jj,jk) - 1000.) / 5000.) ) & + & * (-TANH( (pdept(ji,jj,jk) - 500.) / 150.) + 1.) / 2 ) * ptmask(ji,jj,jk) + END_3D + ! + END SUBROUTINE usr_def_istate + + + SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) + !!---------------------------------------------------------------------- + !! *** ROUTINE usr_def_istate_ssh *** + !! + !! ** Purpose : Initialization of ssh + !! + !! ** Method : Set ssh as null, ptmask is required for test cases + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] + REAL(dp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : GYRE configuration, analytical definition of initial state' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~~ Ocean at rest, ssh is zero' + ! + ! Sea level: + pssh(:,:) = 0._wp + ! + END SUBROUTINE usr_def_istate_ssh + + !!====================================================================== +END MODULE usrdef_istate \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_nam.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_nam.F90 new file mode 100644 index 0000000..acd69ec --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_nam.F90 @@ -0,0 +1,112 @@ +MODULE usrdef_nam + !!====================================================================== + !! *** MODULE usrdef_nam *** + !! + !! === GYRE configuration === + !! + !! User defined : set the domain characteristics of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_nam : read user defined namelist and set global domain size + !! usr_def_hgr : initialize the horizontal mesh + !!---------------------------------------------------------------------- + USE dom_oce + USE par_oce ! ocean space and time domain + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_nam ! called in nemogcm.F90 module + + ! !!* namusr_def namelist *!! + LOGICAL, PUBLIC :: ln_bench ! =T benchmark test with gyre: the gridsize is constant (no need to adjust timestep or viscosity) + INTEGER, PUBLIC :: nn_GYRE ! 1/nn_GYRE = the resolution chosen in degrees and thus defining the horizontal domain size + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_nam.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_nam *** + !! + !! ** Purpose : read user defined namelist and define the domain size + !! + !! ** Method : read in namusr_def containing all the user specific namelist parameter + !! + !! Here GYRE configuration + !! + !! ** input : - namusr_def namelist found in namelist_cfg + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name + INTEGER , INTENT(out) :: kk_cfg ! configuration resolution + INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes + LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity + LOGICAL , INTENT(out) :: ldNFold ! North pole folding + CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F + ! + INTEGER :: ios ! Local integer + !! + NAMELIST/namusr_def/ nn_GYRE, ln_bench, jpkglo + !!---------------------------------------------------------------------- + ! + READ ( numnam_cfg, namusr_def, IOSTAT = ios, ERR = 902 ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namusr_def in configuration namelist' ) + ! + IF(lwm) WRITE( numond, namusr_def ) + ! + cd_cfg = 'GYRE' ! name & resolution (not used) +#if defined key_agrif + IF (.NOT.Agrif_root()) nn_GYRE = Agrif_parent(nn_GYRE) * Agrif_irhox() +#endif + kk_cfg = nn_GYRE + ! + kpi = 30 * nn_GYRE + 2 ! + kpj = 20 * nn_GYRE + 2 +#if defined key_agrif + IF( .NOT.Agrif_Root() ) THEN ! Global Domain size: add 1 land point on each side + kpi = nbcellsx + 2 * ( nbghostcells + 1 ) + kpj = nbcellsy + 2 * ( nbghostcells + 1 ) +!!$ kpi = nbcellsx + nbghostcells_x + nbghostcells_x + 2 +!!$ kpj = nbcellsy + nbghostcells_y_s + nbghostcells_y_n + 2 + ENDIF +#endif + kpk = jpkglo + ! ! Set the lateral boundary condition of the global domain + ldIperio = .FALSE. ; ldJperio = .FALSE. ! GYRE configuration : closed domain + ldNFold = .FALSE. ; cdNFtype = '-' + ! + ! ! control print + IF(lwp) THEN + WRITE(numout,*) ' ' + WRITE(numout,*) 'usr_def_nam : read the user defined namelist (namusr_def) in namelist_cfg' + WRITE(numout,*) '~~~~~~~~~~~ ' + WRITE(numout,*) ' Namelist namusr_def : GYRE case' + WRITE(numout,*) ' GYRE used as Benchmark (=T) ln_bench = ', ln_bench + WRITE(numout,*) ' inverse resolution & implied domain size nn_GYRE = ', nn_GYRE +#if defined key_agrif + IF( Agrif_Root() ) THEN +#endif + WRITE(numout,*) ' Ni0glo = 30*nn_GYRE Ni0glo = ', kpi + WRITE(numout,*) ' Nj0glo = 20*nn_GYRE Nj0glo = ', kpj +#if defined key_agrif + ENDIF +#endif + WRITE(numout,*) ' number of model levels jpkglo = ', kpk + WRITE(numout,*) ' ' + ENDIF + ! + END SUBROUTINE usr_def_nam + + !!====================================================================== +END MODULE usrdef_nam \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_sbc.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_sbc.F90 new file mode 100644 index 0000000..6f20cd4 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_sbc.F90 @@ -0,0 +1,236 @@ +MODULE usrdef_sbc + !!====================================================================== + !! *** MODULE usrdef_sbc *** + !! + !! === GYRE configuration === + !! + !! User defined : surface forcing of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usrdef_sbc : user defined surface bounday conditions in GYRE case + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE sbc_oce ! Surface boundary condition: ocean fields + USE phycst ! physical constants + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distribued memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_fortran ! + + IMPLICIT NONE + PRIVATE + + PUBLIC usrdef_sbc_oce ! routine called in sbcmod module + PUBLIC usrdef_sbc_ice_tau ! routine called by icestp.F90 for ice dynamics + PUBLIC usrdef_sbc_ice_flx ! routine called by icestp.F90 for ice thermo + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_sbc.F90 15145 2021-07-26 16:16:45Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usrdef_sbc_oce( kt, Kbb ) + !!--------------------------------------------------------------------- + !! *** ROUTINE usrdef_sbc *** + !! + !! ** Purpose : provide at each time-step the GYRE surface boundary + !! condition, i.e. the momentum, heat and freshwater fluxes. + !! + !! ** Method : analytical seasonal cycle for GYRE configuration. + !! CAUTION : never mask the surface stress field ! + !! + !! ** Action : - set the ocean surface boundary condition, i.e. + !! utau, vtau, taum, wndm, qns, qsr, emp, sfx + !! + !! Reference : Hazeleger, W., and S. Drijfhout, JPO, 30, 677-695, 2000. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: Kbb ! ocean time index + !! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: zyear0 ! initial year + INTEGER :: zmonth0 ! initial month + INTEGER :: zday0 ! initial day + INTEGER :: zday_year0 ! initial day since january 1st + REAL(wp) :: ztau , ztau_sais ! wind intensity and of the seasonal cycle + REAL(wp) :: ztime ! time in hour + REAL(wp) :: ztimemax , ztimemin ! 21th June, and 21th decem. if date0 = 1st january + REAL(wp) :: ztimemax1, ztimemin1 ! 21th June, and 21th decem. if date0 = 1st january + REAL(wp) :: ztimemax2, ztimemin2 ! 21th June, and 21th decem. if date0 = 1st january + REAL(wp) :: ztaun ! intensity + REAL(wp) :: zemp_S, zemp_N, zemp_sais, zTstar + REAL(wp) :: zcos_sais1, zcos_sais2, ztrp, zconv, t_star + REAL(wp) :: zsumemp, zsurf + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: ztx, zty, zmod, zcoef ! temporary variables + REAL(wp) :: zyydd ! number of days in one year + !!--------------------------------------------------------------------- + zyydd = REAL(nyear_len(1),wp) + + ! ---------------------------- ! + ! heat and freshwater fluxes ! + ! ---------------------------- ! + !same temperature, E-P as in HAZELEGER 2000 + + zyear0 = ndate0 / 10000 ! initial year + zmonth0 = ( ndate0 - zyear0 * 10000 ) / 100 ! initial month + zday0 = ndate0 - zyear0 * 10000 - zmonth0 * 100 ! initial day betwen 1 and 30 + zday_year0 = ( zmonth0 - 1 ) * 30.+zday0 ! initial day betwen 1 and 360 + + ! current day (in hours) since january the 1st of the current year + ztime = REAL( kt ) * rn_Dt / (rmmss * rhhmm) & ! total incrementation (in hours) + & - (nyear - 1) * rjjhh * zyydd ! minus years since beginning of experiment (in hours) + + ztimemax1 = ((5.*30.)+21.)* 24. ! 21th june at 24h in hours + ztimemin1 = ztimemax1 + rjjhh * zyydd / 2 ! 21th december in hours + ztimemax2 = ((6.*30.)+21.)* 24. ! 21th july at 24h in hours + ztimemin2 = ztimemax2 - rjjhh * zyydd / 2 ! 21th january in hours + ! ! NB: rjjhh * zyydd / 4 = one seasonal cycle in hours + + ! amplitudes + zemp_S = 0.7 ! intensity of COS in the South + zemp_N = 0.8 ! intensity of COS in the North + zemp_sais = 0.1 + zTstar = 28.3 ! intemsity from 28.3 a -5 deg + + ! 1/2 period between 21th June and 21th December and between 21th July and 21th January + zcos_sais1 = COS( (ztime - ztimemax1) / (ztimemin1 - ztimemax1) * rpi ) + zcos_sais2 = COS( (ztime - ztimemax2) / (ztimemax2 - ztimemin2) * rpi ) + + ztrp= - 40.e0 ! retroaction term on heat fluxes (W/m2/K) + zconv = 3.16e-5 ! convertion factor: 1 m/yr => 3.16e-5 mm/s + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! emp and rnf used in sshwzv over the whole domain + ! domain from 15 deg to 50 deg between 27 and 28 degC at 15N, -3 + ! and 13 degC at 50N 53.5 + or - 11 = 1/4 period : + ! 64.5 in summer, 42.5 in winter + t_star = zTstar * ( 1. + 1. / 50. * zcos_sais2 ) & + & * COS( rpi * (gphit(ji,jj) - 5.) & + & / ( 53.5 * ( 1 + 11 / 53.5 * zcos_sais2 ) * 2.) ) + ! 23.5 deg : tropics + qsr (ji,jj) = 230 * COS( 3.1415 * ( gphit(ji,jj) - 23.5 * zcos_sais1 ) / ( 0.9 * 180 ) ) + qns (ji,jj) = ztrp * ( ts(ji,jj,1,jp_tem,Kbb) - t_star ) - qsr(ji,jj) + IF( gphit(ji,jj) >= 14.845 .AND. 37.2 >= gphit(ji,jj) ) THEN ! zero at 37.8 deg, max at 24.6 deg + emp (ji,jj) = zemp_S * zconv & + & * SIN( rpi / 2 * (gphit(ji,jj) - 37.2) / (24.6 - 37.2) ) & + & * ( 1 - zemp_sais / zemp_S * zcos_sais1) + ELSE + emp (ji,jj) = - zemp_N * zconv & + & * SIN( rpi / 2 * (gphit(ji,jj) - 37.2) / (46.8 - 37.2) ) & + & * ( 1 - zemp_sais / zemp_N * zcos_sais1 ) + ENDIF + END_2D + + zsumemp = GLOB_SUM( 'usrdef_sbc', REAL(emp (:,:),dp) ) + zsurf = GLOB_SUM( 'usrdef_sbc', REAL(tmask(:,:,1),dp) ) + zsumemp = zsumemp / zsurf ! Default GYRE configuration + + ! freshwater (mass flux) and update of qns with heat content of emp + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! emp used in sshwzv over the whole domain + emp (ji,jj) = emp(ji,jj) - zsumemp * tmask(ji,jj,1) ! freshwater flux (=0 in domain average) + sfx (ji,jj) = 0.0_wp ! no salt flux + qns (ji,jj) = qns(ji,jj) - emp(ji,jj) * sst_m(ji,jj) * rcp ! evap and precip are at SST + END_2D + + + ! ---------------------------- ! + ! momentum fluxes ! + ! ---------------------------- ! + ! same wind as in Wico + !test date0 : ndate0 = 010203 + zyear0 = ndate0 / 10000 + zmonth0 = ( ndate0 - zyear0 * 10000 ) / 100 + zday0 = ndate0 - zyear0 * 10000 - zmonth0 * 100 + !Calculates nday_year, day since january 1st + zday_year0 = (zmonth0-1)*30.+zday0 + + !accumulates days of previous months of this year + ! day (in hours) since january the 1st + ztime = FLOAT( kt ) * rn_Dt / (rmmss * rhhmm) & ! incrementation in hour + & - (nyear - 1) * rjjhh * zyydd ! - nber of hours the precedent years + ztimemax = ((5.*30.)+21.)* 24. ! 21th june in hours + ztimemin = ztimemax + rjjhh * zyydd / 2 ! 21th december in hours + ! ! NB: rjjhh * zyydd / 4 = 1 seasonal cycle in hours + + ! mean intensity at 0.105 ; srqt(2) because projected with 45deg angle + ztau = 0.105 / SQRT( 2. ) + ! seasonal oscillation intensity + ztau_sais = 0.015 + ztaun = ztau - ztau_sais * COS( (ztime - ztimemax) / (ztimemin - ztimemax) * rpi ) + DO_2D( 1, 1, 1, 1 ) + ! domain from 15deg to 50deg and 1/2 period along 14deg + ! so 5/4 of half period with seasonal cycle + utau(ji,jj) = - ztaun * SIN( rpi * (gphiu(ji,jj) - 15.) / (29.-15.) ) + vtau(ji,jj) = ztaun * SIN( rpi * (gphiv(ji,jj) - 15.) / (29.-15.) ) + END_2D + + ! module of wind stress and wind speed at T-point + zcoef = 1. / ( zrhoa * zcdrag ) + DO_2D( 0, 0, 0, 0 ) + ztx = utau(ji-1,jj ) + utau(ji,jj) + zty = vtau(ji ,jj-1) + vtau(ji,jj) + zmod = 0.5 * SQRT( ztx * ztx + zty * zty ) + taum(ji,jj) = zmod + wndm(ji,jj) = SQRT( zmod * zcoef ) + END_2D + + ! ---------------------------------- ! + ! control print at first time-step ! + ! ---------------------------------- ! + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*)'usrdef_sbc_oce : analytical surface fluxes for GYRE configuration' + WRITE(numout,*)'~~~~~~~~~~~ ' + WRITE(numout,*)' nyear = ', nyear + WRITE(numout,*)' nmonth = ', nmonth + WRITE(numout,*)' nday = ', nday + WRITE(numout,*)' nday_year = ', nday_year + WRITE(numout,*)' ztime = ', ztime + WRITE(numout,*)' ztimemax = ', ztimemax + WRITE(numout,*)' ztimemin = ', ztimemin + WRITE(numout,*)' ztimemax1 = ', ztimemax1 + WRITE(numout,*)' ztimemin1 = ', ztimemin1 + WRITE(numout,*)' ztimemax2 = ', ztimemax2 + WRITE(numout,*)' ztimemin2 = ', ztimemin2 + WRITE(numout,*)' zyear0 = ', zyear0 + WRITE(numout,*)' zmonth0 = ', zmonth0 + WRITE(numout,*)' zday0 = ', zday0 + WRITE(numout,*)' zday_year0 = ', zday_year0 + WRITE(numout,*)' zyydd = ', zyydd + WRITE(numout,*)' zemp_S = ', zemp_S + WRITE(numout,*)' zemp_N = ', zemp_N + WRITE(numout,*)' zemp_sais = ', zemp_sais + WRITE(numout,*)' zTstar = ', zTstar + WRITE(numout,*)' zsumemp = ', zsumemp + WRITE(numout,*)' zsurf = ', zsurf + WRITE(numout,*)' ztrp = ', ztrp + WRITE(numout,*)' zconv = ', zconv + WRITE(numout,*)' ndastp = ', ndastp + WRITE(numout,*)' adatrj = ', adatrj + ENDIF + ! + END SUBROUTINE usrdef_sbc_oce + + + SUBROUTINE usrdef_sbc_ice_tau( kt ) + INTEGER, INTENT(in) :: kt ! ocean time step + END SUBROUTINE usrdef_sbc_ice_tau + + + SUBROUTINE usrdef_sbc_ice_flx( kt, phs, phi ) + INTEGER, INTENT(in) :: kt ! ocean time step + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness + END SUBROUTINE usrdef_sbc_ice_flx + + !!====================================================================== +END MODULE usrdef_sbc diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_zgr.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_zgr.F90 new file mode 100644 index 0000000..a312a64 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/USR/usrdef_zgr.F90 @@ -0,0 +1,246 @@ +MODULE usrdef_zgr + !!====================================================================== + !! *** MODULE usrdef_zgr *** + !! + !! === GYRE configuration === + !! + !! User defined : vertical coordinate system of a user configuration + !!====================================================================== + !! History : 4.0 ! 2016-06 (G. Madec) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usr_def_zgr : user defined vertical coordinate system + !! zgr_z : reference 1D z-coordinate + !! zgr_top_bot: ocean top and bottom level indices + !! zgr_zco : 3D verticl coordinate in pure z-coordinate case + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce ! ocean domain + USE depth_e3 ! depth <=> e3 + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC usr_def_zgr ! called by domzgr.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: usrdef_zgr.F90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_zgr( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate + & pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate + & pdept , pdepw , & ! 3D t & w-points depth + & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors + & pe3w , pe3uw , pe3vw , & ! - - - + & k_top , k_bot ) ! top & bottom ocean level + !!--------------------------------------------------------------------- + !! *** ROUTINE usr_def_zgr *** + !! + !! ** Purpose : User defined the vertical coordinates + !! + !!---------------------------------------------------------------------- + LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags + LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag + REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3u, pe3v, pe3f! vertical scale factors [m] + REAL(dp), DIMENSION(:,:,:), INTENT(out) :: pe3t! vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! i-scale factors + INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top, k_bot ! first & last ocean level + ! + INTEGER :: inum ! local logical unit + REAL(WP) :: z_zco, z_zps, z_sco, z_cav + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'usr_def_zgr : GYRE configuration (z-coordinate closed flat box ocean without cavities)' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + ! + ! type of vertical coordinate + ! --------------------------- + ld_zco = .TRUE. ! GYRE case: z-coordinate without ocean cavities + ld_zps = .FALSE. + ld_sco = .FALSE. + ld_isfcav = .FALSE. + ! + ! + ! Build the vertical coordinate system + ! ------------------------------------ + CALL zgr_z( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! Reference z-coordinate system + ! + CALL zgr_msk_top_bot( k_top , k_bot ) ! masked top and bottom ocean t-level indices + ! + ! ! z-coordinate (3D arrays) from the 1D z-coord. + CALL zgr_zco( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d, & ! in : 1D reference vertical coordinate + & pdept , pdepw , & ! out : 3D t & w-points depth + & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors + & pe3w , pe3uw , pe3vw ) ! - - - + ! + END SUBROUTINE usr_def_zgr + + + SUBROUTINE zgr_z( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! 1D reference vertical coordinate + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_z *** + !! + !! ** Purpose : set the 1D depth of model levels and the resulting + !! vertical scale factors. + !! + !! ** Method : 1D z-coordinate system (use in all type of coordinate) + !! The depth of model levels is set from dep(k), an analytical function: + !! w-level: depw_1d = dep(k) + !! t-level: dept_1d = dep(k+0.5) + !! The scale factors are the discrete derivative of the depth: + !! e3w_1d(jk) = dk[ dept_1d ] + !! e3t_1d(jk) = dk[ depw_1d ] + !! with at top and bottom : + !! e3w_1d( 1 ) = 2 * ( dept_1d( 1 ) - depw_1d( 1 ) ) + !! e3t_1d(jpk) = 2 * ( dept_1d(jpk) - depw_1d(jpk) ) + !! The depth are then re-computed from the sum of e3. This ensures + !! that depths are identical when reading domain configuration file. + !! Indeed, only e3. are saved in this file, depth are compute by a call + !! to the e3_to_depth subroutine. + !! + !! Here the Madec & Imbard (1996) function is used. + !! + !! ** Action : - pdept_1d, pdepw_1d : depth of T- and W-point (m) + !! - pe3t_1d , pe3w_1d : scale factors at T- and W-levels (m) + !! + !! Reference : Marti, Madec & Delecluse, 1992, JGR, 97, No8, 12,763-12,766. + !! Madec and Imbard, 1996, Clim. Dyn. + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] + ! + INTEGER :: jk ! dummy loop indices + REAL(wp) :: zt, zw ! local scalars + REAL(wp) :: zsur, za0, za1, zkth, zacr ! Values for the Madec & Imbard (1996) function + !!---------------------------------------------------------------------- + ! + ! Set parameters of z(k) function + ! ------------------------------- + zsur = -2033.194295283385_wp + za0 = 155.8325369664153_wp + za1 = 146.3615918601890_wp + zkth = 17.28520372419791_wp + zacr = 5.0_wp + ! + IF(lwp) THEN ! Parameter print + WRITE(numout,*) + WRITE(numout,*) ' zgr_z : Reference vertical z-coordinates ' + WRITE(numout,*) ' ~~~~~~~' + WRITE(numout,*) ' GYRE case : MI96 function with the following coefficients :' + WRITE(numout,*) ' zsur = ', zsur + WRITE(numout,*) ' za0 = ', za0 + WRITE(numout,*) ' za1 = ', za1 + WRITE(numout,*) ' zkth = ', zkth + WRITE(numout,*) ' zacr = ', zacr + ENDIF + + ! + ! 1D Reference z-coordinate (using Madec & Imbard 1996 function) + ! ------------------------- + ! + DO jk = 1, jpk ! depth at T and W-points + zw = REAL( jk , wp ) + zt = REAL( jk , wp ) + 0.5_wp + pdepw_1d(jk) = ( zsur + za0 * zw + za1 * zacr * LOG( COSH( (zw-zkth) / zacr ) ) ) + pdept_1d(jk) = ( zsur + za0 * zt + za1 * zacr * LOG( COSH( (zt-zkth) / zacr ) ) ) + END DO + ! + ! ! e3t and e3w from depth + CALL depth_to_e3( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d ) + ! + ! ! recompute depths from SUM(e3) <== needed + CALL e3_to_depth( pe3t_1d, pe3w_1d, pdept_1d, pdepw_1d ) + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' Reference 1D z-coordinate depth and scale factors:' + WRITE(numout, "(9x,' level gdept_1d gdepw_1d e3t_1d e3w_1d ')" ) + WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, pdept_1d(jk), pdepw_1d(jk), pe3t_1d(jk), pe3w_1d(jk), jk = 1, jpk ) + ENDIF + ! + END SUBROUTINE zgr_z + + + SUBROUTINE zgr_msk_top_bot( k_top , k_bot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_msk_top_bot *** + !! + !! ** Purpose : set the masked top and bottom ocean t-levels + !! + !! ** Method : GYRE case = closed flat box ocean without ocean cavities + !! k_top = 1 except along north, south, east and west boundaries + !! k_bot = jpk-1 except along north, south, east and west boundaries + !! + !! ** Action : - k_top : first wet ocean level index + !! - k_bot : last wet ocean level index + !!---------------------------------------------------------------------- + INTEGER , DIMENSION(:,:), INTENT(out) :: k_top , k_bot ! first & last wet ocean level + ! + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D local workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' zgr_top_bot : defines the top and bottom wet ocean levels.' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) ' GYRE case : closed flat box ocean without ocean cavities' + ! + z2d(:,:) = REAL( jpkm1 , wp ) ! flat bottom + ! + k_bot(:,:) = NINT( z2d(:,:) ) ! =jpkm1 over the ocean point, =0 elsewhere + ! + k_top(:,:) = MIN( 1 , k_bot(:,:) ) ! = 1 over the ocean point, =0 elsewhere + ! + END SUBROUTINE zgr_msk_top_bot + + + SUBROUTINE zgr_zco( pdept_1d, pdepw_1d, pe3t_1d, pe3w_1d, & ! in : 1D reference vertical coordinate + & pdept , pdepw , & ! out: 3D t & w-points depth + & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors + & pe3w , pe3uw , pe3vw ) ! - - - + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_zco *** + !! + !! ** Purpose : define the reference z-coordinate system + !! + !! ** Method : set 3D coord. arrays to reference 1D array + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:) , INTENT(in ) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:) , INTENT(in ) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pdept, pdepw ! grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pe3u, pe3v, pe3f! vertical scale factors [m] + REAL(dp), DIMENSION(:,:,:), INTENT( out) :: pe3t! vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pe3w , pe3uw, pe3vw ! - - - + ! + INTEGER :: jk + !!---------------------------------------------------------------------- + ! + DO jk = 1, jpk + pdept(:,:,jk) = pdept_1d(jk) + pdepw(:,:,jk) = pdepw_1d(jk) + pe3t (:,:,jk) = pe3t_1d (jk) + pe3u (:,:,jk) = pe3t_1d (jk) + pe3v (:,:,jk) = pe3t_1d (jk) + pe3f (:,:,jk) = pe3t_1d (jk) + pe3w (:,:,jk) = pe3w_1d (jk) + pe3uw(:,:,jk) = pe3w_1d (jk) + pe3vw(:,:,jk) = pe3w_1d (jk) + END DO + ! + END SUBROUTINE zgr_zco + + !!====================================================================== +END MODULE usrdef_zgr \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdf_oce.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdf_oce.F90 new file mode 100644 index 0000000..ac79e16 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdf_oce.F90 @@ -0,0 +1,77 @@ +MODULE zdf_oce + !!====================================================================== + !! *** MODULE zdf_oce *** + !! Ocean physics : define vertical mixing variables + !!===================================================================== + !! history : 1.0 ! 2002-06 (G. Madec) Original code + !! 3.2 ! 2009-07 (G. Madec) addition of avm + !! 4.0 ! 2017-05 (G. Madec) avm and drag coef. defined at t-point + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_oce_alloc ! Called in nemogcm.F90 + + ! !!* namelist namzdf: vertical physics * + ! ! Adaptive-implicit vertical advection flag + LOGICAL , PUBLIC :: ln_zad_Aimp !: adaptive (Courant number-based) implicit vertical advection + ! ! vertical closure scheme flags + LOGICAL , PUBLIC :: ln_zdfcst !: constant coefficients + LOGICAL , PUBLIC :: ln_zdfric !: Richardson depend coefficients + LOGICAL , PUBLIC :: ln_zdftke !: Turbulent Kinetic Energy closure + LOGICAL , PUBLIC :: ln_zdfgls !: Generic Length Scale closure + LOGICAL , PUBLIC :: ln_zdfosm !: OSMOSIS BL closure + ! ! convection + LOGICAL , PUBLIC :: ln_zdfevd !: convection: enhanced vertical diffusion flag + INTEGER , PUBLIC :: nn_evdm !: =0/1 flag to apply enhanced avm or not + REAL(wp), PUBLIC :: rn_evd !: vertical eddy coeff. for enhanced vert. diff. (m2/s) + LOGICAL , PUBLIC :: ln_zdfnpc !: convection: non-penetrative convection flag + INTEGER , PUBLIC :: nn_npc !: non penetrative convective scheme call frequency + INTEGER , PUBLIC :: nn_npcp !: non penetrative convective scheme print frequency + ! ! double diffusion + LOGICAL , PUBLIC :: ln_zdfddm !: double diffusive mixing flag + REAL(wp), PUBLIC :: rn_avts !: maximum value of avs for salt fingering + REAL(wp), PUBLIC :: rn_hsbfr !: heat/salt buoyancy flux ratio + ! ! gravity wave-induced vertical mixing + LOGICAL , PUBLIC :: ln_zdfswm !: surface wave-induced mixing flag + LOGICAL , PUBLIC :: ln_zdfiwm !: internal wave-induced mixing flag + LOGICAL , PUBLIC :: ln_zdfmfc !: convection: eddy diffusivity Mass Flux Convection + ! ! coefficients + REAL(wp), PUBLIC :: rn_avm0 !: vertical eddy viscosity (m2/s) + REAL(wp), PUBLIC :: rn_avt0 !: vertical eddy diffusivity (m2/s) + INTEGER , PUBLIC :: nn_avb !: constant or profile background on avt (=0/1) + INTEGER , PUBLIC :: nn_havtb !: horizontal shape or not for avtb (=0/1) ! ! convection + + + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm, avt, avs !: vertical mixing coefficients (w-point) [m2/s] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm_k , avt_k !: Kz computed by turbulent closure alone [m2/s] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: en !: now turbulent kinetic energy [m2/s2] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:) :: avmb , avtb !: background profile of avm and avt [m2/s] + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: avtb_2d !: horizontal shape of background Kz profile [-] + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdf_oce.F90 14072 2020-12-04 07:48:38Z laurent $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_oce_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_oce_alloc *** + !!---------------------------------------------------------------------- + ! + ALLOCATE( avm (jpi,jpj,jpk) , avm_k(jpi,jpj,jpk) , avs(jpi,jpj,jpk) , & + & avt (jpi,jpj,jpk) , avt_k(jpi,jpj,jpk) , en (jpi,jpj,jpk) , & + & avmb(jpk) , avtb(jpk) , avtb_2d(jpi,jpj) , STAT = zdf_oce_alloc ) + ! + IF( zdf_oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_oce_alloc: failed to allocate arrays' ) + ! + END FUNCTION zdf_oce_alloc + + !!====================================================================== +END MODULE zdf_oce \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfddm.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfddm.F90 new file mode 100644 index 0000000..db0c384 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfddm.F90 @@ -0,0 +1,167 @@ +MODULE zdfddm + !!====================================================================== + !! *** MODULE zdfddm *** + !! Ocean physics : double diffusion mixing parameterization + !!====================================================================== + !! History : OPA ! 2000-08 (G. Madec) double diffusive mixing + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.6 ! 2013-04 (G. Madec, F. Roquet) zrau compute locally using interpolation of alpha & beta + !! 4.0 ! 2017-04 (G. Madec) remove CPP ddm key & avm at t-point only + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_ddm : compute the Kz for salinity + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE zdf_oce ! ocean vertical physics variables + USE eosbn2 ! equation of state + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_ddm ! called by step.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfddm.F90 14853 2021-05-12 13:07:30Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_ddm( kt, Kmm, p_avm, p_avt, p_avs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_ddm *** + !! + !! ** Purpose : Add to the vertical eddy diffusivity coefficient the + !! effect of salt fingering and diffusive convection. + !! + !! ** Method : Diapycnal mixing is increased in case of double + !! diffusive mixing (i.e. salt fingering and diffusive layering) + !! following Merryfield et al. (1999). The rate of double diffusive + !! mixing depend on the buoyancy ratio (R=alpha/beta dk[T]/dk[S]): + !! * salt fingering (Schmitt 1981): + !! for R > 1 and rn2 > 0 : zavfs = rn_avts / ( 1 + (R/rn_hsbfr)^6 ) + !! for R > 1 and rn2 > 0 : zavfs = O + !! otherwise : zavft = 0.7 zavs / R + !! * diffusive layering (Federov 1988): + !! for 0< R < 1 and N^2 > 0 : zavdt = 1.3635e-6 * exp( 4.6 exp(-0.54 (1/R-1) ) ) + !! otherwise : zavdt = 0 + !! for .5 < R < 1 and N^2 > 0 : zavds = zavdt (1.885 R -0.85) + !! for 0 < R <.5 and N^2 > 0 : zavds = zavdt 0.15 R + !! otherwise : zavds = 0 + !! * update the eddy diffusivity: + !! avt = avt + zavft + zavdt + !! avs = avs + zavfs + zavds + !! avm is required to remain at least above avt and avs. + !! + !! ** Action : avt, avs : updated vertical eddy diffusivity coef. for T & S + !! + !! References : Merryfield et al., JPO, 29, 1124-1142, 1999. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avm ! Kz on momentum (w-points) + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avt ! Kz on temperature (w-points) + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_avs ! Kz on salinity (w-points) + ! + INTEGER :: ji, jj , jk ! dummy loop indices + REAL(wp) :: zaw, zbw, zrw ! local scalars + REAL(wp) :: zdt, zds + REAL(wp) :: zinr ! - - + REAL(dp) :: zrr ! - - + REAL(wp) :: zavft ! - - + REAL(dp) :: zavfs ! - - + REAL(wp) :: zavdt, zavds ! - - + REAL(wp), DIMENSION(A2D(nn_hls)) :: zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3 + !!---------------------------------------------------------------------- + ! + ! ! =============== + DO jk = 2, jpkm1 ! Horizontal slab + ! ! =============== + ! Define the mask + ! --------------- +!!gm WORK to be done: change the code from vector optimisation to scalar one. +!!gm ==>>> test in the loop instead of use of mask arrays +!!gm and many acces in memory + + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !== R=zrau = (alpha / beta) (dk[t] / dk[s]) ==! + zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) & +!!gm please, use e3w at Kmm below + & / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) ) + ! + zaw = ( rab_n(ji,jj,jk,jp_tem) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_tem) * zrw ) & + & * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) + zbw = ( rab_n(ji,jj,jk,jp_sal) * (1. - zrw) + rab_n(ji,jj,jk-1,jp_sal) * zrw ) & + & * tmask(ji,jj,jk) * tmask(ji,jj,jk-1) + ! + zdt = zaw * ( ts(ji,jj,jk-1,jp_tem,Kmm) - ts(ji,jj,jk,jp_tem,Kmm) ) + zds = zbw * ( ts(ji,jj,jk-1,jp_sal,Kmm) - ts(ji,jj,jk,jp_sal,Kmm) ) + IF( ABS( zds) <= 1.e-20_wp ) zds = 1.e-20_wp + zrau(ji,jj) = MAX( 1.e-20, zdt / zds ) ! only retains positive value of zrau + END_2D + + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !== indicators ==! + ! stability indicator: msks=1 if rn2>0; 0 elsewhere + IF( rn2(ji,jj,jk) + 1.e-12 <= 0. ) THEN ; zmsks(ji,jj) = 0._wp + ELSE ; zmsks(ji,jj) = 1._wp * wmask(ji,jj,jk) ! mask so avt and avs masked + ENDIF + ! salt fingering indicator: msksf=1 if R>1; 0 elsewhere + IF( zrau(ji,jj) <= 1. ) THEN ; zmskf(ji,jj) = 0._wp + ELSE ; zmskf(ji,jj) = 1._wp + ENDIF + ! diffusive layering indicators: + ! ! mskdl1=1 if 0< R <1; 0 elsewhere + IF( zrau(ji,jj) >= 1. ) THEN ; zmskd1(ji,jj) = 0._wp + ELSE ; zmskd1(ji,jj) = 1._wp + ENDIF + ! ! mskdl2=1 if 0< R <0.5; 0 elsewhere + IF( zrau(ji,jj) >= 0.5 ) THEN ; zmskd2(ji,jj) = 0._wp + ELSE ; zmskd2(ji,jj) = 1._wp + ENDIF + ! mskdl3=1 if 0.5< R <1; 0 elsewhere + IF( zrau(ji,jj) <= 0.5 .OR. zrau(ji,jj) >= 1. ) THEN ; zmskd3(ji,jj) = 0._wp + ELSE ; zmskd3(ji,jj) = 1._wp + ENDIF + END_2D + + ! Update avt and avs + ! ------------------ + ! Constant eddy coefficient: reset to the background value + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zinr = 1._wp / zrau(ji,jj) + ! salt fingering + zrr = zrau(ji,jj) / rn_hsbfr + zrr = zrr * zrr + zavfs = rn_avts / ( 1 + zrr*zrr*zrr ) * zmsks(ji,jj) * zmskf(ji,jj) + zavft = 0.7 * zavfs * zinr + ! diffusive layering + zavdt = 1.3635e-6 * EXP( 4.6 * EXP( -0.54*(zinr-1.) ) ) * zmsks(ji,jj) * zmskd1(ji,jj) + zavds = zavdt * zmsks(ji,jj) * ( ( 1.85 * zrau(ji,jj) - 0.85 ) * zmskd3(ji,jj) & + & + 0.15 * zrau(ji,jj) * zmskd2(ji,jj) ) + ! add to the eddy viscosity coef. previously computed + p_avs(ji,jj,jk) = p_avt(ji,jj,jk) + zavfs + zavds + p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zavft + zavdt + p_avm(ji,jj,jk) = p_avm(ji,jj,jk) + MAX( zavft + zavdt, zavfs + zavds ) + END_2D + ! ! =============== + END DO ! End of slab + ! ! =============== + ! + IF(sn_cfctl%l_prtctl) THEN + CALL prt_ctl(tab3d_1=REAL(avt ,dp), clinfo1=' ddm - t: ', tab3d_2=REAL(avs,dp) , clinfo2=' s: ') + ENDIF + ! + END SUBROUTINE zdf_ddm + + !!====================================================================== +END MODULE zdfddm diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfdrg.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfdrg.F90 new file mode 100644 index 0000000..4ffd69a --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfdrg.F90 @@ -0,0 +1,456 @@ +MODULE zdfdrg + !!====================================================================== + !! *** MODULE zdfdrg *** + !! Ocean physics: top and/or Bottom friction + !!====================================================================== + !! History : OPA ! 1997-06 (G. Madec, A.-M. Treguier) Original code + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.2 ! 2009-09 (A.C.Coward) Correction to include barotropic contribution + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.4 ! 2011-11 (H. Liu) implementation of semi-implicit bottom friction option + !! ! 2012-06 (H. Liu) implementation of Log Layer bottom friction option + !! 4.0 ! 2017-05 (G. Madec) zdfbfr becomes zdfdrg + variable names change + !! + drag defined at t-point + new user interface + top drag (ocean cavities) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_drg : update bottom friction coefficient (non-linear bottom friction only) + !! zdf_drg_exp : compute the top & bottom friction in explicit case + !! zdf_drg_init : read in namdrg namelist and control the bottom friction parameters. + !! drg_init : + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE phycst , ONLY : vkarmn + USE dom_oce ! ocean space and time domain variables + USE zdf_oce ! ocean vertical physics variables + USE trd_oce ! trends: ocean variables + USE trddyn ! trend manager: dynamics + ! + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing + USE prtctl ! Print control + USE sbc_oce , ONLY : nn_ice + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_drg ! called by zdf_phy + PUBLIC zdf_drg_exp ! called by dyn_zdf + PUBLIC zdf_drg_init ! called by zdf_phy_init + + ! !!* Namelist namdrg: nature of drag coefficient namelist * + LOGICAL , PUBLIC :: ln_drg_OFF ! free-slip : Cd = 0 + LOGICAL :: ln_lin ! linear drag: Cd = Cd0_lin + LOGICAL :: ln_non_lin ! non-linear drag: Cd = Cd0_nl |U| + LOGICAL :: ln_loglayer ! logarithmic drag: Cd = vkarmn/log(z/z0) + LOGICAL , PUBLIC :: ln_drgimp ! implicit top/bottom friction flag + LOGICAL , PUBLIC :: ln_drgice_imp ! implicit ice-ocean drag + ! !!* Namelist namdrg_top & _bot: TOP or BOTTOM coefficient namelist * + REAL(wp) :: rn_Cd0 !: drag coefficient [ - ] + REAL(wp) :: rn_Uc0 !: characteristic velocity (linear case: tau=rho*Cd0*Uc0*u) [m/s] + REAL(wp) :: rn_Cdmax !: drag value maximum (ln_loglayer=T) [ - ] + REAL(wp) :: rn_z0 !: roughness (ln_loglayer=T) [ m ] + REAL(wp) :: rn_ke0 !: background kinetic energy (non-linear case) [m2/s2] + LOGICAL :: ln_boost !: =T regional boost of Cd0 ; =F Cd0 horizontally uniform + REAL(wp) :: rn_boost !: local boost factor [ - ] + + REAL(wp), PUBLIC :: r_Cdmin_top, r_Cdmax_top, r_z0_top, r_ke0_top ! set from namdrg_top namelist values + REAL(wp), PUBLIC :: r_Cdmin_bot, r_Cdmax_bot, r_z0_bot, r_ke0_bot ! - - namdrg_bot - - + + INTEGER :: ndrg ! choice of the type of drag coefficient + ! ! associated indices: + INTEGER, PARAMETER :: np_OFF = 0 ! free-slip: drag set to zero + INTEGER, PARAMETER :: np_lin = 1 ! linear drag: Cd = Cd0_lin + INTEGER, PARAMETER :: np_non_lin = 2 ! non-linear drag: Cd = Cd0_nl |U| + INTEGER, PARAMETER :: np_loglayer = 3 ! non linear drag (logarithmic formulation): Cd = vkarmn/log(z/z0) + + LOGICAL , PUBLIC :: l_zdfdrg !: flag to update at each time step the top/bottom Cd + LOGICAL :: l_log_not_linssh !: flag to update at each time step the position ot the velocity point + ! + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: rCd0_top, rCd0_bot !: precomputed top/bottom drag coeff. at t-point (>0) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: rCdU_top, rCdU_bot !: top/bottom drag coeff. at t-point (<0) [m/s] + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfdrg.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_drg( kt, Kmm, k_mk, pCdmin, pCdmax, pz0, pke0, pCd0, & ! <<== in + & pCdU ) ! ==>> out : bottom drag [m/s] + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_drg *** + !! + !! ** Purpose : update the top/bottom drag coefficient (non-linear case only) + !! + !! ** Method : In non linear friction case, the drag coeficient is + !! a function of the velocity: + !! Cd = cd0 * |U+Ut| + !! where U is the top or bottom velocity and + !! Ut a tidal velocity (Ut^2 = Tidal kinetic energy + !! assumed here here to be constant) + !! Depending on the input variable, the top- or bottom drag is compted + !! + !! ** Action : p_Cd drag coefficient at t-point + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + ! ! !! !== top or bottom variables ==! + INTEGER , DIMENSION(:,:), INTENT(in ) :: k_mk ! wet level (1st or last) + REAL(wp) , INTENT(in ) :: pCdmin ! min drag value + REAL(wp) , INTENT(in ) :: pCdmax ! max drag value + REAL(wp) , INTENT(in ) :: pz0 ! roughness + REAL(wp) , INTENT(in ) :: pke0 ! background tidal KE + REAL(wp), DIMENSION(:,:), INTENT(in ) :: pCd0 ! masked precomputed part of Cd0 + REAL(wp), DIMENSION(:,:), INTENT( out) :: pCdU ! = - Cd*|U| (t-points) [m/s] + !! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: imk ! local integers + REAL(wp):: zzz, zut, zvt, zcd ! local scalars + !!---------------------------------------------------------------------- + ! + IF( l_log_not_linssh ) THEN !== "log layer" ==! compute Cd and -Cd*|U| + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + imk = k_mk(ji,jj) ! ocean bottom level at t-points + zut = uu(ji,jj,imk,Kmm) + uu(ji-1,jj,imk,Kmm) ! 2 x velocity at t-point + zvt = vv(ji,jj,imk,Kmm) + vv(ji,jj-1,imk,Kmm) + zzz = 0.5_wp * e3t(ji,jj,imk,Kmm) ! altitude below/above (top/bottom) the boundary + ! +!!JC: possible WAD implementation should modify line below if layers vanish + zcd = ( vkarmn / LOG( zzz / pz0 ) )**2 + zcd = pCd0(ji,jj) * MIN( MAX( pCdmin , zcd ) , pCdmax ) ! here pCd0 = mask*boost + pCdU(ji,jj) = - zcd * SQRT( 0.25 * ( zut*zut + zvt*zvt ) + pke0 ) + END_2D + ELSE !== standard Cd ==! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + imk = k_mk(ji,jj) ! ocean bottom level at t-points + zut = uu(ji,jj,imk,Kmm) + uu(ji-1,jj,imk,Kmm) ! 2 x velocity at t-point + zvt = vv(ji,jj,imk,Kmm) + vv(ji,jj-1,imk,Kmm) + ! ! here pCd0 = mask*boost * drag + pCdU(ji,jj) = - pCd0(ji,jj) * SQRT( 0.25 * ( zut*zut + zvt*zvt ) + pke0 ) + END_2D + ENDIF + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=REAL(pCdU,dp), clinfo1=' Cd*U ') + ! + END SUBROUTINE zdf_drg + + + SUBROUTINE zdf_drg_exp( kt, Kmm, pub, pvb, pua, pva ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_drg_exp *** + !! + !! ** Purpose : compute and add the explicit top and bottom frictions. + !! + !! ** Method : in explicit case, + !! + !! NB: in implicit case the calculation is performed in dynzdf.F90 + !! + !! ** Action : (pua,pva) momentum trend increased by top & bottom friction trend + !!--------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kmm ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pub, pvb ! the two components of the before velocity + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! the two components of the velocity tendency + !! + INTEGER :: ji, jj ! dummy loop indexes + INTEGER :: ikbu, ikbv ! local integers + REAL(wp) :: zm1_2dt ! local scalar + REAL(wp) :: zCdu, zCdv ! - - + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv + !!--------------------------------------------------------------------- + ! +!!gm bug : time step is only rn_Dt (not 2 rn_Dt if euler start !) + zm1_2dt = - 1._wp / ( 2._wp * rn_Dt ) + + IF( l_trddyn ) THEN ! trends: store the input trends + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = pua(:,:,:) + ztrdv(:,:,:) = pva(:,:,:) + ENDIF + + DO_2D( 0, 0, 0, 0 ) + ikbu = mbku(ji,jj) ! deepest wet ocean u- & v-levels + ikbv = mbkv(ji,jj) + ! + ! Apply stability criteria on absolute value : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) + zCdu = 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / e3u(ji,jj,ikbu,Kmm) + zCdv = 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / e3v(ji,jj,ikbv,Kmm) + ! + pua(ji,jj,ikbu) = pua(ji,jj,ikbu) + MAX( zCdu , zm1_2dt ) * pub(ji,jj,ikbu) + pva(ji,jj,ikbv) = pva(ji,jj,ikbv) + MAX( zCdv , zm1_2dt ) * pvb(ji,jj,ikbv) + END_2D + ! + IF( ln_isfcav ) THEN ! ocean cavities + DO_2D( 0, 0, 0, 0 ) + ikbu = miku(ji,jj) ! first wet ocean u- & v-levels + ikbv = mikv(ji,jj) + ! + ! Apply stability criteria on absolute value : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) + zCdu = 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / e3u(ji,jj,ikbu,Kmm) ! NB: Cdtop masked + zCdv = 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / e3v(ji,jj,ikbv,Kmm) + ! + pua(ji,jj,ikbu) = pua(ji,jj,ikbu) + MAX( zCdu , zm1_2dt ) * pub(ji,jj,ikbu) + pva(ji,jj,ikbv) = pva(ji,jj,ikbv) + MAX( zCdv , zm1_2dt ) * pvb(ji,jj,ikbv) + END_2D + ENDIF + ! + IF( l_trddyn ) THEN ! trends: send trends to trddyn for further diagnostics + ztrdu(:,:,:) = pua(:,:,:) - ztrdu(:,:,:) + ztrdv(:,:,:) = pva(:,:,:) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu(:,:,:), ztrdv(:,:,:), jpdyn_bfr, kt, Kmm ) + DEALLOCATE( ztrdu, ztrdv ) + ENDIF + ! ! print mean trends (used for debugging) + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pua, clinfo1=' bfr - Ua: ', mask1=umask, & + & tab3d_2=pva, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + END SUBROUTINE zdf_drg_exp + + + SUBROUTINE zdf_drg_init + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_brg_init *** + !! + !! ** Purpose : Initialization of the bottom friction + !! + !! ** Method : Read the namdrg namelist and check their consistency + !! called at the first timestep (nit000) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indexes + INTEGER :: ios, ioptio ! local integers + !! + NAMELIST/namdrg/ ln_drg_OFF, ln_lin, ln_non_lin, ln_loglayer, ln_drgimp, ln_drgice_imp + !!---------------------------------------------------------------------- + ! + ! !== drag nature ==! + ! + READ ( numnam_ref, namdrg, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam( ios , 'namdrg in reference namelist' ) + READ ( numnam_cfg, namdrg, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam( ios , 'namdrg in configuration namelist' ) + IF(lwm) WRITE ( numond, namdrg ) + ! + IF ( ln_drgice_imp .AND. nn_ice /= 2 ) ln_drgice_imp = .FALSE. + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'zdf_drg_init : top and/or bottom drag setting' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namdrg : top/bottom friction choices' + WRITE(numout,*) ' free-slip : Cd = 0 ln_drg_OFF = ', ln_drg_OFF + WRITE(numout,*) ' linear drag : Cd = Cd0 ln_lin = ', ln_lin + WRITE(numout,*) ' non-linear drag: Cd = Cd0_nl |U| ln_non_lin = ', ln_non_lin + WRITE(numout,*) ' logarithmic drag: Cd = vkarmn/log(z/z0) ln_loglayer = ', ln_loglayer + WRITE(numout,*) ' implicit friction ln_drgimp = ', ln_drgimp + WRITE(numout,*) ' implicit ice-ocean drag ln_drgice_imp =', ln_drgice_imp + ENDIF + ! + ioptio = 0 ! set ndrg and control check + IF( ln_drg_OFF ) THEN ; ndrg = np_OFF ; ioptio = ioptio + 1 ; ENDIF + IF( ln_lin ) THEN ; ndrg = np_lin ; ioptio = ioptio + 1 ; ENDIF + IF( ln_non_lin ) THEN ; ndrg = np_non_lin ; ioptio = ioptio + 1 ; ENDIF + IF( ln_loglayer ) THEN ; ndrg = np_loglayer ; ioptio = ioptio + 1 ; ENDIF + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'zdf_drg_init: Choose ONE type of drag coef in namdrg' ) + ! + IF ( ln_drgice_imp.AND.(.NOT.ln_drgimp) ) & + & CALL ctl_stop( 'zdf_drg_init: ln_drgice_imp=T requires ln_drgimp=T' ) + ! + ! !== BOTTOM drag setting ==! (applied at seafloor) + ! + ALLOCATE( rCd0_bot(jpi,jpj), rCdU_bot(jpi,jpj) ) + CALL drg_init( 'BOTTOM' , mbkt , & ! <== in + & r_Cdmin_bot, r_Cdmax_bot, r_z0_bot, r_ke0_bot, rCd0_bot, rCdU_bot ) ! ==> out + ! + ! !== TOP drag setting ==! (applied at the top of ocean cavities) + ! + IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! Ocean cavities: top friction setting + ALLOCATE( rCdU_top(jpi,jpj) ) + ENDIF + ! + IF( ln_isfcav ) THEN + ALLOCATE( rCd0_top(jpi,jpj)) + CALL drg_init( 'TOP ' , mikt , & ! <== in + & r_Cdmin_top, r_Cdmax_top, r_z0_top, r_ke0_top, rCd0_top, rCdU_top ) ! ==> out + ENDIF + ! + END SUBROUTINE zdf_drg_init + + + SUBROUTINE drg_init( cd_topbot, k_mk, & + & pCdmin, pCdmax, pz0, pke0, pCd0, pCdU ) + !!---------------------------------------------------------------------- + !! *** ROUTINE drg_init *** + !! + !! ** Purpose : Initialization of the top/bottom friction CdO and Cd + !! from namelist parameters + !!---------------------------------------------------------------------- + CHARACTER(len=6) , INTENT(in ) :: cd_topbot ! top/ bot indicator + INTEGER , DIMENSION(:,:), INTENT(in ) :: k_mk ! 1st/last wet level + REAL(wp) , INTENT( out) :: pCdmin, pCdmax ! min and max drag coef. [-] + REAL(wp) , INTENT( out) :: pz0 ! roughness [m] + REAL(wp) , INTENT( out) :: pke0 ! background KE [m2/s2] + REAL(wp), DIMENSION(:,:), INTENT( out) :: pCd0 ! masked precomputed part of the non-linear drag coefficient + REAL(wp), DIMENSION(:,:), INTENT( out) :: pCdU ! minus linear drag*|U| at t-points [m/s] + !! + CHARACTER(len=40) :: cl_namdrg, cl_file, cl_varname, cl_namref, cl_namcfg ! local names + INTEGER :: ji, jj ! dummy loop indexes + LOGICAL :: ll_top, ll_bot ! local logical + INTEGER :: ios, inum, imk ! local integers + REAL(wp):: zmsk, zzz, zcd ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zmsk_boost ! 2D workspace + !! + NAMELIST/namdrg_top/ rn_Cd0, rn_Uc0, rn_Cdmax, rn_ke0, rn_z0, ln_boost, rn_boost + NAMELIST/namdrg_bot/ rn_Cd0, rn_Uc0, rn_Cdmax, rn_ke0, rn_z0, ln_boost, rn_boost + !!---------------------------------------------------------------------- + ! + ! !== set TOP / BOTTOM specificities ==! + ll_top = .FALSE. + ll_bot = .FALSE. + ! + SELECT CASE (cd_topbot) + CASE( 'TOP ' ) + ll_top = .TRUE. + cl_namdrg = 'namdrg_top' + cl_namref = 'namdrg_top in reference namelist' + cl_namcfg = 'namdrg_top in configuration namelist' + cl_file = 'tfr_coef.nc' + cl_varname = 'tfr_coef' + CASE( 'BOTTOM' ) + ll_bot = .TRUE. + cl_namdrg = 'namdrg_bot' + cl_namref = 'namdrg_bot in reference namelist' + cl_namcfg = 'namdrg_bot in configuration namelist' + cl_file = 'bfr_coef.nc' + cl_varname = 'bfr_coef' + CASE DEFAULT + CALL ctl_stop( 'drg_init: bad value for cd_topbot ' ) + END SELECT + ! + ! !== read namlist ==! + ! + IF(ll_top) READ ( numnam_ref, namdrg_top, IOSTAT = ios, ERR = 901) + IF(ll_bot) READ ( numnam_ref, namdrg_bot, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam( ios , TRIM(cl_namref) ) + IF(ll_top) READ ( numnam_cfg, namdrg_top, IOSTAT = ios, ERR = 902 ) + IF(ll_bot) READ ( numnam_cfg, namdrg_bot, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam( ios , TRIM(cl_namcfg) ) + IF(lwm .AND. ll_top) WRITE ( numond, namdrg_top ) + IF(lwm .AND. ll_bot) WRITE ( numond, namdrg_bot ) + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Namelist ',TRIM(cl_namdrg),' : set ',TRIM(cd_topbot),' friction parameters' + WRITE(numout,*) ' drag coefficient rn_Cd0 = ', rn_Cd0 + WRITE(numout,*) ' characteristic velocity (linear case) rn_Uc0 = ', rn_Uc0, ' m/s' + WRITE(numout,*) ' non-linear drag maximum rn_Cdmax = ', rn_Cdmax + WRITE(numout,*) ' background kinetic energy (n-l case) rn_ke0 = ', rn_ke0 + WRITE(numout,*) ' bottom roughness (n-l case) rn_z0 = ', rn_z0 + WRITE(numout,*) ' set a regional boost of Cd0 ln_boost = ', ln_boost + WRITE(numout,*) ' associated boost factor rn_boost = ', rn_boost + ENDIF + ! + ! !== return some namelist parametres ==! (used in non_lin and loglayer cases) + pCdmin = rn_Cd0 + pCdmax = rn_Cdmax + pz0 = rn_z0 + pke0 = rn_ke0 + ! + ! !== mask * boost factor ==! + ! + IF( ln_boost ) THEN !* regional boost: boost factor = 1 + regional boost + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> use a regional boost read in ', TRIM(cl_file), ' file' + IF(lwp) WRITE(numout,*) ' using enhancement factor of ', rn_boost + ! cl_varname is a coefficient in [0,1] giving where to apply the regional boost + CALL iom_open ( TRIM(cl_file), inum ) + CALL iom_get ( inum, jpdom_global, TRIM(cl_varname), zmsk_boost, 1 ) + CALL iom_close( inum) + zmsk_boost(:,:) = 1._wp + rn_boost * zmsk_boost(:,:) + ! + ELSE !* no boost: boost factor = 1 + zmsk_boost(:,:) = 1._wp + ENDIF + ! !* mask outside ocean cavities area (top) or land area (bot) + IF(ll_top) zmsk_boost(:,:) = zmsk_boost(:,:) * ssmask(:,:) * (1. - tmask(:,:,1) ) ! none zero in ocean cavities only + IF(ll_bot) zmsk_boost(:,:) = zmsk_boost(:,:) * ssmask(:,:) ! x seafloor mask + ! + l_log_not_linssh = .FALSE. ! default definition + ! + SELECT CASE( ndrg ) + ! + CASE( np_OFF ) !== No top/bottom friction ==! (pCdU = 0) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> ',TRIM(cd_topbot),' free-slip, friction set to zero' + ! + l_zdfdrg = .FALSE. ! no time variation of the drag: set it one for all + ! + pCdU(:,:) = 0._wp + pCd0(:,:) = 0._wp + ! + CASE( np_lin ) !== linear friction ==! (pCdU = Cd0 * Uc0) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> linear ',TRIM(cd_topbot),' friction (constant coef = Cd0*Uc0 = ', rn_Cd0*rn_Uc0, ')' + ! + l_zdfdrg = .FALSE. ! no time variation of the Cd*|U| : set it one for all + ! + pCd0(:,:) = rn_Cd0 * zmsk_boost(:,:) !* constant in time drag coefficient (= mask (and boost) Cd0) + pCdU(:,:) = - pCd0(:,:) * rn_Uc0 ! using a constant velocity + ! + CASE( np_non_lin ) !== non-linear friction ==! (pCd0 = Cd0 ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> quadratic ',TRIM(cd_topbot),' friction (propotional to module of the velocity)' + IF(lwp) WRITE(numout,*) ' with a drag coefficient Cd0 = ', rn_Cd0, ', and' + IF(lwp) WRITE(numout,*) ' a background velocity module of (rn_ke0)^1/2 = ', SQRT(rn_ke0), 'm/s)' + ! + l_zdfdrg = .TRUE. !* Cd*|U| updated at each time-step (it depends on ocean velocity) + ! + pCd0(:,:) = rn_Cd0 * zmsk_boost(:,:) !* constant in time proportionality coefficient (= mask (and boost) Cd0) + pCdU(:,:) = 0._wp ! + ! + CASE( np_loglayer ) !== logarithmic layer formulation of friction ==! (CdU = (vkarman log(z/z0))^2 |U| ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> quadratic ',TRIM(cd_topbot),' drag (propotional to module of the velocity)' + IF(lwp) WRITE(numout,*) ' with a logarithmic Cd0 formulation Cd0 = ( vkarman log(z/z0) )^2 ,' + IF(lwp) WRITE(numout,*) ' a background velocity module of (rn_ke0)^1/2 = ', SQRT(pke0), 'm/s), ' + IF(lwp) WRITE(numout,*) ' a logarithmic formulation: a roughness of ', pz0, ' meters, and ' + IF(lwp) WRITE(numout,*) ' a proportionality factor bounded by min/max values of ', pCdmin, pCdmax + ! + l_zdfdrg = .TRUE. !* Cd*|U| updated at each time-step (it depends on ocean velocity) + ! + IF( ln_linssh ) THEN !* pCd0 = (v log(z/z0))^2 as velocity points have a fixed z position + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' N.B. linear free surface case, Cd0 computed one for all' + ! + l_log_not_linssh = .FALSE. !- don't update Cd at each time step + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! pCd0 = mask (and boosted) logarithmic drag coef. + zzz = 0.5_wp * e3t_0(ji,jj,k_mk(ji,jj)) + zcd = ( vkarmn / LOG( zzz / rn_z0 ) )**2 + pCd0(ji,jj) = zmsk_boost(ji,jj) * MIN( MAX( rn_Cd0 , zcd ) , rn_Cdmax ) ! rn_Cd0 < Cd0 < rn_Cdmax + END_2D + ELSE !* Cd updated at each time-step ==> pCd0 = mask * boost + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' N.B. non-linear free surface case, Cd0 updated at each time-step ' + ! + l_log_not_linssh = .TRUE. ! compute the drag coef. at each time-step + ! + pCd0(:,:) = zmsk_boost(:,:) + ENDIF + pCdU(:,:) = 0._wp ! initialisation to zero (will be updated at each time step) + ! + CASE DEFAULT + CALL ctl_stop( 'drg_init: bad flag value for ndrg ' ) + END SELECT + ! + END SUBROUTINE drg_init + + !!====================================================================== +END MODULE zdfdrg diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfevd.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfevd.F90 new file mode 100644 index 0000000..c72d816 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfevd.F90 @@ -0,0 +1,141 @@ +MODULE zdfevd + !!====================================================================== + !! *** MODULE zdfevd *** + !! Ocean physics: parameterization of convection through an enhancement + !! of vertical eddy mixing coefficient + !!====================================================================== + !! History : OPA ! 1997-06 (G. Madec, A. Lazar) Original code + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.2 ! 2009-03 (M. Leclair, G. Madec, R. Benshila) test on both before & after + !! 4.0 ! 2017-04 (G. Madec) evd applied on avm (at t-point) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_evd : increase the momentum and tracer Kz at the location of + !! statically unstable portion of the water column (ln_zdfevd=T) + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE zdf_oce ! ocean vertical physics variables + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers + ! + USE in_out_manager ! I/O manager + USE iom ! for iom_put + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_evd ! called by step.F90 + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfevd.F90 15298 2021-09-28 10:06:42Z cetlod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_evd( kt, Kmm, Krhs, p_avm, p_avt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_evd *** + !! + !! ** Purpose : Local increased the vertical eddy viscosity and diffu- + !! sivity coefficients when a static instability is encountered. + !! + !! ** Method : tracer (and momentum if nn_evdm=1) vertical mixing + !! coefficients are set to rn_evd (namelist parameter) + !! if the water column is statically unstable. + !! The test of static instability is performed using + !! Brunt-Vaisala frequency (rn2 < -1.e-12) of to successive + !! time-step (Leap-Frog environnement): before and + !! now time-step. + !! + !! ** Action : avt, avm enhanced where static instability occurs + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step indexocean time step + INTEGER , INTENT(in ) :: Kmm, Krhs ! time level indices + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop indices + ! NOTE: [tiling] use a SAVE array to store diagnostics, then send after all tiles are finished. This is necessary because p_avt/p_avm are modified on adjacent tiles when using nn_hls > 1. zavt_evd/zavm_evd are then zero on some points when subsequently calculated for these tiles. + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: zavt_evd, zavm_evd + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'zdf_evd : Enhanced Vertical Diffusion (evd)' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + IF(lwp) WRITE(numout,*) + ENDIF + + ALLOCATE( zavt_evd(jpi,jpj,jpk) ) + IF( nn_evdm == 1 ) ALLOCATE( zavm_evd(jpi,jpj,jpk) ) + ENDIF + ! + ! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + zavt_evd(ji,jj,jk) = p_avt(ji,jj,jk) ! set avt prior to evd application + END_3D + ! + SELECT CASE ( nn_evdm ) + ! + CASE ( 1 ) !== enhance tracer & momentum Kz ==! (if rn2<-1.e-12) + ! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + zavm_evd(ji,jj,jk) = p_avm(ji,jj,jk) ! set avm prior to evd application + END_3D + ! +!! change last digits results +! WHERE( MAX( rn2(2:jpi,2:jpj,2:jpkm1), rn2b(2:jpi,2:jpj,2:jpkm1) ) <= -1.e-12 ) THEN +! p_avt(2:jpi,2:jpj,2:jpkm1) = rn_evd * wmask(2:jpi,2:jpj,2:jpkm1) +! p_avm(2:jpi,2:jpj,2:jpkm1) = rn_evd * wmask(2:jpi,2:jpj,2:jpkm1) +! END WHERE + ! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + IF( MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1.e-12 ) THEN + p_avt(ji,jj,jk) = rn_evd * wmask(ji,jj,jk) + p_avm(ji,jj,jk) = rn_evd * wmask(ji,jj,jk) + ENDIF + END_3D + ! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + zavm_evd(ji,jj,jk) = p_avm(ji,jj,jk) - zavm_evd(ji,jj,jk) ! change in avm due to evd + END_3D + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + CALL iom_put( "avm_evd", zavm_evd ) ! output this change + DEALLOCATE( zavm_evd ) + ENDIF + ! + CASE DEFAULT !== enhance tracer Kz ==! (if rn2<-1.e-12) +!! change last digits results +! WHERE( MAX( rn2(2:jpi,2:jpj,2:jpkm1), rn2b(2:jpi,2:jpj,2:jpkm1) ) <= -1.e-12 ) +! p_avt(2:jpi,2:jpj,2:jpkm1) = rn_evd * wmask(2:jpi,2:jpj,2:jpkm1) +! END WHERE + + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + IF( MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1.e-12 ) & + p_avt(ji,jj,jk) = rn_evd * wmask(ji,jj,jk) + END_3D + ! + END SELECT + ! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + zavt_evd(ji,jj,jk) = p_avt(ji,jj,jk) - zavt_evd(ji,jj,jk) ! change in avt due to evd + END_3D + ! + IF( l_trdtra ) CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_evd, zavt_evd ) + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + CALL iom_put( "avt_evd", zavt_evd ) ! output this change + DEALLOCATE( zavt_evd ) + ENDIF + ! + END SUBROUTINE zdf_evd + + !!====================================================================== +END MODULE zdfevd \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfgls.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfgls.F90 new file mode 100644 index 0000000..a615346 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfgls.F90 @@ -0,0 +1,1280 @@ +MODULE zdfgls + !!====================================================================== + !! *** MODULE zdfgls *** + !! Ocean physics: vertical mixing coefficient computed from the gls + !! turbulent closure parameterization + !!====================================================================== + !! History : 3.0 ! 2009-09 (G. Reffray) Original code + !! 3.3 ! 2010-10 (C. Bricaud) Add in the reference + !! 4.0 ! 2017-04 (G. Madec) remove CPP keys & avm at t-point only + !! - ! 2017-05 (G. Madec) add top friction as boundary condition + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_gls : update momentum and tracer Kz from a gls scheme + !! zdf_gls_init : initialization, namelist read, and parameters control + !! gls_rst : read/write gls restart in ocean restart file + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE domvvl ! ocean space and time domain : variable volume layer + USE zdfdrg , ONLY : ln_drg_OFF ! top/bottom free-slip flag + USE zdfdrg , ONLY : r_z0_top , r_z0_bot ! top/bottom roughness + USE zdfdrg , ONLY : rCdU_top , rCdU_bot ! top/bottom friction + USE sbc_oce ! surface boundary condition: ocean + USE phycst ! physical constants + USE zdfmxl ! mixed layer + USE sbcwave , ONLY : hsw ! significant wave height +#if defined key_si3 + USE ice, ONLY: hm_i, h_i +#endif +#if defined key_cice + USE sbc_ice, ONLY: h_i +#endif + ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP manager + USE prtctl ! Print control + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_gls ! called in zdfphy + PUBLIC zdf_gls_init ! called in zdfphy + PUBLIC gls_rst ! called in zdfphy + + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hmxl_n !: now mixing length + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zwall !: wall function + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustar2_surf !: Squared surface velocity scale at T-points + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustar2_top !: Squared top velocity scale at T-points + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustar2_bot !: Squared bottom velocity scale at T-points + + ! !! ** Namelist namzdf_gls ** + LOGICAL :: ln_length_lim ! use limit on the dissipation rate under stable stratification (Galperin et al. 1988) + LOGICAL :: ln_sigpsi ! Activate Burchard (2003) modification for k-eps closure & wave breaking mixing + INTEGER :: nn_mxlice ! type of scaling under sea-ice (=0/1/2/3) + INTEGER :: nn_bc_surf ! surface boundary condition (=0/1) + INTEGER :: nn_bc_bot ! bottom boundary condition (=0/1) + INTEGER :: nn_z0_met ! Method for surface roughness computation + INTEGER :: nn_z0_ice ! Roughness accounting for sea ice + INTEGER :: nn_stab_func ! stability functions G88, KC or Canuto (=0/1/2) + INTEGER :: nn_clos ! closure 0/1/2/3 MY82/k-eps/k-w/gen + REAL(wp) :: rn_clim_galp ! Holt 2008 value for k-eps: 0.267 + REAL(wp) :: rn_epsmin ! minimum value of dissipation (m2/s3) + REAL(wp) :: rn_emin ! minimum value of TKE (m2/s2) + REAL(wp) :: rn_charn ! Charnock constant for surface breaking waves mixing : 1400. (standard) or 2.e5 (Stacey value) + REAL(wp) :: rn_crban ! Craig and Banner constant for surface breaking waves mixing + REAL(wp) :: rn_hsro ! Minimum surface roughness + REAL(wp) :: rn_hsri ! Ice ocean roughness + REAL(wp) :: rn_frac_hs ! Fraction of wave height as surface roughness (if nn_z0_met > 1) + + REAL(wp) :: rcm_sf = 0.73_wp ! Shear free turbulence parameters + REAL(wp) :: ra_sf = -2.0_wp ! Must be negative -2 < ra_sf < -1 + REAL(wp) :: rl_sf = 0.2_wp ! 0 > think about that... + ! + IF( .NOT.ln_drg_OFF ) THEN !== top/bottom friction (explicit before friction) + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! bottom friction (explicit before friction) + zmsku = 0.5_wp * ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) + zmskv = 0.5_wp * ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) ! (CAUTION: CdU<0) + ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2 & + & + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2 ) + END_2D + IF( ln_isfcav ) THEN + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! top friction + zmsku = 0.5_wp * ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) + zmskv = 0.5_wp * ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) ! (CAUTION: CdU<0) + ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2 & + & + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2 ) + END_2D + ENDIF + ENDIF + + SELECT CASE ( nn_z0_met ) !== Set surface roughness length ==! + CASE ( 0 ) ! Constant roughness + zhsro(:,:) = rn_hsro + CASE ( 1 ) ! Standard Charnock formula + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zhsro(ji,jj) = MAX( rsbc_zs1 * ustar2_surf(ji,jj) , rn_hsro ) + END_2D + CASE ( 2 ) ! Roughness formulae according to Rascle et al., Ocean Modelling (2008) +!!gm faster coding : the 2 comment lines should be used +!!gm zcof = 2._wp * 0.6_wp / 28._wp +!!gm zdep(:,:) = 30._wp * TANH( zcof/ SQRT( MAX(ustar2_surf(:,:),rsmall) ) ) ! Wave age (eq. 10) + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zcof = 30.*TANH( 2.*0.3/(28.*SQRT(MAX(ustar2_surf(ji,jj),rsmall))) ) ! Wave age (eq. 10) + zhsro(ji,jj) = MAX(rsbc_zs2 * ustar2_surf(ji,jj) * zcof**1.5, rn_hsro) ! zhsro = rn_frac_hs * Hsw (eq. 11) + END_2D + CASE ( 3 ) ! Roughness given by the wave model (coupled or read in file) + zhsro(:,:) = MAX(rn_frac_hs * hsw(A2D(nn_hls)), rn_hsro) ! (rn_frac_hs=1.6 see Eq. (5) of Rascle et al. 2008 ) + END SELECT + ! + ! adapt roughness where there is sea ice + SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice + ! + CASE( 1 ) ! scaling with constant sea-ice roughness + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zhsro(ji,jj) = ( (1._wp-zice_fra(ji,jj)) * zhsro(ji,jj) + zice_fra(ji,jj) * rn_hsri )*tmask(ji,jj,1) + (1._wp - tmask(ji,jj,1))*rn_hsro + END_2D + ! + CASE( 2 ) ! scaling with mean sea-ice thickness +#if defined key_si3 + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zhsro(ji,jj) = ( (1._wp-zice_fra(ji,jj)) * zhsro(ji,jj) + zice_fra(ji,jj) * hm_i(ji,jj) )*tmask(ji,jj,1) + (1._wp - tmask(ji,jj,1))*rn_hsro + END_2D +#endif + ! + CASE( 3 ) ! scaling with max sea-ice thickness +#if defined key_si3 || defined key_cice + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zhsro(ji,jj) = ( (1._wp-zice_fra(ji,jj)) * zhsro(ji,jj) + zice_fra(ji,jj) * MAXVAL(h_i(ji,jj,:)) )*tmask(ji,jj,1) + (1._wp - tmask(ji,jj,1))*rn_hsro + END_2D +#endif + ! + END SELECT + ! + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !== Compute dissipation rate ==! + eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / hmxl_n(ji,jj,jk) + END_3D + + ! Save tke at before time step + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + eb (ji,jj,jk) = en (ji,jj,jk) + hmxl_b(ji,jj,jk) = hmxl_n(ji,jj,jk) + END_3D + + IF( nn_clos == 0 ) THEN ! Mellor-Yamada + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + zup = hmxl_n(ji,jj,jk) * gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) + zdown = vkarmn * gdepw(ji,jj,jk,Kmm) * ( -gdepw(ji,jj,jk,Kmm) + gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) ) + zcoef = ( zup / MAX( zdown, rsmall ) ) + zwall (ji,jj,jk) = ( 1._wp + re2 * zcoef*zcoef ) * tmask(ji,jj,jk) + END_3D + ENDIF + + !!---------------------------------!! + !! Equation to prognostic k !! + !!---------------------------------!! + ! + ! Now Turbulent kinetic energy (output in en) + ! ------------------------------- + ! Resolution of a tridiagonal linear system by a "methode de chasse" + ! computation from level 2 to jpkm1 (e(1) computed after and e(jpk)=0 ). + ! The surface boundary condition are set after + ! The bottom boundary condition are also set after. In standard e(bottom)=0. + ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal + ! Warning : after this step, en : right hand side of the matrix + + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + ! + buoy = - p_avt(ji,jj,jk) * rn2(ji,jj,jk) ! stratif. destruction + ! + diss = eps(ji,jj,jk) ! dissipation + ! + zdir = 0.5_wp + SIGN( 0.5_wp, p_sh2(ji,jj,jk) + buoy ) ! zdir =1(=0) if shear(ji,jj,jk)+buoy >0(<0) + ! + zesh2 = zdir*(p_sh2(ji,jj,jk)+buoy)+(1._wp-zdir)*p_sh2(ji,jj,jk) ! production term + zdiss = zdir*(diss/en(ji,jj,jk)) +(1._wp-zdir)*(diss-buoy)/en(ji,jj,jk) ! dissipation term +!!gm better coding, identical results +! zesh2 = p_sh2(ji,jj,jk) + zdir*buoy ! production term +! zdiss = ( diss - (1._wp-zdir)*buoy ) / en(ji,jj,jk) ! dissipation term +!!gm + ! + ! Compute a wall function from 1. to rsc_psi*zwall/rsc_psi0 + ! Note that as long that Dirichlet boundary conditions are NOT set at the first and last levels (GOTM style) + ! there is no need to set a boundary condition for zwall_psi at the top and bottom boundaries. + ! Otherwise, this should be rsc_psi/rsc_psi0 + IF( ln_sigpsi ) THEN + zsigpsi = MIN( 1._wp, zesh2 / eps(ji,jj,jk) ) ! 0. <= zsigpsi <= 1. + zwall_psi(ji,jj,jk) = rsc_psi / & + & ( zsigpsi * rsc_psi + (1._wp-zsigpsi) * rsc_psi0 / MAX( zwall(ji,jj,jk), 1._wp ) ) + ELSE + zwall_psi(ji,jj,jk) = 1._wp + ENDIF + ! + ! building the matrix + zcof = rfact_tke * tmask(ji,jj,jk) + ! ! lower diagonal, in fact not used for jk = 2 (see surface conditions) + zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) & + & / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk,Kmm) ) + ! ! upper diagonal, in fact not used for jk = ibotm1 (see bottom conditions) + zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) & + & / ( e3t(ji,jj,jk ,Kmm) * e3w(ji,jj,jk,Kmm) ) + ! ! diagonal + zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rn_Dt * zdiss * wmask(ji,jj,jk) + ! ! right hand side in en + en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * zesh2 * wmask(ji,jj,jk) + END_3D + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zdiag(ji,jj,jpk) = 1._wp + ! + ! Set surface condition on zwall_psi (1 at the bottom) + zwall_psi(ji,jj, 1 ) = zwall_psi(ji,jj,2) + zwall_psi(ji,jj,jpk) = 1._wp + END_2D + ! + ! Surface boundary condition on tke + ! --------------------------------- + ! + SELECT CASE ( nn_bc_surf ) + ! + CASE ( 0 ) ! Dirichlet boundary condition (set e at k=1 & 2) + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! First level + en (ji,jj,1) = MAX( rn_emin , rc02r * ustar2_surf(ji,jj) * (1._wp + (1._wp-zice_fra(ji,jj))*rsbc_tke1)**r2_3 ) + zd_lw(ji,jj,1) = en(ji,jj,1) + zd_up(ji,jj,1) = 0._wp + zdiag(ji,jj,1) = 1._wp + ! + ! One level below + en (ji,jj,2) = MAX( rn_emin , rc02r * ustar2_surf(ji,jj) * (1._wp + (1._wp-zice_fra(ji,jj))*rsbc_tke1 & + & * ((zhsro(ji,jj)+gdepw(ji,jj,2,Kmm)) / zhsro(ji,jj) )**(1.5_wp*ra_sf) )**r2_3 ) + zd_lw(ji,jj,2) = 0._wp + zd_up(ji,jj,2) = 0._wp + zdiag(ji,jj,2) = 1._wp + END_2D + ! + IF( ln_isfcav) THEN ! top boundary (ocean cavity) + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF( mikt(ji,jj) > 1 )THEN + itop = mikt(ji,jj) ! k top w-point + itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one + ! ! mask at the + ! ocean surface + ! points + z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) + ! + ! Dirichlet condition applied at: + ! top level (itop) & Just below it (itopp1) + zd_lw(ji,jj,itop) = 0._wp ; zd_lw(ji,jj,itopp1) = 0._wp + zd_up(ji,jj,itop) = 0._wp ; zd_up(ji,jj,itopp1) = 0._wp + zdiag(ji,jj,itop) = 1._wp ; zdiag(ji,jj,itopp1) = 1._wp + en (ji,jj,itop) = z_en ; en (ji,jj,itopp1) = z_en + ENDIF + END_2D + ENDIF + ! + CASE ( 1 ) ! Neumann boundary condition (set d(e)/dz) + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! Dirichlet conditions at k=1 + en (ji,jj,1) = MAX( rn_emin , rc02r * ustar2_surf(ji,jj) * (1._wp + (1._wp-zice_fra(ji,jj))*rsbc_tke1)**r2_3 ) + zd_lw(ji,jj,1) = en(ji,jj,1) + zd_up(ji,jj,1) = 0._wp + zdiag(ji,jj,1) = 1._wp + ! + ! at k=2, set de/dz=Fw + !cbr + ! zdiag zd_lw not defined/used on the halo + zdiag(ji,jj,2) = zdiag(ji,jj,2) + zd_lw(ji,jj,2) ! Remove zd_lw from zdiag + zd_lw(ji,jj,2) = 0._wp + ! + zkar (ji,jj) = (rl_sf + (vkarmn-rl_sf)*(1.-EXP(-rtrans*gdept(ji,jj,1,Kmm)/zhsro(ji,jj)) )) + zflxs(ji,jj) = rsbc_tke2 * (1._wp-zice_fra(ji,jj)) * ustar2_surf(ji,jj)**1.5_wp * zkar(ji,jj) & + & * ( ( zhsro(ji,jj)+gdept(ji,jj,1,Kmm) ) / zhsro(ji,jj) )**(1.5_wp*ra_sf) +!!gm why not : * ( 1._wp + gdept(:,:,1,Kmm) / zhsro(:,:) )**(1.5_wp*ra_sf) + en(ji,jj,2) = en(ji,jj,2) + zflxs(ji,jj) / e3w(ji,jj,2,Kmm) + END_2D + ! + IF( ln_isfcav) THEN ! top boundary (ocean cavity) + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF( mikt(ji,jj) > 1 )THEN + itop = mikt(ji,jj) ! k top w-point + itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one + ! ! mask at the + ! ocean surface + ! points + z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) + ! + ! Bottom level Dirichlet condition: + ! Bottom level (ibot) & Just above it (ibotm1) + ! Dirichlet ! Neumann + zd_lw(ji,jj,itop) = 0._wp ! ! Remove zd_up from zdiag + zdiag(ji,jj,itop) = 1._wp ; zdiag(ji,jj,itopp1) = zdiag(ji,jj,itopp1) + zd_up(ji,jj,itopp1) + zd_up(ji,jj,itop) = 0._wp ; zd_up(ji,jj,itopp1) = 0._wp + en (ji,jj,itop) = z_en + ENDIF + END_2D + ENDIF + ! + END SELECT + + ! Bottom boundary condition on tke + ! -------------------------------- + ! + SELECT CASE ( nn_bc_bot ) + ! + CASE ( 0 ) ! Dirichlet + ! ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = rn_lmin + ! ! Balance between the production and the dissipation terms + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) +!!gm This means that bottom and ocean w-level above have a specified "en" value. Sure ???? +!! With thick deep ocean level thickness, this may be quite large, no ??? +!! in particular in ocean cavities where top stratification can be large... + ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point + ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 + ! + z_en = MAX( rc02r * ustar2_bot(ji,jj), rn_emin ) + ! + ! Dirichlet condition applied at: + ! Bottom level (ibot) & Just above it (ibotm1) + zd_lw(ji,jj,ibot) = 0._wp ; zd_lw(ji,jj,ibotm1) = 0._wp + zd_up(ji,jj,ibot) = 0._wp ; zd_up(ji,jj,ibotm1) = 0._wp + zdiag(ji,jj,ibot) = 1._wp ; zdiag(ji,jj,ibotm1) = 1._wp + en (ji,jj,ibot) = z_en ; en (ji,jj,ibotm1) = z_en + END_2D + ! + ! NOTE: ctl_stop with ln_isfcav when using GLS + IF( ln_isfcav) THEN ! top boundary (ocean cavity) + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + itop = mikt(ji,jj) ! k top w-point + itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one + ! ! mask at the ocean surface points + z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) + ! + !!gm TO BE VERIFIED !!! + ! Dirichlet condition applied at: + ! top level (itop) & Just below it (itopp1) + zd_lw(ji,jj,itop) = 0._wp ; zd_lw(ji,jj,itopp1) = 0._wp + zd_up(ji,jj,itop) = 0._wp ; zd_up(ji,jj,itopp1) = 0._wp + zdiag(ji,jj,itop) = 1._wp ; zdiag(ji,jj,itopp1) = 1._wp + en (ji,jj,itop) = z_en ; en (ji,jj,itopp1) = z_en + END_2D + ENDIF + ! + CASE ( 1 ) ! Neumman boundary condition + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point + ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 + ! + z_en = MAX( rc02r * ustar2_bot(ji,jj), rn_emin ) + ! + ! Bottom level Dirichlet condition: + ! Bottom level (ibot) & Just above it (ibotm1) + ! Dirichlet ! Neumann + zd_lw(ji,jj,ibot) = 0._wp ! ! Remove zd_up from zdiag + zdiag(ji,jj,ibot) = 1._wp ; zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) + zd_up(ji,jj,ibot) = 0._wp ; zd_up(ji,jj,ibotm1) = 0._wp + en (ji,jj,ibot) = z_en + END_2D + ! NOTE: ctl_stop with ln_isfcav when using GLS + IF( ln_isfcav) THEN ! top boundary (ocean cavity) + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + itop = mikt(ji,jj) ! k top w-point + itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one + ! ! mask at the ocean surface points + z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) + ! + ! Bottom level Dirichlet condition: + ! Bottom level (ibot) & Just above it (ibotm1) + ! Dirichlet ! Neumann + zd_lw(ji,jj,itop) = 0._wp ! ! Remove zd_up from zdiag + zdiag(ji,jj,itop) = 1._wp ; zdiag(ji,jj,itopp1) = zdiag(ji,jj,itopp1) + zd_up(ji,jj,itopp1) + zd_up(ji,jj,itop) = 0._wp ; zd_up(ji,jj,itopp1) = 0._wp + en (ji,jj,itop) = z_en + END_2D + ENDIF + ! + END SELECT + + ! Matrix inversion (en prescribed at surface and the bottom) + ! ---------------------------------------------------------- + ! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 + zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) + END_3D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 + zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) + END_3D + DO_3DS_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 ) ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk + en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) + END_3D + ! ! set the minimum value of tke + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) + END_3D + + !!----------------------------------------!! + !! Solve prognostic equation for psi !! + !!----------------------------------------!! + + ! Set psi to previous time step value + ! + SELECT CASE ( nn_clos ) + ! + CASE( 0 ) ! k-kl (Mellor-Yamada) + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + psi(ji,jj,jk) = eb(ji,jj,jk) * hmxl_b(ji,jj,jk) + END_3D + ! + CASE( 1 ) ! k-eps + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + psi(ji,jj,jk) = eps(ji,jj,jk) + END_3D + ! + CASE( 2 ) ! k-w + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + psi(ji,jj,jk) = SQRT( eb(ji,jj,jk) ) / ( rc0 * hmxl_b(ji,jj,jk) ) + END_3D + ! + CASE( 3 ) ! generic + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + psi(ji,jj,jk) = rc02 * eb(ji,jj,jk) * hmxl_b(ji,jj,jk)**rnn + END_3D + ! + END SELECT + ! + ! Now gls (output in psi) + ! ------------------------------- + ! Resolution of a tridiagonal linear system by a "methode de chasse" + ! computation from level 2 to jpkm1 (e(1) already computed and e(jpk)=0 ). + ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal + ! Warning : after this step, en : right hand side of the matrix + + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + ! + ! psi / k + zratio = psi(ji,jj,jk) / eb(ji,jj,jk) + ! + ! psi3+ : stable : B=-KhN²<0 => N²>0 if rn2>0 zdir = 1 (stable) otherwise zdir = 0 (unstable) + zdir = 0.5_wp + SIGN( 0.5_wp, rn2(ji,jj,jk) ) + ! + rpsi3 = zdir * rpsi3m + ( 1._wp - zdir ) * rpsi3p + ! + ! shear prod. - stratif. destruction + prod = rpsi1 * zratio * p_sh2(ji,jj,jk) + ! + ! stratif. destruction + buoy = rpsi3 * zratio * (- p_avt(ji,jj,jk) * rn2(ji,jj,jk) ) + ! + ! shear prod. - stratif. destruction + diss = rpsi2 * zratio * zwall(ji,jj,jk) * eps(ji,jj,jk) + ! + zdir = 0.5_wp + SIGN( 0.5_wp, prod + buoy ) ! zdir =1(=0) if shear(ji,jj,jk)+buoy >0(<0) + ! + zesh2 = zdir * ( prod + buoy ) + (1._wp - zdir ) * prod ! production term + zdiss = zdir * ( diss / psi(ji,jj,jk) ) + (1._wp - zdir ) * (diss-buoy) / psi(ji,jj,jk) ! dissipation term + ! + ! building the matrix + zcof = rfact_psi * zwall_psi(ji,jj,jk) * tmask(ji,jj,jk) + ! ! lower diagonal + zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) ) & + & / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk,Kmm) ) + ! ! upper diagonal + zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) & + & / ( e3t(ji,jj,jk ,Kmm) * e3w(ji,jj,jk,Kmm) ) + ! ! diagonal + zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rn_Dt * zdiss * wmask(ji,jj,jk) + ! ! right hand side in psi + psi(ji,jj,jk) = psi(ji,jj,jk) + rn_Dt * zesh2 * wmask(ji,jj,jk) + END_3D + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zdiag(ji,jj,jpk) = 1._wp + END_2D + + ! Surface boundary condition on psi + ! --------------------------------- + ! + SELECT CASE ( nn_bc_surf ) + ! + CASE ( 0 ) ! Dirichlet boundary conditions + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! Surface value + zdep (ji,jj) = zhsro(ji,jj) * rl_sf ! Cosmetic + psi (ji,jj,1) = rc0**rpp * en(ji,jj,1)**rmm * zdep(ji,jj)**rnn * tmask(ji,jj,1) + zd_lw(ji,jj,1) = psi(ji,jj,1) + zd_up(ji,jj,1) = 0._wp + zdiag(ji,jj,1) = 1._wp + ! + ! One level below + zkar (ji,jj) = (rl_sf + (vkarmn-rl_sf)*(1._wp-EXP(-rtrans*gdepw(ji,jj,2,Kmm)/zhsro(ji,jj) ))) + zdep (ji,jj) = (zhsro(ji,jj) + gdepw(ji,jj,2,Kmm)) * zkar(ji,jj) + psi (ji,jj,2) = rc0**rpp * en(ji,jj,2)**rmm * zdep(ji,jj)**rnn * tmask(ji,jj,1) + zd_lw(ji,jj,2) = 0._wp + zd_up(ji,jj,2) = 0._wp + zdiag(ji,jj,2) = 1._wp + END_2D + ! + CASE ( 1 ) ! Neumann boundary condition on d(psi)/dz + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! Surface value: Dirichlet + zdep (ji,jj) = zhsro(ji,jj) * rl_sf + psi (ji,jj,1) = rc0**rpp * en(ji,jj,1)**rmm * zdep(ji,jj)**rnn * tmask(ji,jj,1) + zd_lw(ji,jj,1) = psi(ji,jj,1) + zd_up(ji,jj,1) = 0._wp + zdiag(ji,jj,1) = 1._wp + ! + ! Neumann condition at k=2, zdiag zd_lw not defined/used on the halo + zdiag(ji,jj,2) = zdiag(ji,jj,2) + zd_lw(ji,jj,2) ! Remove zd_lw from zdiag + zd_lw(ji,jj,2) = 0._wp + ! + ! Set psi vertical flux at the surface: + zkar (ji,jj) = rl_sf + (vkarmn-rl_sf)*(1._wp-EXP(-rtrans*gdept(ji,jj,1,Kmm)/zhsro(ji,jj) )) ! Lengh scale slope + zdep (ji,jj) = ((zhsro(ji,jj) + gdept(ji,jj,1,Kmm)) / zhsro(ji,jj))**(rmm*ra_sf) + zflxs(ji,jj) = (rnn + (1._wp-zice_fra(ji,jj))*rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(ji,jj)) & + & *(1._wp + (1._wp-zice_fra(ji,jj))*rsbc_tke1*zdep(ji,jj))**(2._wp*rmm/3._wp-1_wp) + zdep (ji,jj) = rsbc_psi1 * (zwall_psi(ji,jj,1)*p_avm(ji,jj,1)+zwall_psi(ji,jj,2)*p_avm(ji,jj,2)) * & + & ustar2_surf(ji,jj)**rmm * zkar(ji,jj)**rnn * (zhsro(ji,jj) + gdept(ji,jj,1,Kmm))**(rnn-1.) + zflxs(ji,jj) = zdep(ji,jj) * zflxs(ji,jj) + psi (ji,jj,2) = psi(ji,jj,2) + zflxs(ji,jj) / e3w(ji,jj,2,Kmm) + END_2D + ! + END SELECT + + ! Bottom boundary condition on psi + ! -------------------------------- + ! +!!gm should be done for ISF (top boundary cond.) +!!gm so, totally new staff needed ===>>> think about that ! +! + SELECT CASE ( nn_bc_bot ) ! bottom boundary + ! + CASE ( 0 ) ! Dirichlet + ! ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = vkarmn * r_z0_bot + ! ! Balance between the production and the dissipation terms + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point + ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 + zdep(ji,jj) = vkarmn * r_z0_bot + psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn + zd_lw(ji,jj,ibot) = 0._wp + zd_up(ji,jj,ibot) = 0._wp + zdiag(ji,jj,ibot) = 1._wp + ! + ! Just above last level, Dirichlet condition again (GOTM like) + zdep(ji,jj) = vkarmn * ( r_z0_bot + e3t(ji,jj,ibotm1,Kmm) ) + psi (ji,jj,ibotm1) = rc0**rpp * en(ji,jj,ibot )**rmm * zdep(ji,jj)**rnn + zd_lw(ji,jj,ibotm1) = 0._wp + zd_up(ji,jj,ibotm1) = 0._wp + zdiag(ji,jj,ibotm1) = 1._wp + END_2D + ! + IF( ln_isfcav) THEN ! top boundary (ocean cavity) + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( mikt(ji,jj) > 1 ) THEN + itop = mikt(ji,jj) ! k top w-point + itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one + ! + zdep(ji,jj) = vkarmn * r_z0_top + psi (ji,jj,itop) = rc0**rpp * en(ji,jj,itop)**rmm *zdep(ji,jj)**rnn + zd_lw(ji,jj,itop) = 0._wp + zd_up(ji,jj,itop) = 0._wp + zdiag(ji,jj,itop) = 1._wp + ! + ! Just above last level, Dirichlet condition again (GOTM like) + zdep(ji,jj) = vkarmn * ( r_z0_top + e3t(ji,jj,itopp1,Kmm) ) + psi (ji,jj,itopp1) = rc0**rpp * en(ji,jj,itop )**rmm *zdep(ji,jj)**rnn + zd_lw(ji,jj,itopp1) = 0._wp + zd_up(ji,jj,itopp1) = 0._wp + zdiag(ji,jj,itopp1) = 1._wp + END IF + END_2D + END IF + ! + CASE ( 1 ) ! Neumman boundary condition + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ibot = mbkt(ji,jj) + 1 ! k bottom level of w-point + ibotm1 = mbkt(ji,jj) ! k-1 bottom level of w-point but >=1 + ! + ! Bottom level Dirichlet condition: + zdep(ji,jj) = vkarmn * r_z0_bot + psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn + ! + zd_lw(ji,jj,ibot) = 0._wp + zd_up(ji,jj,ibot) = 0._wp + zdiag(ji,jj,ibot) = 1._wp + ! + ! Just above last level: Neumann condition with flux injection + zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) ! Remove zd_up from zdiag + zd_up(ji,jj,ibotm1) = 0. + ! + ! Set psi vertical flux at the bottom: + zdep(ji,jj) = r_z0_bot + 0.5_wp*e3t(ji,jj,ibotm1,Kmm) + zflxb = rsbc_psi2 * ( p_avm(ji,jj,ibot) + p_avm(ji,jj,ibotm1) ) & + & * (0.5_wp*(en(ji,jj,ibot)+en(ji,jj,ibotm1)))**rmm * zdep(ji,jj)**(rnn-1._wp) + psi(ji,jj,ibotm1) = psi(ji,jj,ibotm1) + zflxb / e3w(ji,jj,ibotm1,Kmm) + END_2D + ! + IF( ln_isfcav) THEN ! top boundary (ocean cavity) + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( mikt(ji,jj) > 1 ) THEN + itop = mikt(ji,jj) ! k top w-point + itopp1 = mikt(ji,jj) + 1 ! k+1 1st w-point below the top one + ! + ! Bottom level Dirichlet condition: + zdep(ji,jj) = vkarmn * r_z0_top + psi (ji,jj,itop) = rc0**rpp * en(ji,jj,itop)**rmm *zdep(ji,jj)**rnn + ! + zd_lw(ji,jj,itop) = 0._wp + zd_up(ji,jj,itop) = 0._wp + zdiag(ji,jj,itop) = 1._wp + ! + ! Just below cavity level: Neumann condition with flux + ! injection + zdiag(ji,jj,itopp1) = zdiag(ji,jj,itopp1) + zd_up(ji,jj,itopp1) ! Remove zd_up from zdiag + zd_up(ji,jj,itopp1) = 0._wp + ! + ! Set psi vertical flux below cavity: + zdep(ji,jj) = r_z0_top + 0.5_wp*e3t(ji,jj,itopp1,Kmm) + zflxb = rsbc_psi2 * ( p_avm(ji,jj,itop) + p_avm(ji,jj,itopp1)) & + & * (0.5_wp*(en(ji,jj,itop)+en(ji,jj,itopp1)))**rmm * zdep(ji,jj)**(rnn-1._wp) + psi(ji,jj,itopp1) = psi(ji,jj,itopp1) + zflxb / e3w(ji,jj,itopp1,Kmm) + END IF + END_2D + END IF + + ! + END SELECT + + ! Matrix inversion + ! ---------------- + ! + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 + zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) + END_3D + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 + zd_lw(ji,jj,jk) = psi(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) + END_3D + DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 ) ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk + psi(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * psi(ji,jj,jk+1) ) / zdiag(ji,jj,jk) + END_3D + + ! Set dissipation + !---------------- + + SELECT CASE ( nn_clos ) + ! + CASE( 0 ) ! k-kl (Mellor-Yamada) + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / MAX( psi(ji,jj,jk), rn_epsmin) + END_3D + ! + CASE( 1 ) ! k-eps + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + eps(ji,jj,jk) = psi(ji,jj,jk) + END_3D + ! + CASE( 2 ) ! k-w + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + eps(ji,jj,jk) = rc04 * en(ji,jj,jk) * psi(ji,jj,jk) + END_3D + ! + CASE( 3 ) ! generic + zcoef = rc0**( 3._wp + rpp/rnn ) + zex1 = ( 1.5_wp + rmm/rnn ) + zex2 = -1._wp / rnn + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + eps(ji,jj,jk) = zcoef * en(ji,jj,jk)**zex1 * psi(ji,jj,jk)**zex2 + END_3D + ! + END SELECT + + ! Limit dissipation rate under stable stratification + ! -------------------------------------------------- + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) ! Note that this set boundary conditions on hmxl_n at the same time + ! limitation + eps (ji,jj,jk) = MAX( eps(ji,jj,jk), rn_epsmin ) + hmxl_n(ji,jj,jk) = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / eps(ji,jj,jk) + END_3D + IF( ln_length_lim ) THEN ! Galperin criterium (NOTE : Not required if the proper value of C3 in stable cases is calculated) + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + zrn2 = MAX( rn2(ji,jj,jk), rsmall ) + hmxl_n(ji,jj,jk) = MIN( rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), hmxl_n(ji,jj,jk) ) + END_3D + ENDIF + + ! + ! Stability function and vertical viscosity and diffusivity + ! --------------------------------------------------------- + ! + SELECT CASE ( nn_stab_func ) + ! + CASE ( 0 , 1 ) ! Galperin or Kantha-Clayson stability functions + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + ! zcof = l²/q² + zcof = hmxl_b(ji,jj,jk) * hmxl_b(ji,jj,jk) / ( 2._wp*eb(ji,jj,jk) ) + ! Gh = -N²l²/q² + gh = - rn2(ji,jj,jk) * zcof + gh = MIN( gh, rgh0 ) + gh = MAX( gh, rghmin ) + ! Stability functions from Kantha and Clayson (if C2=C3=0 => Galperin) + sh = ra2*( 1._wp-6._wp*ra1/rb1 ) / ( 1.-3.*ra2*gh*(6.*ra1+rb2*( 1._wp-rc3 ) ) ) + sm = ( rb1**(-1._wp/3._wp) + ( 18._wp*ra1*ra1 + 9._wp*ra1*ra2*(1._wp-rc2) )*sh*gh ) / (1._wp-9._wp*ra1*ra2*gh) + ! + ! Store stability function in zstt and zstm + zstt(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk) + zstm(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk) + END_3D + ! + CASE ( 2, 3 ) ! Canuto stability functions + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + ! zcof = l²/q² + zcof = hmxl_b(ji,jj,jk)*hmxl_b(ji,jj,jk) / ( 2._wp * eb(ji,jj,jk) ) + ! Gh = -N²l²/q² + gh = - rn2(ji,jj,jk) * zcof + gh = MIN( gh, rgh0 ) + gh = MAX( gh, rghmin ) + gh = gh * rf6 + ! Gm = M²l²/q² Shear number + shr = p_sh2(ji,jj,jk) / MAX( p_avm(ji,jj,jk), rsmall ) + gm = MAX( shr * zcof , 1.e-10 ) + gm = gm * rf6 + gm = MIN ( (rd0 - rd1*gh + rd3*gh*gh) / (rd2-rd4*gh) , gm ) + ! Stability functions from Canuto + rcff = rd0 - rd1*gh +rd2*gm + rd3*gh*gh - rd4*gh*gm + rd5*gm*gm + sm = (rs0 - rs1*gh + rs2*gm) / rcff + sh = (rs4 - rs5*gh + rs6*gm) / rcff + ! + ! Store stability function in zstt and zstm + zstt(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk) + zstm(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk) + END_3D + ! + END SELECT + + ! Boundary conditions on stability functions for momentum (Neumann): + ! Lines below are useless if GOTM style Dirichlet conditions are used + + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zstm(ji,jj,1) = zstm(ji,jj,2) + zstm(ji,jj,jpk) = 0. ! default value, in case jpk > mbkt(ji,jj)+1 + ! ! Not needed but avoid a bug when looking for undefined values (-fpe0) + END_2D + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! update bottom with good values + zstm(ji,jj,mbkt(ji,jj)+1) = zstm(ji,jj,mbkt(ji,jj)) + END_2D + + zstt(:,:, 1) = wmask(A2D(nn_hls), 1) ! default value not needed but avoid a bug when looking for undefined values (-fpe0) + zstt(:,:,jpk) = wmask(A2D(nn_hls),jpk) ! default value not needed but avoid a bug when looking for undefined values (-fpe0) + +!!gm should be done for ISF (top boundary cond.) +!!gm so, totally new staff needed!!gm + + ! Compute diffusivities/viscosities + ! The computation below could be restrained to jk=2 to jpkm1 if GOTM style Dirichlet conditions are used + ! -> yes BUT p_avm(:,:1) and p_avm(:,:jpk) are used when we compute zd_lw(:,:2) and zd_up(:,:jpkm1). These values are + ! later overwritten by surface/bottom boundaries conditions, so we don't really care of p_avm(:,:1) and p_avm(:,:jpk) + ! for zd_lw and zd_up but they have to be defined to avoid a bug when looking for undefined values (-fpe0) + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + zsqen = SQRT( 2._wp * en(ji,jj,jk) ) * hmxl_n(ji,jj,jk) + zavt = zsqen * zstt(ji,jj,jk) + zavm = zsqen * zstm(ji,jj,jk) + p_avt(ji,jj,jk) = MAX( zavt, avtb(jk) ) * wmask(ji,jj,jk) ! apply mask for zdfmxl routine + p_avm(ji,jj,jk) = MAX( zavm, avmb(jk) ) ! Note that avm is not masked at the surface and the bottom + END_3D + p_avt(A2D(nn_hls),1) = 0._wp + ! + IF(sn_cfctl%l_prtctl) THEN + CALL prt_ctl( tab3d_1=REAL(en ,dp) , clinfo1=' gls - e: ', tab3d_2=REAL(p_avt,dp), clinfo2=' t: ' ) + CALL prt_ctl( tab3d_1=REAL(p_avm,dp), clinfo1=' gls - m: ' ) + ENDIF + ! + END SUBROUTINE zdf_gls + + + SUBROUTINE zdf_gls_init + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_gls_init *** + !! + !! ** Purpose : Initialization of the vertical eddy diffivity and + !! viscosity computed using a GLS turbulent closure scheme + !! + !! ** Method : Read the namzdf_gls namelist and check the parameters + !! + !! ** input : Namlist namzdf_gls + !! + !! ** Action : Increase by 1 the nstop flag is setting problem encounter + !! + !!---------------------------------------------------------------------- + INTEGER :: jk ! dummy loop indices + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp):: zcr ! local scalar + !! + NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, & + & rn_clim_galp, ln_sigpsi, rn_hsro, rn_hsri, & + & nn_mxlice, rn_crban, rn_charn, rn_frac_hs, & + & nn_bc_surf, nn_bc_bot, nn_z0_met, nn_z0_ice, & + & nn_stab_func, nn_clos + !!---------------------------------------------------------- + ! + READ ( numnam_ref, namzdf_gls, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_gls in reference namelist' ) + + READ ( numnam_cfg, namzdf_gls, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_gls in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf_gls ) + + IF(lwp) THEN !* Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_gls_init : GLS turbulent closure scheme' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namzdf_gls : set gls mixing parameters' + WRITE(numout,*) ' minimum value of en rn_emin = ', rn_emin + WRITE(numout,*) ' minimum value of eps rn_epsmin = ', rn_epsmin + WRITE(numout,*) ' Limit dissipation rate under stable stratif. ln_length_lim = ', ln_length_lim + WRITE(numout,*) ' Galperin limit (Standard: 0.53, Holt: 0.26) rn_clim_galp = ', rn_clim_galp + WRITE(numout,*) ' TKE Surface boundary condition nn_bc_surf = ', nn_bc_surf + WRITE(numout,*) ' TKE Bottom boundary condition nn_bc_bot = ', nn_bc_bot + WRITE(numout,*) ' Modify psi Schmidt number (wb case) ln_sigpsi = ', ln_sigpsi + WRITE(numout,*) ' Craig and Banner coefficient rn_crban = ', rn_crban + WRITE(numout,*) ' Charnock coefficient rn_charn = ', rn_charn + WRITE(numout,*) ' Surface roughness formula nn_z0_met = ', nn_z0_met + WRITE(numout,*) ' surface wave breaking under ice nn_z0_ice = ', nn_z0_ice + SELECT CASE( nn_z0_ice ) + CASE( 0 ) ; WRITE(numout,*) ' ==>>> no impact of ice cover on surface wave breaking' + CASE( 1 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weigthed by 1-TANH( fr_i(:,:) * 10 )' + CASE( 2 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weighted by 1-fr_i(:,:)' + CASE( 3 ) ; WRITE(numout,*) ' ==>>> roughness uses rn_hsri and is weighted by 1-MIN( 1, 4 * fr_i(:,:) )' + CASE DEFAULT + CALL ctl_stop( 'zdf_gls_init: wrong value for nn_z0_ice, should be 0,1,2, or 3') + END SELECT + WRITE(numout,*) ' Wave height frac. (used if nn_z0_met=2) rn_frac_hs = ', rn_frac_hs + WRITE(numout,*) ' Stability functions nn_stab_func = ', nn_stab_func + WRITE(numout,*) ' Type of closure nn_clos = ', nn_clos + WRITE(numout,*) ' Surface roughness (m) rn_hsro = ', rn_hsro + WRITE(numout,*) ' type of scaling under sea-ice nn_mxlice = ', nn_mxlice + IF( nn_mxlice == 1 ) & + WRITE(numout,*) ' Ice-ocean roughness (used if nn_z0_ice/=0) rn_hsri = ', rn_hsri + SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice + CASE( 0 ) ; WRITE(numout,*) ' ==>>> No scaling under sea-ice' + CASE( 1 ) ; WRITE(numout,*) ' ==>>> scaling with constant sea-ice thickness' + CASE( 2 ) ; WRITE(numout,*) ' ==>>> scaling with mean sea-ice thickness' + CASE( 3 ) ; WRITE(numout,*) ' ==>>> scaling with max sea-ice thickness' + CASE DEFAULT + CALL ctl_stop( 'zdf_tke_init: wrong value for nn_mxlice, should be 0,1,2,3 ') + END SELECT + WRITE(numout,*) + ENDIF + + ! !* allocate GLS arrays + IF( zdf_gls_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_gls_init : unable to allocate arrays' ) + + ! !* Check of some namelist values + IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_bc_surf is 0 or 1' ) + IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_bc_surf is 0 or 1' ) + IF( nn_z0_met < 0 .OR. nn_z0_met > 3 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_z0_met is 0, 1, 2 or 3' ) + IF( nn_z0_met == 3 .AND. .NOT. (ln_wave .AND. ln_sdw ) ) CALL ctl_stop( 'zdf_gls_init: nn_z0_met=3 requires ln_wave=T and ln_sdw=T' ) + IF( nn_stab_func < 0 .OR. nn_stab_func > 3 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_stab_func is 0, 1, 2 and 3' ) + IF( nn_clos < 0 .OR. nn_clos > 3 ) CALL ctl_stop( 'zdf_gls_init: bad flag: nn_clos is 0, 1, 2 or 3' ) + + SELECT CASE ( nn_clos ) !* set the parameters for the chosen closure + ! + CASE( 0 ) ! k-kl (Mellor-Yamada) + ! + IF(lwp) WRITE(numout,*) ' ==>> k-kl closure chosen (i.e. closed to the classical Mellor-Yamada)' + IF(lwp) WRITE(numout,*) + rpp = 0._wp + rmm = 1._wp + rnn = 1._wp + rsc_tke = 1.96_wp + rsc_psi = 1.96_wp + rpsi1 = 0.9_wp + rpsi3p = 1._wp + rpsi2 = 0.5_wp + ! + SELECT CASE ( nn_stab_func ) + CASE( 0, 1 ) ; rpsi3m = 2.53_wp ! G88 or KC stability functions + CASE( 2 ) ; rpsi3m = 2.62_wp ! Canuto A stability functions + CASE( 3 ) ; rpsi3m = 2.38 ! Canuto B stability functions (caution : constant not identified) + END SELECT + ! + CASE( 1 ) ! k-eps + ! + IF(lwp) WRITE(numout,*) ' ==>> k-eps closure chosen' + IF(lwp) WRITE(numout,*) + rpp = 3._wp + rmm = 1.5_wp + rnn = -1._wp + rsc_tke = 1._wp + rsc_psi = 1.2_wp ! Schmidt number for psi + rpsi1 = 1.44_wp + rpsi3p = 1._wp + rpsi2 = 1.92_wp + ! + SELECT CASE ( nn_stab_func ) + CASE( 0, 1 ) ; rpsi3m = -0.52_wp ! G88 or KC stability functions + CASE( 2 ) ; rpsi3m = -0.629_wp ! Canuto A stability functions + CASE( 3 ) ; rpsi3m = -0.566 ! Canuto B stability functions + END SELECT + ! + CASE( 2 ) ! k-omega + ! + IF(lwp) WRITE(numout,*) ' ==>> k-omega closure chosen' + IF(lwp) WRITE(numout,*) + rpp = -1._wp + rmm = 0.5_wp + rnn = -1._wp + rsc_tke = 2._wp + rsc_psi = 2._wp + rpsi1 = 0.555_wp + rpsi3p = 1._wp + rpsi2 = 0.833_wp + ! + SELECT CASE ( nn_stab_func ) + CASE( 0, 1 ) ; rpsi3m = -0.58_wp ! G88 or KC stability functions + CASE( 2 ) ; rpsi3m = -0.64_wp ! Canuto A stability functions + CASE( 3 ) ; rpsi3m = -0.64_wp ! Canuto B stability functions caution : constant not identified) + END SELECT + ! + CASE( 3 ) ! generic + ! + IF(lwp) WRITE(numout,*) ' ==>> generic closure chosen' + IF(lwp) WRITE(numout,*) + rpp = 2._wp + rmm = 1._wp + rnn = -0.67_wp + rsc_tke = 0.8_wp + rsc_psi = 1.07_wp + rpsi1 = 1._wp + rpsi3p = 1._wp + rpsi2 = 1.22_wp + ! + SELECT CASE ( nn_stab_func ) + CASE( 0, 1 ) ; rpsi3m = 0.1_wp ! G88 or KC stability functions + CASE( 2 ) ; rpsi3m = 0.05_wp ! Canuto A stability functions + CASE( 3 ) ; rpsi3m = 0.05_wp ! Canuto B stability functions caution : constant not identified) + END SELECT + ! + END SELECT + + ! + SELECT CASE ( nn_stab_func ) !* set the parameters of the stability functions + ! + CASE ( 0 ) ! Galperin stability functions + ! + IF(lwp) WRITE(numout,*) ' ==>> Stability functions from Galperin' + rc2 = 0._wp + rc3 = 0._wp + rc_diff = 1._wp + rc0 = 0.5544_wp + rcm_sf = 0.9884_wp + rghmin = -0.28_wp + rgh0 = 0.0233_wp + rghcri = 0.02_wp + ! + CASE ( 1 ) ! Kantha-Clayson stability functions + ! + IF(lwp) WRITE(numout,*) ' ==>> Stability functions from Kantha-Clayson' + rc2 = 0.7_wp + rc3 = 0.2_wp + rc_diff = 1._wp + rc0 = 0.5544_wp + rcm_sf = 0.9884_wp + rghmin = -0.28_wp + rgh0 = 0.0233_wp + rghcri = 0.02_wp + ! + CASE ( 2 ) ! Canuto A stability functions + ! + IF(lwp) WRITE(numout,*) ' ==>> Stability functions from Canuto A' + rs0 = 1.5_wp * rl1 * rl5*rl5 + rs1 = -rl4*(rl6+rl7) + 2._wp*rl4*rl5*(rl1-(1._wp/3._wp)*rl2-rl3) + 1.5_wp*rl1*rl5*rl8 + rs2 = -(3._wp/8._wp) * rl1*(rl6*rl6-rl7*rl7) + rs4 = 2._wp * rl5 + rs5 = 2._wp * rl4 + rs6 = (2._wp/3._wp) * rl5 * ( 3._wp*rl3*rl3 - rl2*rl2 ) - 0.5_wp * rl5*rl1 * (3._wp*rl3-rl2) & + & + 0.75_wp * rl1 * ( rl6 - rl7 ) + rd0 = 3._wp * rl5*rl5 + rd1 = rl5 * ( 7._wp*rl4 + 3._wp*rl8 ) + rd2 = rl5*rl5 * ( 3._wp*rl3*rl3 - rl2*rl2 ) - 0.75_wp*(rl6*rl6 - rl7*rl7 ) + rd3 = rl4 * ( 4._wp*rl4 + 3._wp*rl8) + rd4 = rl4 * ( rl2 * rl6 - 3._wp*rl3*rl7 - rl5*(rl2*rl2 - rl3*rl3 ) ) + rl5*rl8 * ( 3._wp*rl3*rl3 - rl2*rl2 ) + rd5 = 0.25_wp * ( rl2*rl2 - 3._wp *rl3*rl3 ) * ( rl6*rl6 - rl7*rl7 ) + rc0 = 0.5268_wp + rf6 = 8._wp / (rc0**6._wp) + rc_diff = SQRT(2._wp) / (rc0**3._wp) + rcm_sf = 0.7310_wp + rghmin = -0.28_wp + rgh0 = 0.0329_wp + rghcri = 0.03_wp + ! + CASE ( 3 ) ! Canuto B stability functions + ! + IF(lwp) WRITE(numout,*) ' ==>> Stability functions from Canuto B' + rs0 = 1.5_wp * rm1 * rm5*rm5 + rs1 = -rm4 * (rm6+rm7) + 2._wp * rm4*rm5*(rm1-(1._wp/3._wp)*rm2-rm3) + 1.5_wp * rm1*rm5*rm8 + rs2 = -(3._wp/8._wp) * rm1 * (rm6*rm6-rm7*rm7 ) + rs4 = 2._wp * rm5 + rs5 = 2._wp * rm4 + rs6 = (2._wp/3._wp) * rm5 * (3._wp*rm3*rm3-rm2*rm2) - 0.5_wp * rm5*rm1*(3._wp*rm3-rm2) + 0.75_wp * rm1*(rm6-rm7) + rd0 = 3._wp * rm5*rm5 + rd1 = rm5 * (7._wp*rm4 + 3._wp*rm8) + rd2 = rm5*rm5 * (3._wp*rm3*rm3 - rm2*rm2) - 0.75_wp * (rm6*rm6 - rm7*rm7) + rd3 = rm4 * ( 4._wp*rm4 + 3._wp*rm8 ) + rd4 = rm4 * ( rm2*rm6 -3._wp*rm3*rm7 - rm5*(rm2*rm2 - rm3*rm3) ) + rm5 * rm8 * ( 3._wp*rm3*rm3 - rm2*rm2 ) + rd5 = 0.25_wp * ( rm2*rm2 - 3._wp*rm3*rm3 ) * ( rm6*rm6 - rm7*rm7 ) + rc0 = 0.5268_wp !! rc0 = 0.5540_wp (Warner ...) to verify ! + rf6 = 8._wp / ( rc0**6._wp ) + rc_diff = SQRT(2._wp)/(rc0**3.) + rcm_sf = 0.7470_wp + rghmin = -0.28_wp + rgh0 = 0.0444_wp + rghcri = 0.0414_wp + ! + END SELECT + + ! !* Set Schmidt number for psi diffusion in the wave breaking case + ! ! See Eq. (13) of Carniel et al, OM, 30, 225-239, 2009 + ! ! or Eq. (17) of Burchard, JPO, 31, 3133-3145, 2001 + IF( ln_sigpsi ) THEN + ra_sf = -1.5 ! Set kinetic energy slope, then deduce rsc_psi and rl_sf + ! Verification: retrieve Burchard (2001) results by uncomenting the line below: + ! Note that the results depend on the value of rn_cm_sf which is constant (=rc0) in his work + ! ra_sf = -SQRT(2./3.*rc0**3./rn_cm_sf*rn_sc_tke)/vkarmn + rsc_psi0 = rsc_tke/(24.*rpsi2)*(-1.+(4.*rnn + ra_sf*(1.+4.*rmm))**2./(ra_sf**2.)) + ELSE + rsc_psi0 = rsc_psi + ENDIF + + ! !* Shear free turbulence parameters + ! + ra_sf = -4._wp*rnn*SQRT(rsc_tke) / ( (1._wp+4._wp*rmm)*SQRT(rsc_tke) & + & - SQRT(rsc_tke + 24._wp*rsc_psi0*rpsi2 ) ) + + IF ( rn_crban==0._wp ) THEN + rl_sf = vkarmn + ELSE + rl_sf = rc0 * SQRT(rc0/rcm_sf) * SQRT( ( (1._wp + 4._wp*rmm + 8._wp*rmm**2_wp) * rsc_tke & + & + 12._wp*rsc_psi0*rpsi2 - (1._wp + 4._wp*rmm) & + & *SQRT(rsc_tke*(rsc_tke & + & + 24._wp*rsc_psi0*rpsi2)) ) & + & /(12._wp*rnn**2.) ) + ENDIF + + ! + IF(lwp) THEN !* Control print + WRITE(numout,*) + WRITE(numout,*) ' Limit values :' + WRITE(numout,*) ' Parameter m = ', rmm + WRITE(numout,*) ' Parameter n = ', rnn + WRITE(numout,*) ' Parameter p = ', rpp + WRITE(numout,*) ' rpsi1 = ', rpsi1 + WRITE(numout,*) ' rpsi2 = ', rpsi2 + WRITE(numout,*) ' rpsi3m = ', rpsi3m + WRITE(numout,*) ' rpsi3p = ', rpsi3p + WRITE(numout,*) ' rsc_tke = ', rsc_tke + WRITE(numout,*) ' rsc_psi = ', rsc_psi + WRITE(numout,*) ' rsc_psi0 = ', rsc_psi0 + WRITE(numout,*) ' rc0 = ', rc0 + WRITE(numout,*) + WRITE(numout,*) ' Shear free turbulence parameters:' + WRITE(numout,*) ' rcm_sf = ', rcm_sf + WRITE(numout,*) ' ra_sf = ', ra_sf + WRITE(numout,*) ' rl_sf = ', rl_sf + ENDIF + + ! !* Constants initialization + rc02 = rc0 * rc0 ; rc02r = 1. / rc02 + rc03 = rc02 * rc0 + rc04 = rc03 * rc0 + rsbc_tke1 = -3._wp/2._wp*rn_crban*ra_sf*rl_sf ! Dirichlet + Wave breaking + rsbc_tke2 = rn_Dt * rn_crban / rl_sf ! Neumann + Wave breaking + zcr = MAX(rsmall, rsbc_tke1**(1./(-ra_sf*3._wp/2._wp))-1._wp ) + rtrans = 0.2_wp / zcr ! Ad. inverse transition length between log and wave layer + rsbc_zs1 = rn_charn/grav ! Charnock formula for surface roughness + rsbc_zs2 = rn_frac_hs / 0.85_wp / grav * 665._wp ! Rascle formula for surface roughness + rsbc_psi1 = -0.5_wp * rn_Dt * rc0**(rpp-2._wp*rmm) / rsc_psi + rsbc_psi2 = -0.5_wp * rn_Dt * rc0**rpp * rnn * vkarmn**rnn / rsc_psi ! Neumann + NO Wave breaking + ! + rfact_tke = -0.5_wp / rsc_tke * rn_Dt ! Cst used for the Diffusion term of tke + rfact_psi = -0.5_wp / rsc_psi * rn_Dt ! Cst used for the Diffusion term of tke + ! + ! !* Wall proximity function +!!gm tmask or wmask ???? + zwall(:,:,:) = 1._wp * tmask(:,:,:) + + ! !* read or initialize all required files + CALL gls_rst( nit000, 'READ' ) ! (en, avt_k, avm_k, hmxl_n) + ! + END SUBROUTINE zdf_gls_init + + + SUBROUTINE gls_rst( kt, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE gls_rst *** + !! + !! ** Purpose : Read or write TKE file (en) in restart file + !! + !! ** Method : use of IOM library + !! if the restart does not contain TKE, en is either + !! set to rn_emin or recomputed (nn_igls/=0) + !!---------------------------------------------------------------------- + USE zdf_oce , ONLY : en, avt_k, avm_k ! ocean vertical physics + !! + INTEGER , INTENT(in) :: kt ! ocean time-step + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + ! + INTEGER :: jit, jk ! dummy loop indices + INTEGER :: id1, id2, id3, id4 + INTEGER :: ji, jj, ikbu, ikbv + REAL(wp):: cbx, cby + !!---------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise + ! ! --------------- + IF( ln_rstart ) THEN !* Read the restart file + id1 = iom_varid( numror, 'en' , ldstop = .FALSE. ) + id2 = iom_varid( numror, 'avt_k' , ldstop = .FALSE. ) + id3 = iom_varid( numror, 'avm_k' , ldstop = .FALSE. ) + id4 = iom_varid( numror, 'hmxl_n', ldstop = .FALSE. ) + ! + IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN ! all required arrays exist + CALL iom_get( numror, jpdom_auto, 'en' , en , kfill = jpfillcopy ) ! we devide by en -> must be != 0. + CALL iom_get( numror, jpdom_auto, 'avt_k' , avt_k ) + CALL iom_get( numror, jpdom_auto, 'avm_k' , avm_k ) + CALL iom_get( numror, jpdom_auto, 'hmxl_n', hmxl_n, kfill = jpfillcopy ) ! we devide by hmxl_n -> must be != 0. + ELSE + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>> previous run without GLS scheme, set en and hmxl_n to background values' + en (:,:,:) = rn_emin + hmxl_n(:,:,:) = 0.05_wp + ! avt_k, avm_k already set to the background value in zdf_phy_init + ENDIF + ELSE !* Start from rest + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>> start from rest, set en and hmxl_n by background values' + en (:,:,:) = rn_emin + hmxl_n(:,:,:) = 0.05_wp + ! avt_k, avm_k already set to the background value in zdf_phy_init + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! ------------------- + IF(lwp) WRITE(numout,*) '---- gls-rst ----' + CALL iom_rstput( kt, nitrst, numrow, 'en' , en ) + CALL iom_rstput( kt, nitrst, numrow, 'avt_k' , avt_k ) + CALL iom_rstput( kt, nitrst, numrow, 'avm_k' , avm_k ) + CALL iom_rstput( kt, nitrst, numrow, 'hmxl_n', hmxl_n ) + ! + ENDIF + ! + END SUBROUTINE gls_rst + + !!====================================================================== +END MODULE zdfgls diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfiwm.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfiwm.F90 new file mode 100644 index 0000000..836715d --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfiwm.F90 @@ -0,0 +1,439 @@ +MODULE zdfiwm + !!======================================================================== + !! *** MODULE zdfiwm *** + !! Ocean physics: Internal gravity wave-driven vertical mixing + !!======================================================================== + !! History : 1.0 ! 2004-04 (L. Bessieres, G. Madec) Original code + !! - ! 2006-08 (A. Koch-Larrouy) Indonesian strait + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.6 ! 2016-03 (C. de Lavergne) New param: internal wave-driven mixing + !! 4.0 ! 2017-04 (G. Madec) renamed module, remove the old param. and the CPP keys + !! 4.0 ! 2020-12 (C. de Lavergne) Update param to match published one + !! 4.0 ! 2021-09 (C. de Lavergne) Add energy from trapped and shallow internal tides + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_iwm : global momentum & tracer Kz with wave induced Kz + !! zdf_iwm_init : global momentum & tracer Kz with wave induced Kz + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE zdf_oce ! ocean vertical physics variables + USE zdfddm ! ocean vertical physics: double diffusive mixing + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE eosbn2 ! ocean equation of state + USE phycst ! physical constants + ! + USE fldread ! field read + USE prtctl ! Print control + USE in_out_manager ! I/O manager + USE iom ! I/O Manager + USE lib_mpp ! MPP library + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_iwm ! called in step module + PUBLIC zdf_iwm_init ! called in nemogcm module + + ! !!* Namelist namzdf_iwm : internal wave-driven mixing * + LOGICAL :: ln_mevar ! variable (=T) or constant (=F) mixing efficiency + LOGICAL :: ln_tsdiff ! account for differential T/S wave-driven mixing (=T) or not (=F) + + REAL(wp):: r1_6 = 1._wp / 6._wp + REAL(wp):: rnu = 1.4e-6_wp ! molecular kinematic viscosity + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ebot_iwm ! bottom-intensified dissipation above abyssal hills (W/m2) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ecri_iwm ! bottom-intensified dissipation at topographic slopes (W/m2) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ensq_iwm ! dissipation scaling with squared buoyancy frequency (W/m2) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: esho_iwm ! dissipation due to shoaling internal tides (W/m2) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbot_iwm ! decay scale for abyssal hill dissipation (m) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hcri_iwm ! inverse decay scale for topographic slope dissipation (m-1) + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfiwm.F90 15533 2021-11-24 12:07:20Z cdllod $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_iwm_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_iwm_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( ebot_iwm(jpi,jpj), ecri_iwm(jpi,jpj), ensq_iwm(jpi,jpj) , & + & esho_iwm(jpi,jpj), hbot_iwm(jpi,jpj), hcri_iwm(jpi,jpj) , STAT=zdf_iwm_alloc ) + ! + CALL mpp_sum ( 'zdfiwm', zdf_iwm_alloc ) + IF( zdf_iwm_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_iwm_alloc: failed to allocate arrays' ) + END FUNCTION zdf_iwm_alloc + + + SUBROUTINE zdf_iwm( kt, Kmm, p_avm, p_avt, p_avs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_iwm *** + !! + !! ** Purpose : add to the vertical mixing coefficients the effect of + !! breaking internal waves. + !! + !! ** Method : - internal wave-driven vertical mixing is given by: + !! Kz_wave = min( f( Reb = zemx_iwm / (Nu * N^2) ), 100 cm2/s ) + !! where zemx_iwm is the 3D space distribution of the wave-breaking + !! energy and Nu the molecular kinematic viscosity. + !! The function f(Reb) is linear (constant mixing efficiency) + !! if the namelist parameter ln_mevar = F and nonlinear if ln_mevar = T. + !! + !! - Compute zemx_iwm, the 3D power density that allows to compute + !! Reb and therefrom the wave-induced vertical diffusivity. + !! This is divided into four components: + !! 1. Bottom-intensified dissipation at topographic slopes, expressed + !! as an exponential decay above the bottom. + !! zemx_iwm(z) = ( ecri_iwm / rho0 ) * EXP( -(H-z)/hcri_iwm ) + !! / ( 1. - EXP( - H/hcri_iwm ) ) * hcri_iwm + !! where hcri_iwm is the characteristic length scale of the bottom + !! intensification, ecri_iwm a static 2D map of available power, and + !! H the ocean depth. + !! 2. Bottom-intensified dissipation above abyssal hills, expressed + !! as an algebraic decay above bottom. + !! zemx_iwm(z) = ( ebot_iwm / rho0 ) * ( 1 + hbot_iwm/H ) + !! / ( 1 + (H-z)/hbot_iwm )^2 + !! where hbot_iwm is the characteristic length scale of the bottom + !! intensification and ebot_iwm is a static 2D map of available power. + !! 3. Dissipation scaling in the vertical with the squared buoyancy + !! frequency (N^2). + !! zemx_iwm(z) = ( ensq_iwm / rho0 ) * rn2(z) + !! / ZSUM( rn2 * e3w ) + !! where ensq_iwm is a static 2D map of available power. + !! 4. Dissipation due to shoaling internal tides, scaling in the + !! vertical with the buoyancy frequency (N). + !! zemx_iwm(z) = ( esho_iwm / rho0 ) * sqrt(rn2(z)) + !! / ZSUM( sqrt(rn2) * e3w ) + !! where esho_iwm is a static 2D map of available power. + !! + !! - update the model vertical eddy viscosity and diffusivity: + !! avt = avt + av_wave + !! avs = avs + av_wave + !! avm = avm + av_wave + !! + !! - if namelist parameter ln_tsdiff = T, account for differential mixing: + !! avs = avs + av_wave * diffusivity_ratio(Reb) + !! + !! ** Action : - avt, avs, avm, increased by internal wave-driven mixing + !! + !! References : de Lavergne et al. JAMES 2020, https://doi.org/10.1029/2020MS002065 + !! de Lavergne et al. JPO 2016, https://doi.org/10.1175/JPO-D-14-0259.1 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points) + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avt, p_avs ! tracer Kz (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), SAVE :: zztmp + ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zfact ! Used for vertical structure + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zReb ! Turbulence intensity parameter + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zemx_iwm ! local energy density available for mixing (W/kg) + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zav_ratio ! S/T diffusivity ratio (only for ln_tsdiff=T) + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zav_wave ! Internal wave-induced diffusivity + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d ! 3D workspace used for iom_put + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d ! 2D - - - - + !!---------------------------------------------------------------------- + ! + ! !* Initialize appropriately certain variables + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + zav_ratio(ji,jj,jk) = 1._wp * wmask(ji,jj,jk) ! important to set it to 1 here + END_3D + IF( iom_use("emix_iwm") ) zemx_iwm (:,:,:) = 0._wp + IF( iom_use("av_wave") .OR. sn_cfctl%l_prtctl ) zav_wave (:,:,:) = 0._wp + ! + ! ! ----------------------------- ! + ! ! Internal wave-driven mixing ! (compute zav_wave) + ! ! ----------------------------- ! + ! + ! !* 'cri' component: distribute energy over the time-varying + ! !* ocean depth using an exponential decay from the seafloor. + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! part independent of the level + IF( ht(ji,jj) /= 0._wp ) THEN ; zfact(ji,jj) = ecri_iwm(ji,jj) * r1_rho0 / ( 1._wp - EXP( -ht(ji,jj) * hcri_iwm(ji,jj) ) ) + ELSE ; zfact(ji,jj) = 0._wp + ENDIF + END_2D + + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! complete with the level-dependent part + zemx_iwm(ji,jj,jk) = zfact(ji,jj) * ( EXP( ( gdept(ji,jj,jk ,Kmm) - ht(ji,jj) ) * hcri_iwm(ji,jj) ) & + & - EXP( ( gdept(ji,jj,jk-1,Kmm) - ht(ji,jj) ) * hcri_iwm(ji,jj) ) & + & ) * wmask(ji,jj,jk) / e3w(ji,jj,jk,Kmm) + END_3D + + !* 'bot' component: distribute energy over the time-varying + !* ocean depth using an algebraic decay above the seafloor. + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! part independent of the level + IF( ht(ji,jj) /= 0._wp ) THEN ; zfact(ji,jj) = ebot_iwm(ji,jj) * ( 1._wp + hbot_iwm(ji,jj) / ht(ji,jj) ) * r1_rho0 + ELSE ; zfact(ji,jj) = 0._wp + ENDIF + END_2D + + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! complete with the level-dependent part + zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + & + & zfact(ji,jj) * ( 1._wp / ( 1._wp + ( ht(ji,jj) - gdept(ji,jj,jk ,Kmm) ) / hbot_iwm(ji,jj) ) & + & - 1._wp / ( 1._wp + ( ht(ji,jj) - gdept(ji,jj,jk-1,Kmm) ) / hbot_iwm(ji,jj) ) & + & ) * wmask(ji,jj,jk) / e3w(ji,jj,jk,Kmm) + END_3D + + !* 'nsq' component: distribute energy over the time-varying + !* ocean depth as proportional to rn2 + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zfact(ji,jj) = 0._wp + END_2D + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! part independent of the level + zfact(ji,jj) = zfact(ji,jj) + e3w(ji,jj,jk,Kmm) * MAX( 0._wp, rn2(ji,jj,jk) ) + END_3D + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF( zfact(ji,jj) /= 0._wp ) zfact(ji,jj) = ensq_iwm(ji,jj) * r1_rho0 / zfact(ji,jj) + END_2D + ! + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! complete with the level-dependent part + zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + zfact(ji,jj) * MAX( 0._wp, rn2(ji,jj,jk) ) + END_3D + + !* 'sho' component: distribute energy over the time-varying + !* ocean depth as proportional to sqrt(rn2) + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zfact(ji,jj) = 0._wp + END_2D + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! part independent of the level + zfact(ji,jj) = zfact(ji,jj) + e3w(ji,jj,jk,Kmm) * SQRT( MAX( 0._wp, rn2(ji,jj,jk) ) ) + END_3D + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF( zfact(ji,jj) /= 0._wp ) zfact(ji,jj) = esho_iwm(ji,jj) * r1_rho0 / zfact(ji,jj) + END_2D + ! + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! complete with the level-dependent part + zemx_iwm(ji,jj,jk) = zemx_iwm(ji,jj,jk) + zfact(ji,jj) * SQRT( MAX( 0._wp, rn2(ji,jj,jk) ) ) + END_3D + + ! Calculate turbulence intensity parameter Reb + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + zReb(ji,jj,jk) = zemx_iwm(ji,jj,jk) / MAX( 1.e-20_wp, rnu * rn2(ji,jj,jk) ) + END_3D + ! + ! Define internal wave-induced diffusivity + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + zav_wave(ji,jj,jk) = zReb(ji,jj,jk) * r1_6 * rnu ! This corresponds to a constant mixing efficiency of 1/6 + END_3D + ! + IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224) regimes + IF( zReb(ji,jj,jk) > 480.00_wp ) THEN + zav_wave(ji,jj,jk) = 3.6515_wp * rnu * SQRT( zReb(ji,jj,jk) ) + ELSEIF( zReb(ji,jj,jk) < 10.224_wp ) THEN + zav_wave(ji,jj,jk) = 0.052125_wp * rnu * zReb(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) + ENDIF + END_3D + ENDIF + ! + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Bound diffusivity by molecular value and 100 cm2/s + zav_wave(ji,jj,jk) = MIN( MAX( 1.4e-7_wp, zav_wave(ji,jj,jk) ), 1.e-2_wp ) * wmask(ji,jj,jk) + END_3D + ! + ! ! ----------------------- ! + ! ! Update mixing coefs ! + ! ! ----------------------- ! + ! + IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Calculate S/T diffusivity ratio as a function of Reb (else it is set to 1) + zav_ratio(ji,jj,jk) = ( 0.505_wp + & + & 0.495_wp * TANH( 0.92_wp * ( LOG10( MAX( 1.e-20, zReb(ji,jj,jk) * 5._wp * r1_6 ) ) - 0.60_wp ) ) & + & ) * wmask(ji,jj,jk) + END_3D + ENDIF + CALL iom_put( "av_ratio", zav_ratio ) + ! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !* update momentum & tracer diffusivity with wave-driven mixing + p_avs(ji,jj,jk) = p_avs(ji,jj,jk) + zav_wave(ji,jj,jk) * zav_ratio(ji,jj,jk) + p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zav_wave(ji,jj,jk) + p_avm(ji,jj,jk) = p_avm(ji,jj,jk) + zav_wave(ji,jj,jk) + END_3D + ! !* output internal wave-driven mixing coefficient + CALL iom_put( "av_wave", zav_wave ) + !* output useful diagnostics: Kz*N^2 , + ! vertical integral of rho0 * Kz * N^2 , energy density (zemx_iwm) + IF( iom_use("bflx_iwm") .OR. iom_use("pcmap_iwm") ) THEN + ALLOCATE( z2d(A2D(nn_hls)) , z3d(A2D(nn_hls),jpk) ) + z2d(:,:) = 0._wp ; z3d(:,:,:) = 0._wp ! Initialisation for iom_put + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + z3d(ji,jj,jk) = MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) + z2d(ji,jj) = z2d(ji,jj) + rho0 * e3w(ji,jj,jk,Kmm) * z3d(ji,jj,jk) * wmask(ji,jj,jk) + END_3D + CALL iom_put( "bflx_iwm", z3d ) + CALL iom_put( "pcmap_iwm", z2d ) + DEALLOCATE( z2d , z3d ) + ENDIF + CALL iom_put( "emix_iwm", zemx_iwm ) + + ! + IF( kt == nit000 ) THEN !* Control print at first time-step: diagnose the energy consumed by zav_wave + IF( .NOT. l_istiled .OR. ntile == 1 ) zztmp = 0._wp ! Do only on the first tile + DO_3D( 0, 0, 0, 0, 2, jpkm1 ) + zztmp = zztmp + e3w(ji,jj,jk,Kmm) * e1e2t(ji,jj) & + & * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) + END_3D + + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + CALL mpp_sum( 'zdfiwm', zztmp ) + zztmp = rho0 * zztmp ! Global integral of rho0 * Kz * N^2 = power contributing to mixing + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'zdf_iwm : Internal wave-driven mixing (iwm)' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) + WRITE(numout,*) ' Total power consumption by av_wave = ', zztmp * 1.e-12_wp, 'TW' + ENDIF + ENDIF + ENDIF + + IF(sn_cfctl%l_prtctl) CALL prt_ctl(tab3d_1=REAL(zav_wave,dp) , clinfo1=' iwm - av_wave: ', tab3d_2=REAL(avt,dp), clinfo2=' avt: ') + ! + END SUBROUTINE zdf_iwm + + + SUBROUTINE zdf_iwm_init + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_iwm_init *** + !! + !! ** Purpose : Initialization of the internal wave-driven vertical mixing, reading + !! of input power maps and decay length scales in a netcdf file. + !! + !! ** Method : - Read the namzdf_iwm namelist and check the parameters + !! + !! - Read the input data in a NetCDF file (zdfiwm_forcing.nc) with variables: + !! 'power_bot' bottom-intensified dissipation above abyssal hills + !! 'power_cri' bottom-intensified dissipation at topographic slopes + !! 'power_nsq' dissipation scaling with squared buoyancy frequency + !! 'power_sho' dissipation due to shoaling internal tides + !! 'scale_bot' decay scale for abyssal hill dissipation + !! 'scale_cri' decay scale for topographic-slope dissipation + !! + !! ** input : - Namlist namzdf_iwm + !! - NetCDF file : zdfiwm_forcing.nc + !! + !! ** Action : - Increase by 1 the nstop flag is setting problem encounter + !! - Define ebot_iwm, ecri_iwm, ensq_iwm, esho_iwm, hbot_iwm, hcri_iwm + !! + !! References : de Lavergne et al. JAMES 2020, https://doi.org/10.1029/2020MS002065 + !!---------------------------------------------------------------------- + INTEGER :: ifpr ! dummy loop indices + INTEGER :: inum ! local integer + INTEGER :: ios + ! + CHARACTER(len=256) :: cn_dir ! Root directory for location of ssr files + INTEGER, PARAMETER :: jpiwm = 6 ! maximum number of variables to read + INTEGER, PARAMETER :: jp_mpb = 1 + INTEGER, PARAMETER :: jp_mpc = 2 + INTEGER, PARAMETER :: jp_mpn = 3 + INTEGER, PARAMETER :: jp_mps = 4 + INTEGER, PARAMETER :: jp_dsb = 5 + INTEGER, PARAMETER :: jp_dsc = 6 + ! + TYPE(FLD_N), DIMENSION(jpiwm) :: slf_iwm ! array of namelist informations + TYPE(FLD_N) :: sn_mpb, sn_mpc, sn_mpn, sn_mps ! information about Mixing Power field to be read + TYPE(FLD_N) :: sn_dsb, sn_dsc ! information about Decay Scale field to be read + TYPE(FLD ), DIMENSION(jpiwm) :: sf_iwm ! structure of input fields (file informations, fields read) + ! + REAL(wp), DIMENSION(jpi,jpj,4) :: ztmp + REAL(wp), DIMENSION(4) :: zdia + ! + NAMELIST/namzdf_iwm/ ln_mevar, ln_tsdiff, & + & cn_dir, sn_mpb, sn_mpc, sn_mpn, sn_mps, sn_dsb, sn_dsc + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namzdf_iwm, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in reference namelist' ) + ! + READ ( numnam_cfg, namzdf_iwm, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf_iwm ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_iwm_init : internal wave-driven mixing' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namzdf_iwm : set wave-driven mixing parameters' + WRITE(numout,*) ' Variable (T) or constant (F) mixing efficiency = ', ln_mevar + WRITE(numout,*) ' Differential internal wave-driven mixing (T) or not (F) = ', ln_tsdiff + ENDIF + + ! This internal-wave-driven mixing parameterization elevates avt and avm in the interior, and + ! ensures that avt remains larger than its molecular value (=1.4e-7). Therefore, avtb should + ! be set here to a very small value, and avmb to its (uniform) molecular value (=1.4e-6). + avmb(:) = rnu ! molecular value + avtb(:) = 1.e-10_wp ! very small diffusive minimum (background avt is specified in zdf_iwm) + avtb_2d(:,:) = 1._wp ! uniform + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) ' Force the background value applied to avm & avt in TKE to be everywhere ', & + & 'the viscous molecular value & a very small diffusive value, resp.' + ENDIF + + ! ! allocate iwm arrays + IF( zdf_iwm_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_iwm_init : unable to allocate iwm arrays' ) + ! + ! store namelist information in an array + slf_iwm(jp_mpb) = sn_mpb ; slf_iwm(jp_mpc) = sn_mpc ; slf_iwm(jp_mpn) = sn_mpn ; slf_iwm(jp_mps) = sn_mps + slf_iwm(jp_dsb) = sn_dsb ; slf_iwm(jp_dsc) = sn_dsc + ! + DO ifpr= 1, jpiwm + ALLOCATE( sf_iwm(ifpr)%fnow(jpi,jpj,1) ) + IF( slf_iwm(ifpr)%ln_tint ) ALLOCATE( sf_iwm(ifpr)%fdta(jpi,jpj,1,2) ) + END DO + + ! fill sf_iwm with sf_iwm and control print + CALL fld_fill( sf_iwm, slf_iwm , cn_dir, 'zdfiwm_init', 'iwm input file', 'namiwm' ) + + ! ! hard-coded default values + sf_iwm(jp_mpb)%fnow(:,:,1) = 1.e-10_wp + sf_iwm(jp_mpc)%fnow(:,:,1) = 1.e-10_wp + sf_iwm(jp_mpn)%fnow(:,:,1) = 1.e-5_wp + sf_iwm(jp_mps)%fnow(:,:,1) = 1.e-10_wp + sf_iwm(jp_dsb)%fnow(:,:,1) = 100._wp + sf_iwm(jp_dsc)%fnow(:,:,1) = 100._wp + + ! ! read necessary fields + CALL fld_read( nit000, 1, sf_iwm ) + + ebot_iwm(:,:) = sf_iwm(1)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation above abyssal hills [W/m2] + ecri_iwm(:,:) = sf_iwm(2)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation at topographic slopes [W/m2] + ensq_iwm(:,:) = sf_iwm(3)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation scaling with N^2 [W/m2] + esho_iwm(:,:) = sf_iwm(4)%fnow(:,:,1) * ssmask(:,:) ! energy flux for dissipation due to shoaling [W/m2] + hbot_iwm(:,:) = sf_iwm(5)%fnow(:,:,1) ! spatially variable decay scale for abyssal hill dissipation [m] + hcri_iwm(:,:) = sf_iwm(6)%fnow(:,:,1) ! spatially variable decay scale for topographic-slope [m] + + hcri_iwm(:,:) = 1._wp / hcri_iwm(:,:) ! only the inverse height is used, hence calculated here once for all + + ! diags + ztmp(:,:,1) = e1e2t(:,:) * ebot_iwm(:,:) + ztmp(:,:,2) = e1e2t(:,:) * ecri_iwm(:,:) + ztmp(:,:,3) = e1e2t(:,:) * ensq_iwm(:,:) + ztmp(:,:,4) = e1e2t(:,:) * esho_iwm(:,:) + + zdia(1:4) =glob_sum_vec( 'zdfiwm', CASTDP(ztmp(:,:,1:4)) ) + + IF(lwp) THEN + WRITE(numout,*) ' Dissipation above abyssal hills: ', zdia(1) * 1.e-12_wp, 'TW' + WRITE(numout,*) ' Dissipation along topographic slopes: ', zdia(2) * 1.e-12_wp, 'TW' + WRITE(numout,*) ' Dissipation scaling with N^2: ', zdia(3) * 1.e-12_wp, 'TW' + WRITE(numout,*) ' Dissipation due to shoaling: ', zdia(4) * 1.e-12_wp, 'TW' + ENDIF + ! + END SUBROUTINE zdf_iwm_init + + !!====================================================================== +END MODULE zdfiwm diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfmfc.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfmfc.F90 new file mode 100644 index 0000000..be231b8 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfmfc.F90 @@ -0,0 +1,487 @@ +MODULE zdfmfc + !!====================================================================== + !! *** MODULE zdfmfc *** + !! Ocean physics: Mass-Flux scheme parameterization of Convection: + !! Non-local transport for the convective ocean boundary + !! layer. Subgrid-scale large eddies are represented by a + !! mass-flux contribution (ln_zdfmfc = .TRUE.) + !!====================================================================== + !! History : NEMO ! + !! 3.6 ! 2016-06 (H. Giordani, R. Bourdallé-Badie) Original code + !! 4.2 ! 2020-12 (H. Giordani, R. Bourdallé-Badie) adapt to NEM04.2 + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! tra_mfc : Compute the Mass Flux and trends of T/S + !! diag_mfc : Modify diagonal of trazdf Matrix + !! rhs_mfc : Modify RHS of trazdf Matrix + !! zdf_mfc_init : initialization, namelist read, and parameters control + !!---------------------------------------------------------------------- + ! + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE domvvl ! ocean space and time domain : variable volume layer + USE domzgr + USE zdf_oce ! ocean vertical physics + USE sbc_oce ! surface boundary condition: ocean + USE phycst ! physical constants + USE eosbn2 ! equation of state (eos routine) + USE zdfmxl ! mixed layer + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! MPP manager + USE prtctl ! Print control + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE timing ! Timing + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_mfc ! routine called in step module + PUBLIC diag_mfc ! routine called in trazdf module + PUBLIC rhs_mfc ! routine called in trazdf module + PUBLIC zdf_mfc_init ! routine called in nemo module + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: edmfa, edmfb, edmfc !: diagonal term of the matrix. + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: edmftra !: y term for matrix inversion + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: edmfm !: y term for matrix inversion + ! + !! ** Namelist namzdf_edmf ** + REAL(wp) :: rn_cemf ! entrain of T/S + REAL(wp) :: rn_cwmf ! detrain of T/S + REAL(wp) :: rn_cent ! entrain of the convective mass flux + REAL(wp) :: rn_cdet ! detrain of the convective mass flux + REAL(wp) :: rn_cap ! Factor of computation for convective area (negative => area constant) + REAL(wp) :: App_max ! Maximum of the convective area + LOGICAL, PUBLIC, SAVE :: ln_edmfuv !: EDMF flag for velocity ! + ! + !! * Substitutions +# include "do_loop_substitute.h90" +# include "single_precision_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.2 , NEMO Consortium (2018) + !! $Id: zdfmfc.F90 13783 2020-20-02 15:30:22Z rbourdal $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_mfc_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_edmf_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( edmfa(jpi,jpj,jpk) , edmfb(jpi,jpj,jpk) , edmfc(jpi,jpj,jpk) & + & , edmftra(jpi,jpj,jpk,2), edmfm(jpi,jpj,jpk) , STAT= zdf_mfc_alloc ) + ! + IF( lk_mpp ) CALL mpp_sum ( 'zdfmfc', zdf_mfc_alloc ) + IF( zdf_mfc_alloc /= 0 ) CALL ctl_warn('zdf_mfc_alloc: failed to allocate arrays') + END FUNCTION zdf_mfc_alloc + + + SUBROUTINE tra_mfc( kt, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_mfc *** + !! + !! ** Purpose : Compute a mass flux, depending on surface flux, over + !! the instable part of the water column. + !! + !! ** Method : Compute surface instability and mix tracers until stable level + !! + !! + !! ** Action : Compute convection plume and (ta,sa)-trends for trazdf (EDMF scheme) + !! + !! References : + !! Giordani, Bourdallé-Badie and Madec JAMES 2020 + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: Kmm, Krhs ! time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation + REAL(wp), DIMENSION(A2D(nn_hls),jpk,2) :: ztsp ! T/S of the plume + REAL(wp), DIMENSION(A2D(nn_hls),jpk,2) :: ztse ! T/S at W point + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zrwp ! + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zrwp2 ! + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zapp ! + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zedmf ! + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zepsT, zepsW ! + ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zustar, zustar2 ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zuws, zvws, zsws, zfnet ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zfbuo, zrautbm1, zrautb, zraupl + REAL(wp), DIMENSION(A2D(nn_hls)) :: zwpsurf ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zop0 , zsp0 ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zrwp_0, zrwp2_0 ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zapp0 ! + REAL(wp), DIMENSION(A2D(nn_hls)) :: zphp, zph, zphpm1, zphm1, zNHydro + REAL(wp), DIMENSION(A2D(nn_hls)) :: zhcmo ! + ! + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zn2 ! N^2 + REAL(wp), DIMENSION(A2D(nn_hls),2 ) :: zab, zabm1, zabp ! alpha and beta + + REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value + + REAL(wp) :: zrho, zrhop + REAL(wp) :: zcnh, znum, zden, zcoef1, zcoef2 + REAL(wp) :: zca, zcb, zcd, zrw, zxl, zcdet, zctre + REAL(wp) :: zaw, zbw, zxw + REAL(wp) :: alpha + ! + INTEGER, INTENT(in ) :: kt ! ocean time-step index ! + ! + INTEGER :: ji, jj, jk ! dummy loop arguments + ! + !------------------------------------------------------------------ + ! Initialisation of coefficients + !------------------------------------------------------------------ + zca = 1._wp + zcb = 1._wp + zcd = 1._wp + + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + !------------------------------------------------------------------ + ! Surface boundary condition + !------------------------------------------------------------------ + ! surface Stress + !-------------------- + zuws(ji,jj) = utau(ji,jj) * r1_rho0 + zvws(ji,jj) = vtau(ji,jj) * r1_rho0 + zustar2(ji,jj) = SQRT(zuws(ji,jj)*zuws(ji,jj)+zvws(ji,jj)*zvws(ji,jj)) + zustar(ji,jj) = SQRT(zustar2(ji,jj)) + + ! Heat Flux + !-------------------- + zfnet(ji,jj) = qns(ji,jj) + qsr(ji,jj) + zfnet(ji,jj) = zfnet(ji,jj) / (rho0 * rcp) + + ! Water Flux + !--------------------- + zsws(ji,jj) = emp(ji,jj) + + !------------------------------------------- + ! Initialisation of prognostic variables + !------------------------------------------- + zrwp (ji,jj,:) = 0._wp ; zrwp2(ji,jj,:) = 0._wp ; zedmf(ji,jj,:) = 0._wp + zph (ji,jj) = 0._wp ; zphm1(ji,jj) = 0._wp ; zphpm1(ji,jj) = 0._wp + ztsp(ji,jj,:,:)= 0._wp + + ! Tracers inside plume (ztsp) and environment (ztse) + ztsp(ji,jj,1,jp_tem) = pts(ji,jj,1,jp_tem,Kmm) * tmask(ji,jj,1) + ztsp(ji,jj,1,jp_sal) = pts(ji,jj,1,jp_sal,Kmm) * tmask(ji,jj,1) + ztse(ji,jj,1,jp_tem) = pts(ji,jj,1,jp_tem,Kmm) * tmask(ji,jj,1) + ztse(ji,jj,1,jp_sal) = pts(ji,jj,1,jp_sal,Kmm) * tmask(ji,jj,1) + END_2D + + CALL eos( ztse(:,:,1,:) , zrautb(:,:) ) + CALL eos( ztsp(:,:,1,:) , zraupl(:,:) ) + + !------------------------------------------- + ! Boundary Condition of Mass Flux (plume velo.; convective area, entrain/detrain) + !------------------------------------------- + zhcmo(:,:) = e3t(A1Di(nn_hls),A1Dj(nn_hls),1,Kmm) + zfbuo(:,:) = 0._wp + WHERE ( ABS(zrautb(:,:)) > 1.e-20 ) zfbuo(:,:) = & + & grav * ( 2.e-4_wp *zfnet(:,:) & + & - 7.6E-4_wp*pts(A2D(nn_hls),1,jp_sal,Kmm) & + & * zsws(:,:)/zrautb(:,:)) * zhcmo(:,:) + + zedmf(:,:,1) = -0.065_wp*(ABS(zfbuo(:,:)))**(1._wp/3._wp)*SIGN(1.,zfbuo(:,:)) + zedmf(:,:,1) = MAX(0., zedmf(:,:,1)) + + zwpsurf(:,:) = 2._wp/3._wp*zustar(:,:) + 2._wp/3._wp*ABS(zfbuo(:,:))**(1._wp/3._wp) + zwpsurf(:,:) = MAX(1.e-5_wp,zwpsurf(:,:)) + zwpsurf(:,:) = MIN(1.,zwpsurf(:,:)) + + zapp(:,:,:) = App_max + WHERE(zwpsurf .NE. 0.) zapp(:,:,1) = MIN(MAX(0.,zedmf(:,:,1)/zwpsurf(:,:)), App_max) + + zedmf(:,:,1) = 0._wp + zrwp (:,:,1) = 0._wp + zrwp2(:,:,1) = 0._wp + zepsT(:,:,:) = 0.001_wp + zepsW(:,:,:) = 0.001_wp + + + !-------------------------------------------------------------- + ! Compute plume properties + ! In the same loop on vert. levels computation of: + ! - Vertical velocity: zWp + ! - Convective Area: zAp + ! - Tracers properties inside the plume (if necessary): ztp + !--------------------------------------------------------------- + + DO jk= 2, jpk + + ! Compute the buoyancy acceleration on T-points at jk-1 + zrautbm1(:,:) = zrautb(:,:) + CALL eos( CASTSP(pts (:,:,jk ,:,Kmm)) , zrautb(:,:) ) + CALL eos( ztsp(:,:,jk-1,: ) , zraupl(:,:) ) + + DO_2D( 0, 0, 0, 0 ) + zphm1(ji,jj) = zphm1(ji,jj) + grav * zrautbm1(ji,jj) * e3t(ji,jj,jk-1, Kmm) + zphpm1(ji,jj) = zphpm1(ji,jj) + grav * zraupl(ji,jj) * e3t(ji,jj,jk-1, Kmm) + zph(ji,jj) = zphm1(ji,jj) + grav * zrautb(ji,jj) * e3t(ji,jj,jk , Kmm) + zph(ji,jj) = MAX( zph(ji,jj), zepsilon) + END_2D + + WHERE(zrautbm1 .NE. 0.) zfbuo(:,:) = grav * (zraupl(:,:) - zrautbm1(:,:)) / zrautbm1(:,:) + + DO_2D( 0, 0, 0, 0 ) + + ! Compute Environment of Plume. Interpolation T/S (before time step) on W-points + zrw = (gdept(ji,jj,jk,Kmm) - gdepw(ji,jj,jk,Kmm)) & + & / (gdept(ji,jj,jk,Kmm) - gdept(ji,jj,jk-1,Kmm)) + ztse(ji,jj,jk,:) = (pts(ji,jj,jk,:,Kmm) * zrw + pts(ji,jj,jk-1,:,Kmm)*(1._wp - zrw) )*tmask(ji,jj,jk) + + !--------------------------------------------------------------- + ! Compute the vertical velocity on W-points + !--------------------------------------------------------------- + + ! Non-hydrostatic pressure terms in the wp2 equation + zcnh = 0.2_wp + znum = 0.5_wp + zcnh - & + (zcnh*grav*zraupl(ji,jj)/zph(ji,jj)+zcb*zepsW(ji,jj,jk-1)) & + *e3t(ji,jj,jk-1,Kmm)*0.5_wp + zden = 0.5_wp + zcnh + & + (zcnh*grav*zraupl(ji,jj)/zph(ji,jj)+zcb*zepsW(ji,jj,jk-1)) & + *e3t(ji,jj,jk-1,Kmm)*0.5_wp + + zcoef1 = zca*e3t(ji,jj,jk-1,Kmm) / zden + zcoef2 = znum/zden + + ! compute wp2 + zrwp2(ji,jj,jk) = zcoef1*zfbuo(ji,jj) & + + zcoef2*zrwp2(ji,jj,jk-1) + zrwp2(ji,jj,jk) = MAX ( zrwp2(ji,jj,jk)*wmask(ji,jj,jk) , 0.) + zrwp (ji,jj,jk) = SQRT( zrwp2(ji,jj,jk) ) + + !---------------------------------------------------------------------------------- + ! Compute convective area on W-point + ! Compute vertical profil of the convective area with mass conservation hypothesis + ! If rn_cap negative => constant value on the water column. + !---------------------------------------------------------------------------------- + IF( rn_cap .GT. 0. ) THEN + + zxw = MAX(zrwp(ji,jj,jk-1), zrwp(ji,jj,jk) ) + IF( zxw > 0. ) THEN + + zxl = (zrwp(ji,jj,jk-1)-zrwp(ji,jj,jk))/(e3t(ji,jj,jk-1,Kmm)*zxw) + IF (zxl .LT. 0._wp) THEN + zctre = -1.*rn_cap*zxl + zcdet = 0._wp + ELSE + zctre = 0._wp + zcdet = rn_cap*zxl + END IF + zapp(ji,jj,jk) = zapp(ji,jj,jk-1)* & + & (1._wp + (zxl + zctre - zcdet )*e3t(ji,jj,jk-1,Kmm)) + ELSE + zapp(ji,jj,jk) = App_max + END IF + zapp(ji,jj,jk) = MIN( MAX(zapp(ji,jj,jk),0.), App_max) + ELSE + zapp(ji,jj,jk) = -1. * rn_cap + END IF + + ! Compute Mass Flux on W-point + zedmf(ji,jj,jk) = -zapp(ji,jj,jk) * zrwp(ji,jj,jk)* wmask(ji,jj,jk) + + ! Compute Entrainment coefficient + IF(rn_cemf .GT. 0.) THEN + zxw = 0.5_wp*(zrwp(ji,jj,jk-1)+ zrwp(ji,jj,jk) ) + zepsT(ji,jj,jk) = 0.01_wp + IF( zxw > 0. ) THEN + zepsT(ji,jj,jk) = zepsT(ji,jj,jk) + & + & ABS( zrwp(ji,jj,jk-1)-zrwp(ji,jj,jk) ) & + & / ( e3t(ji,jj,jk-1,Kmm) * zxw ) + zepsT(ji,jj,jk) = zepsT(ji,jj,jk) * rn_cemf * wmask(ji,jj,jk) + ENDIF + ELSE + zepsT(ji,jj,jk) = -rn_cemf + ENDIF + + ! Compute the detrend coef for velocity (on W-point and not T-points, bug ???) + IF(rn_cwmf .GT. 0.) THEN + zepsW(ji,jj,jk) = rn_cwmf * zepsT(ji,jj,jk) + ELSE + zepsW(ji,jj,jk) = -rn_cwmf + ENDIF + + !--------------------------------------------------------------- + ! Compute the plume properties on T-points + !--------------------------------------------------------------- + IF(zrwp (ji,jj,jk) .LT. 1.e-12_wp .AND. zrwp (ji,jj,jk-1) .LT. 1.e-12_wp) THEN + ztsp(ji,jj,jk-1,jp_tem) = pts(ji,jj,jk-1,jp_tem,Kmm) + ztsp(ji,jj,jk-1,jp_sal) = pts(ji,jj,jk-1,jp_sal,Kmm) + ENDIF + + zcoef1 = (1._wp-zepsT(ji,jj,jk)*(1._wp-zrw)*e3w(ji,jj,jk,Kmm)*wmask(ji,jj,jk ) ) & + & / (1._wp+zepsT(ji,jj,jk)*zrw*e3w(ji,jj,jk,Kmm)*wmask(ji,jj,jk) ) + ! + zcoef2 = zepsT(ji,jj,jk)*e3w(ji,jj,jk,Kmm)*wmask(ji,jj,jk) & + & / (1._wp+zepsT(ji,jj,jk)*zrw*e3w(ji,jj,jk,Kmm)*wmask(ji,jj,jk)) + ! + ztsp(ji,jj,jk,jp_tem) = (zcoef1 * ztsp(ji,jj,jk-1,jp_tem) + & + & zcoef2 * ztse(ji,jj,jk ,jp_tem) )*tmask(ji,jj,jk) + ztsp(ji,jj,jk,jp_sal) = (zcoef1 * ztsp(ji,jj,jk-1,jp_sal) + & + & zcoef2 * ztse(ji,jj,jk ,jp_sal) )*tmask(ji,jj,jk) + + END_2D + END DO ! end of loop on jpk + + ! Compute Mass Flux on T-point + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + edmfm(ji,jj,jk) = (zedmf(ji,jj,jk+1) + zedmf(ji,jj,jk) )*0.5_wp + END_3D + DO_2D( 0, 0, 0, 0 ) + edmfm(ji,jj,jpk) = zedmf(ji,jj,jpk) + END_2D + + ! Save variable (on T point) + CALL iom_put( "mf_Tp" , ztsp(:,:,:,jp_tem) ) ! Save plume temperature + CALL iom_put( "mf_Sp" , ztsp(:,:,:,jp_sal) ) ! Save plume salinity + CALL iom_put( "mf_mf" , edmfm(:,:,:) ) ! Save Mass Flux + ! Save variable (on W point) + CALL iom_put( "mf_wp" , zrwp (:,:,:) ) ! Save convective velocity in the plume + CALL iom_put( "mf_app", zapp (:,:,:) ) ! Save convective area + + !================================================================================= + ! Computation of a tridiagonal matrix and right hand side terms of the linear system + !================================================================================= + DO_3D( 0, 0, 0, 0, 1, jpk ) + edmfa(ji,jj,jk) = 0._wp + edmfb(ji,jj,jk) = 0._wp + edmfc(ji,jj,jk) = 0._wp + edmftra(ji,jj,jk,:) = 0._wp + END_3D + + !--------------------------------------------------------------- + ! Diagonal terms + !--------------------------------------------------------------- + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + edmfa(ji,jj,jk) = 0._wp + edmfb(ji,jj,jk) = -edmfm(ji,jj,jk ) / e3w(ji,jj,jk+1,Kmm) + edmfc(ji,jj,jk) = edmfm(ji,jj,jk+1) / e3w(ji,jj,jk+1,Kmm) + END_3D + DO_2D( 0, 0, 0, 0 ) + edmfa(ji,jj,jpk) = -edmfm(ji,jj,jpk-1) / e3w(ji,jj,jpk,Kmm) + edmfb(ji,jj,jpk) = edmfm(ji,jj,jpk ) / e3w(ji,jj,jpk,Kmm) + edmfc(ji,jj,jpk) = 0._wp + END_2D + + !--------------------------------------------------------------- + ! right hand side term for Temperature + !--------------------------------------------------------------- + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + edmftra(ji,jj,jk,1) = - edmfm(ji,jj,jk ) * ztsp(ji,jj,jk ,jp_tem) / e3w(ji,jj,jk+1,Kmm) & + & + edmfm(ji,jj,jk+1) * ztsp(ji,jj,jk+1,jp_tem) / e3w(ji,jj,jk+1,Kmm) + END_3D + DO_2D( 0, 0, 0, 0 ) + edmftra(ji,jj,jpk,1) = - edmfm(ji,jj,jpk-1) * ztsp(ji,jj,jpk-1,jp_tem) / e3w(ji,jj,jpk,Kmm) & + & + edmfm(ji,jj,jpk ) * ztsp(ji,jj,jpk ,jp_tem) / e3w(ji,jj,jpk,Kmm) + END_2D + + !--------------------------------------------------------------- + ! Right hand side term for Salinity + !--------------------------------------------------------------- + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + edmftra(ji,jj,jk,2) = - edmfm(ji,jj,jk ) * ztsp(ji,jj,jk ,jp_sal) / e3w(ji,jj,jk+1,Kmm) & + & + edmfm(ji,jj,jk+1) * ztsp(ji,jj,jk+1,jp_sal) / e3w(ji,jj,jk+1,Kmm) + END_3D + DO_2D( 0, 0, 0, 0 ) + edmftra(ji,jj,jpk,2) = - edmfm(ji,jj,jpk-1) * ztsp(ji,jj,jpk-1,jp_sal) / e3w(ji,jj,jpk,Kmm) & + & + edmfm(ji,jj,jpk ) * ztsp(ji,jj,jpk ,jp_sal) / e3w(ji,jj,jpk,Kmm) + END_2D + ! + END SUBROUTINE tra_mfc + + + SUBROUTINE diag_mfc( zdiagi, zdiagd, zdiags, p2dt, Kaa ) + + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: zdiags! inout: tridaig. terms + REAL(dp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: zdiagi, zdiagd! inout: tridaig. terms + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + INTEGER , INTENT(in ) :: Kaa ! ocean time level indices + + INTEGER :: ji, jj, jk ! dummy loop arguments + + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zdiagi(ji,jj,jk) = zdiagi(ji,jj,jk) + e3t(ji,jj,jk,Kaa) * p2dt *edmfa(ji,jj,jk) + zdiags(ji,jj,jk) = zdiags(ji,jj,jk) + e3t(ji,jj,jk,Kaa) * p2dt *edmfc(ji,jj,jk) + zdiagd(ji,jj,jk) = zdiagd(ji,jj,jk) + e3t(ji,jj,jk,Kaa) * p2dt *edmfb(ji,jj,jk) + END_3D + + END SUBROUTINE diag_mfc + + SUBROUTINE rhs_mfc( zrhs, jjn ) + + REAL(dp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: zrhs ! inout: rhs trend + INTEGER , INTENT(in ) :: jjn ! tracer indices + + INTEGER :: ji, jj, jk ! dummy loop arguments + + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + zrhs(ji,jj,jk) = zrhs(ji,jj,jk) + edmftra(ji,jj,jk,jjn) + END_3D + + END SUBROUTINE rhs_mfc + + + + SUBROUTINE zdf_mfc_init + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_mfc_init *** + !! + !! ** Purpose : Initialization of the vertical eddy diffivity and + !! mass flux + !! + !! ** Method : Read the namzdf_mfc namelist and check the parameters + !! called at the first timestep (nit000) + !! + !! ** input : Namlist namzdf_mfc + !! + !! ** Action : Increase by 1 the nstop flag is setting problem encounter + !! + !!---------------------------------------------------------------------- + ! + INTEGER :: jk ! dummy loop indices + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp):: zcr ! local scalar + !! + NAMELIST/namzdf_mfc/ ln_edmfuv, rn_cemf, rn_cwmf, rn_cent, rn_cdet, rn_cap, App_max + !!---------------------------------------------------------- + ! + ! +! REWIND( numnam_ref ) ! Namelist namzdf_mfc in reference namelist : Vertical eddy diffivity mass flux + READ ( numnam_ref, namzdf_mfc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_edmf in reference namelist' ) + +! REWIND( numnam_cfg ) ! Namelist namzdf_mfc in configuration namelist : Vertical eddy diffivity mass flux + READ ( numnam_cfg, namzdf_mfc, IOSTAT = ios, ERR = 902 ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_edmf in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf_mfc ) + + IF(lwp) THEN !* Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_mfc_init' + WRITE(numout,*) '~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namzdf_mfc : set eddy diffusivity Mass Flux Convection' + WRITE(numout,*) ' Apply mass flux on velocities (Not yet avail.) ln_edmfuv = ', ln_edmfuv + WRITE(numout,*) ' Coeff for entrain/detrain T/S of plume (Neg => cte) rn_cemf = ', rn_cemf + WRITE(numout,*) ' Coeff for entrain/detrain Wp of plume (Neg => cte) rn_cwmf = ', rn_cwmf + WRITE(numout,*) ' Coeff for entrain/detrain area of plume rn_cap = ', rn_cap + WRITE(numout,*) ' Coeff for entrain area of plume rn_cent = ', rn_cent + WRITE(numout,*) ' Coeff for detrain area of plume rn_cdet = ', rn_cdet + WRITE(numout,*) ' Max convective area App_max = ', App_max + ENDIF + !* allocate edmf arrays + IF( zdf_mfc_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_edmf_init : unable to allocate arrays' ) + edmfa(:,:,:) = 0._wp + edmfb(:,:,:) = 0._wp + edmfc(:,:,:) = 0._wp + edmftra(:,:,:,:) = 0._wp + ! + END SUBROUTINE zdf_mfc_init + + !!====================================================================== + + !!====================================================================== +END MODULE zdfmfc \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfmxl.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfmxl.F90 new file mode 100644 index 0000000..7f965d3 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfmxl.F90 @@ -0,0 +1,165 @@ +MODULE zdfmxl + !!====================================================================== + !! *** MODULE zdfmxl *** + !! Ocean physics: mixed layer depth + !!====================================================================== + !! History : 1.0 ! 2003-08 (G. Madec) original code + !! 3.2 ! 2009-07 (S. Masson, G. Madec) IOM + merge of DO-loop + !! 3.7 ! 2012-03 (G. Madec) make public the density criteria for trdmxl + !! - ! 2014-02 (F. Roquet) mixed layer depth calculated using N2 instead of rhop + !!---------------------------------------------------------------------- + !! zdf_mxl : Compute the turbocline and mixed layer depths. + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE isf_oce ! ice shelf + USE dom_oce ! ocean space and time domain variables + USE trc_oce , ONLY: l_offline ! ocean space and time domain variables + USE zdf_oce ! ocean vertical physics + ! + USE in_out_manager ! I/O manager + USE prtctl ! Print control + USE phycst ! physical constants + USE iom ! I/O library + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_mxl, zdf_mxl_turb, zdf_mxl_alloc ! called by zdfphy.F90 + + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmln !: number of level in the mixed layer (used by LDF, ZDF, TRD, TOP) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmld !: mixing layer depth (turbocline) [m] (used by TOP) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlp !: mixed layer depth (rho=rho0+zdcrit) [m] (used by LDF) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlpt !: depth of the last T-point inside the mixed layer [m] (used by LDF) + + REAL(wp), PUBLIC :: rho_c = 0.01_wp !: density criterion for mixed layer depth + REAL(wp), PUBLIC :: avt_c = 5.e-4_wp ! Kz criterion for the turbocline depth + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfmxl.F90 15249 2021-09-13 09:59:09Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_mxl_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_mxl_alloc *** + !!---------------------------------------------------------------------- + zdf_mxl_alloc = 0 ! set to zero if no array to be allocated + IF( .NOT. ALLOCATED( nmln ) ) THEN + ALLOCATE( nmln(jpi,jpj), hmld(jpi,jpj), hmlp(jpi,jpj), hmlpt(jpi,jpj), STAT= zdf_mxl_alloc ) + ! + CALL mpp_sum ( 'zdfmxl', zdf_mxl_alloc ) + IF( zdf_mxl_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_mxl_alloc: failed to allocate arrays.' ) + ! + ENDIF + END FUNCTION zdf_mxl_alloc + + + SUBROUTINE zdf_mxl( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdfmxl *** + !! + !! ** Purpose : Compute the mixed layer depth with density criteria. + !! + !! ** Method : The mixed layer depth is the shallowest W depth with + !! the density of the corresponding T point (just bellow) bellow a + !! given value defined locally as rho(10m) + rho_c + !! + !! ** Action : nmln, hmlp, hmlpt + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iik, ikt ! local integer + REAL(wp) :: zN2_c ! local scalar + !!---------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'zdf_mxl : mixed layer depth' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + ENDIF + ! + ! w-level of the mixing and mixed layers + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + nmln(ji,jj) = nlb10 ! Initialization to the number of w ocean point + hmlp(ji,jj) = 0._wp ! here hmlp used as a dummy variable, integrating vertically N^2 + END_2D + zN2_c = grav * rho_c * r1_rho0 ! convert density criteria into N^2 criteria + DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, nlb10, jpkm1 ) ! Mixed layer level: w-level + ikt = mbkt(ji,jj) + hmlp(ji,jj) = & + & hmlp(ji,jj) + MAX( rn2b(ji,jj,jk) , 0._wp ) * e3w(ji,jj,jk,Kmm) + IF( hmlp(ji,jj) < zN2_c ) nmln(ji,jj) = MIN( jk , ikt ) + 1 ! Mixed layer level + END_3D + ! depth of the mixed layer + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + iik = nmln(ji,jj) + hmlp (ji,jj) = gdepw(ji,jj,iik ,Kmm) * ssmask(ji,jj) ! Mixed layer depth + hmlpt(ji,jj) = gdept(ji,jj,iik-1,Kmm) * ssmask(ji,jj) ! depth of the last T-point inside the mixed layer + END_2D + ! + IF( .NOT.l_offline .AND. iom_use("mldr10_1") ) THEN + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF( ln_isfcav ) THEN ; CALL iom_put( "mldr10_1", hmlp - risfdep) ! mixed layer thickness + ELSE ; CALL iom_put( "mldr10_1", hmlp ) ! mixed layer depth + END IF + ENDIF + ENDIF + ! + IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=REAL(nmln,dp), clinfo1=' nmln : ', tab2d_2=REAL(hmlp,dp), clinfo2=' hmlp : ' ) + ! + END SUBROUTINE zdf_mxl + + + SUBROUTINE zdf_mxl_turb( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_mxl_turb *** + !! + !! ** Purpose : Compute the turbocline depth. + !! + !! ** Method : The turbocline depth is the depth at which the vertical + !! eddy diffusivity coefficient (resulting from the vertical physics + !! alone, not the isopycnal part, see trazdf.F) fall below a given + !! value defined locally (avt_c here taken equal to 5 cm/s2 by default) + !! + !! ** Action : hmld + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kmm ! ocean time level index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iik ! local integer + INTEGER, DIMENSION(A2D(nn_hls)) :: imld ! 2D workspace + !!---------------------------------------------------------------------- + ! + ! w-level of the turbocline and mixing layer (iom_use) + imld(:,:) = mbkt(A2D(nn_hls)) + 1 ! Initialization to the number of w ocean point + DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! from the bottom to nlb10 + IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) ) imld(ji,jj) = jk ! Turbocline + END_3D + ! depth of the mixing layer + DO_2D_OVR( 1, 1, 1, 1 ) + iik = imld(ji,jj) + hmld (ji,jj) = gdepw(ji,jj,iik ,Kmm) * ssmask(ji,jj) ! Turbocline depth + END_2D + ! + IF( .NOT.l_offline .AND. iom_use("mldkz5") ) THEN + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF( ln_isfcav ) THEN ; CALL iom_put( "mldkz5" , hmld - risfdep ) ! turbocline thickness + ELSE ; CALL iom_put( "mldkz5" , hmld ) ! turbocline depth + END IF + ENDIF + ENDIF + ! + END SUBROUTINE zdf_mxl_turb + !!====================================================================== +END MODULE zdfmxl diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfosm.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfosm.F90 new file mode 100644 index 0000000..898eba7 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfosm.F90 @@ -0,0 +1,3484 @@ +MODULE zdfosm + !!====================================================================== + !! *** MODULE zdfosm *** + !! Ocean physics: vertical mixing coefficient compute from the OSMOSIS + !! turbulent closure parameterization + !!===================================================================== + !! History : NEMO 4.0 ! A. Grant, G. Nurser + !! 15/03/2017 Changed calculation of pycnocline thickness in unstable conditions and stable conditions AG + !! 15/03/2017 Calculation of pycnocline gradients for stable conditions changed. Pycnocline gradients now depend on stability of the OSBL. A.G + !! 06/06/2017 (1) Checks on sign of buoyancy jump in calculation of OSBL depth. A.G. + !! (2) Removed variable zbrad0, zbradh and zbradav since they are not used. + !! (3) Approximate treatment for shear turbulence. + !! Minimum values for zustar and zustke. + !! Add velocity scale, zvstr, that tends to zustar for large Langmuir numbers. + !! Limit maximum value for Langmuir number. + !! Use zvstr in definition of stability parameter zhol. + !! (4) Modified parametrization of entrainment flux, changing original coefficient 0.0485 for Langmuir contribution to 0.135 * zla + !! (5) For stable boundary layer add factor that depends on length of timestep to 'slow' collapse and growth. Make sure buoyancy jump not negative. + !! (6) For unstable conditions when growth is over multiple levels, limit change to maximum of one level per cycle through loop. + !! (7) Change lower limits for loops that calculate OSBL averages from 1 to 2. Large gradients between levels 1 and 2 can cause problems. + !! (8) Change upper limits from ibld-1 to ibld. + !! (9) Calculation of pycnocline thickness in unstable conditions. Check added to ensure that buoyancy jump is positive before calculating Ri. + !! (10) Thickness of interface layer at base of the stable OSBL set by Richardson number. Gives continuity in transition from unstable OSBL. + !! (11) Checks that buoyancy jump is poitive when calculating pycnocline profiles. + !! (12) Replace zwstrl with zvstr in calculation of eddy viscosity. + !! 27/09/2017 (13) Calculate Stokes drift and Stokes penetration depth from wave information + !! (14) Buoyancy flux due to entrainment changed to include contribution from shear turbulence. + !! 28/09/2017 (15) Calculation of Stokes drift moved into separate do-loops to allow for different options for the determining the Stokes drift to be added. + !! (16) Calculation of Stokes drift from windspeed for PM spectrum (for testing, commented out) + !! (17) Modification to Langmuir velocity scale to include effects due to the Stokes penetration depth (for testing, commented out) + !! ??/??/2018 (18) Revision to code structure, selected using key_osmldpth1. Inline code moved into subroutines. Changes to physics made, + !! (a) Pycnocline temperature and salinity profies changed for unstable layers + !! (b) The stable OSBL depth parametrization changed. + !! 16/05/2019 (19) Fox-Kemper parametrization of restratification through mixed layer eddies added to revised code. + !! 23/05/19 (20) Old code where key_osmldpth1` is *not* set removed, together with the key key_osmldpth1 + !! 4.2 ! 2021-05 (S. Mueller) Efficiency improvements, source-code clarity enhancements, and adaptation to tiling + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 'ln_zdfosm' OSMOSIS scheme + !!---------------------------------------------------------------------- + !! zdf_osm : update momentum and tracer Kz from osm scheme + !! zdf_osm_vertical_average : compute vertical averages over boundary layers + !! zdf_osm_velocity_rotation : rotate velocity components + !! zdf_osm_velocity_rotation_2d : rotation of 2d fields + !! zdf_osm_velocity_rotation_3d : rotation of 3d fields + !! zdf_osm_osbl_state : determine the state of the OSBL + !! zdf_osm_external_gradients : calculate gradients below the OSBL + !! zdf_osm_calculate_dhdt : calculate rate of change of hbl + !! zdf_osm_timestep_hbl : hbl timestep + !! zdf_osm_pycnocline_thickness : calculate thickness of pycnocline + !! zdf_osm_diffusivity_viscosity : compute eddy diffusivity and viscosity profiles + !! zdf_osm_fgr_terms : compute flux-gradient relationship terms + !! zdf_osm_pycnocline_buoyancy_profiles : calculate pycnocline buoyancy profiles + !! zdf_osm_zmld_horizontal_gradients : calculate horizontal buoyancy gradients for use with Fox-Kemper parametrization + !! zdf_osm_osbl_state_fk : determine state of OSBL and MLE layers + !! zdf_osm_mle_parameters : timestep MLE depth and calculate MLE fluxes + !! zdf_osm_init : initialization, namelist read, and parameters control + !! zdf_osm_alloc : memory allocation + !! osm_rst : read (or initialize) and write osmosis restart fields + !! tra_osm : compute and add to the T & S trend the non-local flux + !! trc_osm : compute and add to the passive tracer trend the non-local flux (TBD) + !! dyn_osm : compute and add to u & v trensd the non-local flux + !! zdf_osm_iomput : iom_put wrapper that accepts arrays without halo + !! zdf_osm_iomput_2d : iom_put wrapper for 2D fields + !! zdf_osm_iomput_3d : iom_put wrapper for 3D fields + !!---------------------------------------------------------------------- + USE oce ! Ocean dynamics and active tracers + ! ! Uses ww from previous time step (which is now wb) to calculate hbl + USE dom_oce ! Ocean space and time domain + USE zdf_oce ! Ocean vertical physics + USE sbc_oce ! Surface boundary condition: ocean + USE sbcwave ! Surface wave parameters + USE phycst ! Physical constants + USE eosbn2 ! Equation of state + USE traqsr ! Details of solar radiation absorption + USE zdfdrg, ONLY : rCdU_bot ! Bottom friction velocity + USE zdfddm ! Double diffusion mixing (avs array) + USE iom ! I/O library + USE lib_mpp ! MPP library + USE trd_oce ! Ocean trends definition + USE trdtra ! Tracers trends + USE in_out_manager ! I/O manager + USE lbclnk ! Ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + IMPLICIT NONE + PRIVATE + + ! Public subroutines + PUBLIC zdf_osm ! Routine called by step.F90 + PUBLIC zdf_osm_init ! Routine called by nemogcm.F90 + PUBLIC osm_rst ! Routine called by step.F90 + PUBLIC tra_osm ! Routine called by step.F90 + PUBLIC trc_osm ! Routine called by trcstp.F90 + PUBLIC dyn_osm ! Routine called by step.F90 + + ! Public variables + LOGICAL, PUBLIC :: ln_osm_mle !: Flag to activate the Mixed Layer Eddy (MLE) + ! ! parameterisation, needed by tra_mle_init in + ! ! tramle.F90 + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghamu !: Non-local u-momentum flux + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghamv !: Non-local v-momentum flux + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghamt !: Non-local temperature flux (gamma/o) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghams !: Non-local salinity flux (gamma/o) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbl !: Boundary layer depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hml !: ML depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmle !: Depth of layer affexted by mixed layer eddies in Fox-Kemper parametrization + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dbdx_mle !: Zonal buoyancy gradient in ML + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dbdy_mle !: Meridional buoyancy gradient in ML + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mld_prof !: Level of base of MLE layer + + INTERFACE zdf_osm_velocity_rotation + !!--------------------------------------------------------------------- + !! *** INTERFACE zdf_velocity_rotation *** + !!--------------------------------------------------------------------- + MODULE PROCEDURE zdf_osm_velocity_rotation_2d + MODULE PROCEDURE zdf_osm_velocity_rotation_3d + END INTERFACE + ! + INTERFACE zdf_osm_iomput + !!--------------------------------------------------------------------- + !! *** INTERFACE zdf_osm_iomput *** + !!--------------------------------------------------------------------- + MODULE PROCEDURE zdf_osm_iomput_2d + MODULE PROCEDURE zdf_osm_iomput_3d + END INTERFACE + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: etmean ! Averaging operator for avt + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dh ! Depth of pycnocline + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_ft ! Inverse of the modified Coriolis parameter at t-pts + ! Layer indices + INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nbld ! Level of boundary layer base + INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmld ! Level of mixed-layer depth (pycnocline top) + ! Layer type + INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) :: n_ddh ! Type of shear layer + ! ! n_ddh=0: active shear layer + ! ! n_ddh=1: shear layer not active + ! ! n_ddh=2: shear production low + ! Layer flags + LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: l_conv ! Unstable/stable bl + LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: l_shear ! Shear layers + LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: l_coup ! Coupling to bottom + LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: l_pyc ! OSBL pycnocline present + LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: l_flux ! Surface flux extends below OSBL into MLE layer + LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:) :: l_mle ! MLE layer increases in hickness. + ! Scales + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swth0 ! Surface heat flux (Kinematic) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sws0 ! Surface freshwater flux + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swb0 ! Surface buoyancy flux + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: suw0 ! Surface u-momentum flux + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sustar ! Friction velocity + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: scos_wind ! Cos angle of surface stress + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssin_wind ! Sin angle of surface stress + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swthav ! Heat flux - bl average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swsav ! Freshwater flux - bl average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swbav ! Buoyancy flux - bl average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sustke ! Surface Stokes drift + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dstokes ! Penetration depth of the Stokes drift + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swstrl ! Langmuir velocity scale + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: swstrc ! Convective velocity scale + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sla ! Trubulent Langmuir number + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: svstr ! Velocity scale that tends to sustar for large Langmuir number + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: shol ! Stability parameter for boundary layer + ! Layer averages: BL + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_t_bl ! Temperature average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_s_bl ! Salinity average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_u_bl ! Velocity average (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_v_bl ! Velocity average (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_b_bl ! Buoyancy average + ! Difference between layer average and parameter at the base of the layer: BL + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dt_bl ! Temperature difference + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_ds_bl ! Salinity difference + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_du_bl ! Velocity difference (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dv_bl ! Velocity difference (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_db_bl ! Buoyancy difference + ! Layer averages: ML + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_t_ml ! Temperature average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_s_ml ! Salinity average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_u_ml ! Velocity average (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_v_ml ! Velocity average (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_b_ml ! Buoyancy average + ! Difference between layer average and parameter at the base of the layer: ML + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dt_ml ! Temperature difference + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_ds_ml ! Salinity difference + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_du_ml ! Velocity difference (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_dv_ml ! Velocity difference (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_db_ml ! Buoyancy difference + ! Layer averages: MLE + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_t_mle ! Temperature average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_s_mle ! Salinity average + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_u_mle ! Velocity average (u) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_v_mle ! Velocity average (v) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: av_b_mle ! Buoyancy average + ! Diagnostic output + REAL(WP), ALLOCATABLE, SAVE, DIMENSION(:,:) :: osmdia2d ! Auxiliary array for diagnostic output + REAL(WP), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: osmdia3d ! Auxiliary array for diagnostic output + LOGICAL :: ln_dia_pyc_scl = .FALSE. ! Output of pycnocline scalar-gradient profiles + LOGICAL :: ln_dia_pyc_shr = .FALSE. ! Output of pycnocline velocity-shear profiles + + ! !!* namelist namzdf_osm * + LOGICAL :: ln_use_osm_la ! Use namelist rn_osm_la + REAL(wp) :: rn_osm_la ! Turbulent Langmuir number + REAL(wp) :: rn_osm_dstokes ! Depth scale of Stokes drift + REAL(wp) :: rn_zdfosm_adjust_sd = 1.0_wp ! Factor to reduce Stokes drift by + REAL(wp) :: rn_osm_hblfrac = 0.1_wp ! For nn_osm_wave = 3/4 specify fraction in top of hbl + LOGICAL :: ln_zdfosm_ice_shelter ! Flag to activate ice sheltering + REAL(wp) :: rn_osm_hbl0 = 10.0_wp ! Initial value of hbl for 1D runs + INTEGER :: nn_ave ! = 0/1 flag for horizontal average on avt + INTEGER :: nn_osm_wave = 0 ! = 0/1/2 flag for getting stokes drift from La# / PM wind-waves/Inputs into + ! ! sbcwave + INTEGER :: nn_osm_SD_reduce ! = 0/1/2 flag for getting effective stokes drift from surface value + LOGICAL :: ln_dia_osm ! Use namelist rn_osm_la + LOGICAL :: ln_kpprimix = .TRUE. ! Shear instability mixing + REAL(wp) :: rn_riinfty = 0.7_wp ! Local Richardson Number limit for shear instability + REAL(wp) :: rn_difri = 0.005_wp ! Maximum shear mixing at Rig = 0 (m2/s) + LOGICAL :: ln_convmix = .TRUE. ! Convective instability mixing + REAL(wp) :: rn_difconv = 1.0_wp ! Diffusivity when unstable below BL (m2/s) + ! OSMOSIS mixed layer eddy parametrization constants + INTEGER :: nn_osm_mle ! = 0/1 flag for horizontal average on avt + REAL(wp) :: rn_osm_mle_ce ! MLE coefficient + ! Parameters used in nn_osm_mle = 0 case + REAL(wp) :: rn_osm_mle_lf ! Typical scale of mixed layer front + REAL(wp) :: rn_osm_mle_time ! Time scale for mixing momentum across the mixed layer + ! Parameters used in nn_osm_mle = 1 case + REAL(wp) :: rn_osm_mle_lat ! Reference latitude for a 5 km scale of ML front + LOGICAL :: ln_osm_hmle_limit ! If true arbitrarily restrict hmle to rn_osm_hmle_limit*zmld + REAL(wp) :: rn_osm_hmle_limit ! If ln_osm_hmle_limit true arbitrarily restrict hmle to rn_osm_hmle_limit*zmld + REAL(wp) :: rn_osm_mle_rho_c ! Density criterion for definition of MLD used by FK + REAL(wp) :: rb_c ! ML buoyancy criteria = g rho_c /rho0 where rho_c is defined in zdfmld + REAL(wp) :: rc_f ! MLE coefficient (= rn_ce / (5 km * fo) ) in nn_osm_mle=1 case + REAL(wp) :: rn_osm_mle_thresh ! Threshold buoyancy for deepening of MLE layer below OSBL base + REAL(wp) :: rn_osm_bl_thresh ! Threshold buoyancy for deepening of OSBL base + REAL(wp) :: rn_osm_mle_tau ! Adjustment timescale for MLE + + ! General constants + REAL(wp) :: epsln = 1.0e-20_wp ! A small positive number to ensure no div by zero + REAL(wp) :: depth_tol = 1.0e-6_wp ! A small-ish positive number to give a hbl slightly shallower than gdepw + REAL(wp) :: pthird = 1.0_wp/3.0_wp ! 1/3 + REAL(wp) :: p2third = 2.0_wp/3.0_wp ! 2/3 + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfosm.F90 14921 2021-05-28 12:19:26Z smueller $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_osm_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_osm_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + zdf_osm_alloc = 0 + ! + ALLOCATE( ghamu(jpi,jpj,jpk), ghamv(jpi,jpj,jpk), ghamt(jpi,jpj,jpk), ghams(jpi,jpj,jpk), hbl(jpi,jpj), hml(jpi,jpj), & + & hmle(jpi,jpj), dbdx_mle(jpi,jpj), dbdy_mle(jpi,jpj), mld_prof(jpi,jpj), STAT=ierr ) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( etmean(A2D(nn_hls-1),jpk), dh(jpi,jpj), r1_ft(A2D(nn_hls-1)), STAT=ierr ) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( nbld(jpi,jpj), nmld(A2D(nn_hls-1)), STAT=ierr ) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( n_ddh(A2D(nn_hls-1)), STAT=ierr ) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( l_conv(A2D(nn_hls-1)), l_shear(A2D(nn_hls-1)), l_coup(A2D(nn_hls-1)), l_pyc(A2D(nn_hls-1)), & + & l_flux(A2D(nn_hls-1)), l_mle(A2D(nn_hls-1)), STAT=ierr ) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( swth0(A2D(nn_hls-1)), sws0(A2D(nn_hls-1)), swb0(A2D(nn_hls-1)), suw0(A2D(nn_hls-1)), & + & sustar(A2D(nn_hls-1)), scos_wind(A2D(nn_hls-1)), ssin_wind(A2D(nn_hls-1)), swthav(A2D(nn_hls-1)), & + & swsav(A2D(nn_hls-1)), swbav(A2D(nn_hls-1)), sustke(A2D(nn_hls-1)), dstokes(A2D(nn_hls-1)), & + & swstrl(A2D(nn_hls-1)), swstrc(A2D(nn_hls-1)), sla(A2D(nn_hls-1)), svstr(A2D(nn_hls-1)), & + & shol(A2D(nn_hls-1)), STAT=ierr ) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( av_t_bl(jpi,jpj), av_s_bl(jpi,jpj), av_u_bl(jpi,jpj), av_v_bl(jpi,jpj), & + & av_b_bl(jpi,jpj), STAT=ierr) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( av_dt_bl(jpi,jpj), av_ds_bl(jpi,jpj), av_du_bl(jpi,jpj), av_dv_bl(jpi,jpj), & + & av_db_bl(jpi,jpj), STAT=ierr) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( av_t_ml(jpi,jpj), av_s_ml(jpi,jpj), av_u_ml(jpi,jpj), av_v_ml(jpi,jpj), & + & av_b_ml(jpi,jpj), STAT=ierr) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( av_dt_ml(jpi,jpj), av_ds_ml(jpi,jpj), av_du_ml(jpi,jpj), av_dv_ml(jpi,jpj), & + & av_db_ml(jpi,jpj), STAT=ierr) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + ALLOCATE( av_t_mle(jpi,jpj), av_s_mle(jpi,jpj), av_u_mle(jpi,jpj), av_v_mle(jpi,jpj), & + & av_b_mle(jpi,jpj), STAT=ierr) + zdf_osm_alloc = zdf_osm_alloc + ierr + ! + IF ( ln_dia_osm ) THEN + ALLOCATE( osmdia2d(jpi,jpj), osmdia3d(jpi,jpj,jpk), STAT=ierr ) + zdf_osm_alloc = zdf_osm_alloc + ierr + END IF + ! + CALL mpp_sum ( 'zdfosm', zdf_osm_alloc ) + IF( zdf_osm_alloc /= 0 ) CALL ctl_warn( 'zdf_osm_alloc: failed to allocate zdf_osm arrays' ) + ! + END FUNCTION zdf_osm_alloc + + SUBROUTINE zdf_osm( kt, Kbb, Kmm, Krhs, p_avm, & + & p_avt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_osm *** + !! + !! ** Purpose : Compute the vertical eddy viscosity and diffusivity + !! coefficients and non local mixing using the OSMOSIS scheme + !! + !! ** Method : The boundary layer depth hosm is diagnosed at tracer points + !! from profiles of buoyancy, and shear, and the surface forcing. + !! Above hbl (sigma=-z/hbl <1) the mixing coefficients are computed from + !! + !! Kx = hosm Wx(sigma) G(sigma) + !! + !! and the non local term ghamt = Cs / Ws(sigma) / hosm + !! Below hosm the coefficients are the sum of mixing due to internal waves + !! shear instability and double diffusion. + !! + !! -1- Compute the now interior vertical mixing coefficients at all depths. + !! -2- Diagnose the boundary layer depth. + !! -3- Compute the now boundary layer vertical mixing coefficients. + !! -4- Compute the now vertical eddy vicosity and diffusivity. + !! -5- Smoothing + !! + !! N.B. The computation is done from jk=2 to jpkm1 + !! Surface value of avt are set once a time to zero + !! in routine zdf_osm_init. + !! + !! ** Action : update the non-local terms ghamts + !! update avt (before vertical eddy coef.) + !! + !! References : Large W.G., Mc Williams J.C. and Doney S.C. + !! Reviews of Geophysics, 32, 4, November 1994 + !! Comments in the code refer to this paper, particularly + !! the equation number. (LMD94, here after) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! Ocean time step + INTEGER , INTENT(in ) :: Kbb, Kmm, Krhs ! Ocean time level indices + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avm, p_avt ! Momentum and tracer Kz (w-points) + !! + INTEGER :: ji, jj, jk, jl, jm, jkflt ! Dummy loop indices + !! + REAL(wp) :: zthermal, zbeta + REAL(wp) :: zesh2, zri, zfri ! Interior Richardson mixing + !! Scales + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zrad0 ! Surface solar temperature flux (deg m/s) + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zradh ! Radiative flux at bl base (Buoyancy units) + REAL(wp) :: zradav ! Radiative flux, bl average (Buoyancy Units) + REAL(wp) :: zvw0 ! Surface v-momentum flux + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb0tot ! Total surface buoyancy flux including insolation + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb_min + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb_fk_b ! MLE buoyancy flux averaged over OSBL + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwb_fk ! Max MLE buoyancy flux + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdiff_mle ! Extra MLE vertical diff + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zvel_mle ! Velocity scale for dhdt with stable ML and FK + !! Mixed-layer variables + INTEGER, DIMENSION(A2D(nn_hls-1)) :: jk_nlev ! Number of levels + INTEGER, DIMENSION(A2D(nn_hls-1)) :: jk_ext ! Offset for external level + !! + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zhbl ! BL depth - grid + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zhml ! ML depth - grid + !! + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zhmle ! MLE depth - grid + REAL(wp), DIMENSION(A2D(nn_hls)) :: zmld ! ML depth on grid + !! + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdh ! Pycnocline depth - grid + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdhdt ! BL depth tendency + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdtdz_bl_ext, zdsdz_bl_ext ! External temperature/salinity gradients + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(A2D(nn_hls)) :: zdtdx, zdtdy, zdsdx, zdsdy ! Horizontal gradients for Fox-Kemper parametrization + !! + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdbds_mle ! Magnitude of horizontal buoyancy gradient + !! Flux-gradient relationship variables + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zshear ! Shear production + !! + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zhbl_t ! Holds boundary layer depth updated by full timestep + !! For calculating Ri#-dependent mixing + REAL(wp), DIMENSION(A2D(nn_hls)) :: z2du ! u-shear^2 + REAL(wp), DIMENSION(A2D(nn_hls)) :: z2dv ! v-shear^2 + REAL(wp) :: zrimix ! Spatial form of ri#-induced diffusion + !! Temporary variables + REAL(wp) :: znd ! Temporary non-dimensional depth + REAL(wp) :: zz0, zz1, zfac + REAL(wp) :: zus_x, zus_y ! Temporary Stokes drift + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk) :: zviscos ! Viscosity + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk) :: zdiffut ! t-diffusivity + REAL(wp) :: zabsstke + REAL(wp) :: zsqrtpi, z_two_thirds, zthickness + REAL(wp) :: z2k_times_thickness, zsqrt_depth, zexp_depth, zf, zexperfc + !! For debugging + REAL(wp), PARAMETER :: pp_large = -1e10_wp + !!---------------------------------------------------------------------- + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + nmld(ji,jj) = 0 + sustke(ji,jj) = pp_large + l_pyc(ji,jj) = .FALSE. + l_flux(ji,jj) = .FALSE. + l_mle(ji,jj) = .FALSE. + END_2D + ! Mixed layer + ! No initialization of zhbl or zhml (or zdh?) + zhbl(:,:) = pp_large + zhml(:,:) = pp_large + zdh(:,:) = pp_large + ! + IF ( ln_osm_mle ) THEN ! Only initialise arrays if needed + zdtdx(:,:) = pp_large ; zdtdy(:,:) = pp_large ; zdsdx(:,:) = pp_large + zdsdy(:,:) = pp_large + zwb_fk(:,:) = pp_large ; zvel_mle(:,:) = pp_large + zhmle(:,:) = pp_large ; zmld(:,:) = pp_large + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + dbdx_mle(ji,jj) = pp_large + dbdy_mle(ji,jj) = pp_large + END_2D + ENDIF + zhbl_t(:,:) = pp_large + ! + zdiffut(:,:,:) = 0.0_wp + zviscos(:,:,:) = 0.0_wp + ! + DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) + ghamt(ji,jj,jk) = pp_large + ghams(ji,jj,jk) = pp_large + ghamu(ji,jj,jk) = pp_large + ghamv(ji,jj,jk) = pp_large + END_3D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpk ) + ghamt(ji,jj,jk) = 0.0_wp + ghams(ji,jj,jk) = 0.0_wp + ghamu(ji,jj,jk) = 0.0_wp + ghamv(ji,jj,jk) = 0.0_wp + END_3D + ! + zdiff_mle(:,:) = 0.0_wp + ! + ! Ensure only positive hbl values are accessed when using extended halo + ! (nn_hls==2) + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + hbl(ji,jj) = MAX( hbl(ji,jj), epsln ) + END_2D + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Calculate boundary layer scales + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + ! Turbulent surface fluxes and fluxes averaged over depth of the OSBL + zz0 = rn_abs ! Assume two-band radiation model for depth of OSBL - surface equi-partition in 2-bands + zz1 = 1.0_wp - rn_abs + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zrad0(ji,jj) = qsr(ji,jj) * r1_rho0_rcp ! Surface downward irradiance (so always +ve) + zradh(ji,jj) = zrad0(ji,jj) * & ! Downwards irradiance at base of boundary layer + & ( zz0 * EXP( -1.0_wp * hbl(ji,jj) / rn_si0 ) + zz1 * EXP( -1.0_wp * hbl(ji,jj) / rn_si1 ) ) + zradav = zrad0(ji,jj) * & ! Downwards irradiance averaged + & ( zz0 * ( 1.0_wp - EXP( -hbl(ji,jj)/rn_si0 ) ) * rn_si0 + & ! over depth of the OSBL + & zz1 * ( 1.0_wp - EXP( -hbl(ji,jj)/rn_si1 ) ) * rn_si1 ) / hbl(ji,jj) + swth0(ji,jj) = - qns(ji,jj) * r1_rho0_rcp * tmask(ji,jj,1) ! Upwards surface Temperature flux for non-local term + swthav(ji,jj) = 0.5_wp * swth0(ji,jj) - ( 0.5_wp * ( zrad0(ji,jj) + zradh(ji,jj) ) - & ! Turbulent heat flux averaged + & zradav ) ! over depth of OSBL + END_2D + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + sws0(ji,jj) = -1.0_wp * ( ( emp(ji,jj) - rnf(ji,jj) ) * ts(ji,jj,1,jp_sal,Kmm) + & ! Upwards surface salinity flux + & sfx(ji,jj) ) * r1_rho0 * tmask(ji,jj,1) ! for non-local term + zthermal = rab_n(ji,jj,1,jp_tem) + zbeta = rab_n(ji,jj,1,jp_sal) + swb0(ji,jj) = grav * zthermal * swth0(ji,jj) - grav * zbeta * sws0(ji,jj) ! Non radiative upwards surface buoyancy flux + zwb0tot(ji,jj) = swb0(ji,jj) - grav * zthermal * ( zrad0(ji,jj) - zradh(ji,jj) ) ! Total upwards surface buoyancy flux + swsav(ji,jj) = 0.5_wp * sws0(ji,jj) ! Turbulent salinity flux averaged over depth of the OBSL + swbav(ji,jj) = grav * zthermal * swthav(ji,jj) - & ! Turbulent buoyancy flux averaged over the depth of the + & grav * zbeta * swsav(ji,jj) ! OBSBL + END_2D + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + suw0(ji,jj) = -0.5_wp * (utau(ji-1,jj) + utau(ji,jj)) * r1_rho0 * tmask(ji,jj,1) ! Surface upward velocity fluxes + zvw0 = -0.5_wp * (vtau(ji,jj-1) + vtau(ji,jj)) * r1_rho0 * tmask(ji,jj,1) + sustar(ji,jj) = MAX( SQRT( SQRT( suw0(ji,jj) * suw0(ji,jj) + zvw0 * zvw0 ) ), & ! Friction velocity (sustar), at + & 1e-8_wp ) ! T-point : LMD94 eq. 2 + scos_wind(ji,jj) = -1.0_wp * suw0(ji,jj) / ( sustar(ji,jj) * sustar(ji,jj) ) + ssin_wind(ji,jj) = -1.0_wp * zvw0 / ( sustar(ji,jj) * sustar(ji,jj) ) + END_2D + ! Calculate Stokes drift in direction of wind (sustke) and Stokes penetration depth (dstokes) + SELECT CASE (nn_osm_wave) + ! Assume constant La#=0.3 + CASE(0) + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zus_x = scos_wind(ji,jj) * sustar(ji,jj) / 0.3_wp**2 + zus_y = ssin_wind(ji,jj) * sustar(ji,jj) / 0.3_wp**2 + ! Linearly + sustke(ji,jj) = MAX( SQRT( zus_x * zus_x + zus_y * zus_y ), 1e-8_wp ) + dstokes(ji,jj) = rn_osm_dstokes + END_2D + ! Assume Pierson-Moskovitz wind-wave spectrum + CASE(1) + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! Use wind speed wndm included in sbc_oce module + sustke(ji,jj) = MAX ( 0.016_wp * wndm(ji,jj), 1e-8_wp ) + dstokes(ji,jj) = MAX ( 0.12_wp * wndm(ji,jj)**2 / grav, 5e-1_wp ) + END_2D + ! Use ECMWF wave fields as output from SBCWAVE + CASE(2) + zfac = 2.0_wp * rpi / 16.0_wp + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( hsw(ji,jj) > 1e-4_wp ) THEN + ! Use wave fields + zabsstke = SQRT( ut0sd(ji,jj)**2 + vt0sd(ji,jj)**2 ) + sustke(ji,jj) = MAX( ( scos_wind(ji,jj) * ut0sd(ji,jj) + ssin_wind(ji,jj) * vt0sd(ji,jj) ), 1e-8_wp ) + dstokes(ji,jj) = MAX( zfac * hsw(ji,jj) * hsw(ji,jj) / ( MAX( zabsstke * wmp(ji,jj), 1e-7 ) ), 5e-1_wp ) + ELSE + ! Assume masking issue (e.g. ice in ECMWF reanalysis but not in model run) + ! .. so default to Pierson-Moskowitz + sustke(ji,jj) = MAX( 0.016_wp * wndm(ji,jj), 1e-8_wp ) + dstokes(ji,jj) = MAX( 0.12_wp * wndm(ji,jj)**2 / grav, 5e-1_wp ) + END IF + END_2D + END SELECT + ! + IF (ln_zdfosm_ice_shelter) THEN + ! Reduce both Stokes drift and its depth scale by ocean fraction to represent sheltering by ice + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + sustke(ji,jj) = sustke(ji,jj) * ( 1.0_wp - fr_i(ji,jj) ) + dstokes(ji,jj) = dstokes(ji,jj) * ( 1.0_wp - fr_i(ji,jj) ) + END_2D + END IF + ! + SELECT CASE (nn_osm_SD_reduce) + ! Reduce surface Stokes drift by a constant factor or following Breivik (2016) + van Roekel (2012) or Grant (2020). + CASE(0) + ! The Langmur number from the ECMWF model (or from PM) appears to give La<0.3 for wind-driven seas. + ! The coefficient rn_zdfosm_adjust_sd = 0.8 gives La=0.3 in this situation. + ! It could represent the effects of the spread of wave directions around the mean wind. The effect of this adjustment needs to be tested. + IF(nn_osm_wave > 0) THEN + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + sustke(ji,jj) = rn_zdfosm_adjust_sd * sustke(ji,jj) + END_2D + END IF + CASE(1) + ! Van Roekel (2012): consider average SD over top 10% of boundary layer + ! Assumes approximate depth profile of SD from Breivik (2016) + zsqrtpi = SQRT(rpi) + z_two_thirds = 2.0_wp / 3.0_wp + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zthickness = rn_osm_hblfrac*hbl(ji,jj) + z2k_times_thickness = zthickness * 2.0_wp / MAX( ABS( 5.97_wp * dstokes(ji,jj) ), 1e-7_wp ) + zsqrt_depth = SQRT( z2k_times_thickness ) + zexp_depth = EXP( -1.0_wp * z2k_times_thickness ) + sustke(ji,jj) = sustke(ji,jj) * ( 1.0_wp - zexp_depth - & + & z_two_thirds * ( zsqrtpi * zsqrt_depth * z2k_times_thickness * ERFC(zsqrt_depth) + & + & 1.0_wp - ( 1.0_wp + z2k_times_thickness ) * zexp_depth ) ) / & + & z2k_times_thickness + END_2D + CASE(2) + ! Grant (2020): Match to exponential with same SD and d/dz(Sd) at depth 10% of boundary layer + ! Assumes approximate depth profile of SD from Breivik (2016) + zsqrtpi = SQRT(rpi) + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zthickness = rn_osm_hblfrac*hbl(ji,jj) + z2k_times_thickness = zthickness * 2.0_wp / MAX( ABS( 5.97_wp * dstokes(ji,jj) ), 1e-7_wp ) + IF( z2k_times_thickness < 50.0_wp ) THEN + zsqrt_depth = SQRT( z2k_times_thickness ) + zexperfc = zsqrtpi * zsqrt_depth * ERFC(zsqrt_depth) * EXP( z2k_times_thickness ) + ELSE + ! Asymptotic expansion of sqrt(pi)*zsqrt_depth*EXP(z2k_times_thickness)*ERFC(zsqrt_depth) for large + ! z2k_times_thickness + ! See Abramowitz and Stegun, Eq. 7.1.23 + ! zexperfc = 1._wp - (1/2)/(z2k_times_thickness) + (3/4)/(z2k_times_thickness**2) - (15/8)/(z2k_times_thickness**3) + zexperfc = ( ( -1.875_wp / z2k_times_thickness + 0.75_wp ) / z2k_times_thickness - 0.5_wp ) / & + & z2k_times_thickness + 1.0_wp + END IF + zf = z2k_times_thickness * ( 1.0_wp / zexperfc - 1.0_wp ) + dstokes(ji,jj) = 5.97_wp * zf * dstokes(ji,jj) + sustke(ji,jj) = sustke(ji,jj) * EXP( z2k_times_thickness * ( 1.0_wp / ( 2.0_wp * zf ) - 1.0_wp ) ) * & + & ( 1.0_wp - zexperfc ) + END_2D + END SELECT + ! + ! Langmuir velocity scale (swstrl), La # (sla) + ! Mixed scale (svstr), convective velocity scale (swstrc) + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! Langmuir velocity scale (swstrl), at T-point + swstrl(ji,jj) = ( sustar(ji,jj) * sustar(ji,jj) * sustke(ji,jj) )**pthird + sla(ji,jj) = MAX( MIN( SQRT( sustar(ji,jj) / ( swstrl(ji,jj) + epsln ) )**3, 4.0_wp ), 0.2_wp ) + IF ( sla(ji,jj) > 0.45_wp ) dstokes(ji,jj) = MIN( dstokes(ji,jj), 0.5_wp * hbl(ji,jj) ) + ! Velocity scale that tends to sustar for large Langmuir numbers + svstr(ji,jj) = ( swstrl(ji,jj)**3 + ( 1.0_wp - EXP( -0.5_wp * sla(ji,jj)**2 ) ) * sustar(ji,jj) * sustar(ji,jj) * & + & sustar(ji,jj) )**pthird + ! + ! Limit maximum value of Langmuir number as approximate treatment for shear turbulence + ! Note sustke and swstrl are not amended + ! + ! Get convective velocity (swstrc), stabilty scale (shol) and logical conection flag l_conv + IF ( swbav(ji,jj) > 0.0_wp ) THEN + swstrc(ji,jj) = ( 2.0_wp * swbav(ji,jj) * 0.9_wp * hbl(ji,jj) )**pthird + shol(ji,jj) = -0.9_wp * hbl(ji,jj) * 2.0_wp * swbav(ji,jj) / ( svstr(ji,jj)**3 + epsln ) + ELSE + swstrc(ji,jj) = 0.0_wp + shol(ji,jj) = -1.0_wp * hbl(ji,jj) * 2.0_wp * swbav(ji,jj) / ( svstr(ji,jj)**3 + epsln ) + ENDIF + END_2D + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Mixed-layer model - calculate averages over the boundary layer, and the change in the boundary layer depth + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! BL must be always 4 levels deep. + ! For calculation of lateral buoyancy gradients for FK in + ! zdf_osm_zmld_horizontal_gradients need halo values for nbld + ! + ! agn 23/6/20: not clear all this is needed, as hbl checked after it is re-calculated anyway + ! ########################################################################## + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + hbl(ji,jj) = MAX(hbl(ji,jj), gdepw(ji,jj,4,Kmm) ) + END_2D + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + nbld(ji,jj) = 4 + END_2D + DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 5, jpkm1 ) + IF ( MAX( hbl(ji,jj), gdepw(ji,jj,4,Kmm) ) >= gdepw(ji,jj,jk,Kmm) ) THEN + nbld(ji,jj) = MIN(mbkt(ji,jj)-2, jk) + ENDIF + END_3D + ! ########################################################################## + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zhbl(ji,jj) = gdepw(ji,jj,nbld(ji,jj),Kmm) + nmld(ji,jj) = MAX( 3, nbld(ji,jj) - MAX( INT( dh(ji,jj) / e3t(ji,jj,nbld(ji,jj)-1,Kmm) ), 1 ) ) + zhml(ji,jj) = gdepw(ji,jj,nmld(ji,jj),Kmm) + zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) + END_2D + ! + ! Averages over well-mixed and boundary layer, note BL averages use jk_ext=2 everywhere + jk_nlev(:,:) = nbld(A2D(nn_hls-1)) + jk_ext(:,:) = 1 ! ag 19/03 + CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_bl, av_s_bl, & + & av_b_bl, av_u_bl, av_v_bl, jk_ext, av_dt_bl, & + & av_ds_bl, av_db_bl, av_du_bl, av_dv_bl ) + jk_nlev(:,:) = nmld(A2D(nn_hls-1)) - 1 + jk_ext(:,:) = nbld(A2D(nn_hls-1)) - nmld(A2D(nn_hls-1)) + jk_ext(:,:) + 1 ! ag 19/03 + CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_ml, av_s_ml, & + & av_b_ml, av_u_ml, av_v_ml, jk_ext, av_dt_ml, & + & av_ds_ml, av_db_ml, av_du_ml, av_dv_ml ) + ! Velocity components in frame aligned with surface stress + CALL zdf_osm_velocity_rotation( av_u_ml, av_v_ml ) + CALL zdf_osm_velocity_rotation( av_du_ml, av_dv_ml ) + CALL zdf_osm_velocity_rotation( av_u_bl, av_v_bl ) + CALL zdf_osm_velocity_rotation( av_du_bl, av_dv_bl ) + ! + ! Determine the state of the OSBL, stable/unstable, shear/no shear + CALL zdf_osm_osbl_state( Kmm, zwb_ent, zwb_min, zshear, zhbl, & + & zhml, zdh ) + ! + IF ( ln_osm_mle ) THEN + ! Fox-Kemper Scheme + DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls ) + mld_prof(ji,jj) = 4 + END_2D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 5, jpkm1 ) + IF ( hmle(ji,jj) >= gdepw(ji,jj,jk,Kmm) ) mld_prof(ji,jj) = MIN( mbkt(ji,jj), jk) + END_3D + jk_nlev(:,:) = mld_prof(A2D(nn_hls-1)) + CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_mle, av_s_mle, & + & av_b_mle, av_u_mle, av_v_mle ) + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zhmle(ji,jj) = gdepw(ji,jj,mld_prof(ji,jj),Kmm) + END_2D + ! + ! Calculate fairly-well-mixed depth zmld & its index mld_prof + lateral zmld-averaged gradients + CALL zdf_osm_zmld_horizontal_gradients( Kmm, zmld, zdtdx, zdtdy, zdsdx, & + & zdsdy, zdbds_mle ) + ! Calculate max vertical FK flux zwb_fk & set logical descriptors + CALL zdf_osm_osbl_state_fk( Kmm, zwb_fk, zhbl, zhmle, zwb_ent, & + & zdbds_mle ) + ! Recalculate hmle, zmle, zvel_mle, zdiff_mle & redefine mld_proc to be index for new hmle + CALL zdf_osm_mle_parameters( Kmm, zmld, zhmle, zvel_mle, zdiff_mle, & + & zdbds_mle, zhbl, zwb0tot ) + ELSE ! ln_osm_mle + ! FK not selected, Boundary Layer only. + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + l_pyc(ji,jj) = .TRUE. + l_flux(ji,jj) = .FALSE. + l_mle(ji,jj) = .FALSE. + IF ( l_conv(ji,jj) .AND. av_db_bl(ji,jj) < rn_osm_bl_thresh ) l_pyc(ji,jj) = .FALSE. + END_2D + ENDIF ! ln_osm_mle + ! + !! External gradient below BL needed both with and w/o FK + jk_ext(:,:) = nbld(A2D(nn_hls-1)) + 1 + CALL zdf_osm_external_gradients( Kmm, jk_ext, zdtdz_bl_ext, zdsdz_bl_ext, zdbdz_bl_ext ) ! ag 19/03 + ! + ! Test if pycnocline well resolved + ! DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) Removed with ag 19/03 changes. A change in eddy diffusivity/viscosity + ! IF (l_conv(ji,jj) ) THEN should account for this. + ! ztmp = 0.2 * zhbl(ji,jj) / e3w(ji,jj,nbld(ji,jj),Kmm) + ! IF ( ztmp > 6 ) THEN + ! ! pycnocline well resolved + ! jk_ext(ji,jj) = 1 + ! ELSE + ! ! pycnocline poorly resolved + ! jk_ext(ji,jj) = 0 + ! ENDIF + ! ELSE + ! ! Stable conditions + ! jk_ext(ji,jj) = 0 + ! ENDIF + ! END_2D + ! + ! Recalculate bl averages using jk_ext & ml averages .... note no rotation of u & v here.. + jk_nlev(:,:) = nbld(A2D(nn_hls-1)) + jk_ext(:,:) = 1 ! ag 19/03 + CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_bl, av_s_bl, & + & av_b_bl, av_u_bl, av_v_bl, jk_ext, av_dt_bl, & + & av_ds_bl, av_db_bl, av_du_bl, av_dv_bl ) + jk_nlev(:,:) = nmld(A2D(nn_hls-1)) - 1 + jk_ext(:,:) = nbld(A2D(nn_hls-1)) - nmld(A2D(nn_hls-1)) + jk_ext(:,:) + 1 ! ag 19/03 + CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_ml, av_s_ml, & + & av_b_ml, av_u_ml, av_v_ml, jk_ext, av_dt_ml, & + & av_ds_ml, av_db_ml, av_du_ml, av_dv_ml ) ! ag 19/03 + ! + ! Rate of change of hbl + CALL zdf_osm_calculate_dhdt( zdhdt, zhbl, zdh, zwb_ent, zwb_min, & + & zdbdz_bl_ext, zwb_fk_b, zwb_fk, zvel_mle ) + ! Test if surface boundary layer coupled to bottom + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + l_coup(ji,jj) = .FALSE. ! ag 19/03 + zhbl_t(ji,jj) = hbl(ji,jj) + ( zdhdt(ji,jj) - ww(ji,jj,nbld(ji,jj)) ) * rn_Dt ! Certainly need ww here, so subtract it + ! Adjustment to represent limiting by ocean bottom + IF ( mbkt(ji,jj) > 2 ) THEN ! To ensure mbkt(ji,jj) - 2 > 0 so no incorrect array access + IF ( zhbl_t(ji,jj) > gdepw(ji, jj,mbkt(ji,jj)-2,Kmm) ) THEN + zhbl_t(ji,jj) = MIN( zhbl_t(ji,jj), gdepw(ji,jj,mbkt(ji,jj)-2,Kmm) ) ! ht(:,:)) + l_pyc(ji,jj) = .FALSE. + l_coup(ji,jj) = .TRUE. ! ag 19/03 + END IF + END IF + END_2D + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + nmld(ji,jj) = nbld(ji,jj) ! use nmld to hold previous blayer index + nbld(ji,jj) = 4 + END_2D + ! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 4, jpkm1 ) + IF ( zhbl_t(ji,jj) >= gdepw(ji,jj,jk,Kmm) ) THEN + nbld(ji,jj) = jk + END IF + END_3D + ! + ! + ! Step through model levels taking account of buoyancy change to determine the effect on dhdt + ! + CALL zdf_osm_timestep_hbl( Kmm, zdhdt, zhbl, zhbl_t, zwb_ent, & + & zwb_fk_b ) + ! Is external level in bounds? + ! + ! Recalculate BL averages and differences using new BL depth + jk_nlev(:,:) = nbld(A2D(nn_hls-1)) + jk_ext(:,:) = 1 ! ag 19/03 + CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_bl, av_s_bl, & + & av_b_bl, av_u_bl, av_v_bl, jk_ext, av_dt_bl, & + & av_ds_bl, av_db_bl, av_du_bl, av_dv_bl ) + ! + CALL zdf_osm_pycnocline_thickness( Kmm, zdh, zhml, zdhdt, zhbl, & + & zwb_ent, zdbdz_bl_ext, zwb_fk_b ) + ! + ! Reset l_pyc before calculating terms in the flux-gradient relationship + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( av_db_bl(ji,jj) < rn_osm_bl_thresh .OR. nbld(ji,jj) >= mbkt(ji,jj) - 2 .OR. & + & nbld(ji,jj) - nmld(ji,jj) == 1 .OR. zdhdt(ji,jj) < 0.0_wp ) THEN ! ag 19/03 + l_pyc(ji,jj) = .FALSE. ! ag 19/03 + IF ( nbld(ji,jj) >= mbkt(ji,jj) -2 ) THEN + nmld(ji,jj) = nbld(ji,jj) - 1 ! ag 19/03 + zdh(ji,jj) = gdepw(ji,jj,nbld(ji,jj),Kmm) - gdepw(ji,jj,nmld(ji,jj),Kmm) ! ag 19/03 + zhml(ji,jj) = gdepw(ji,jj,nmld(ji,jj),Kmm) ! ag 19/03 + dh(ji,jj) = zdh(ji,jj) ! ag 19/03 + hml(ji,jj) = hbl(ji,jj) - dh(ji,jj) ! ag 19/03 + ENDIF + ENDIF ! ag 19/03 + END_2D + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! Limit delta for shallow boundary layers for calculating + dstokes(ji,jj) = MIN ( dstokes(ji,jj), hbl(ji,jj) / 3.0_wp ) ! flux-gradient terms + END_2D + ! + ! + ! Average over the depth of the mixed layer in the convective boundary layer + ! jk_ext = nbld - nmld + 1 + ! Recalculate ML averages and differences using new ML depth + jk_nlev(:,:) = nmld(A2D(nn_hls-1)) - 1 + jk_ext(:,:) = nbld(A2D(nn_hls-1)) - nmld(A2D(nn_hls-1)) + jk_ext(:,:) + 1 ! ag 19/03 + CALL zdf_osm_vertical_average( Kbb, Kmm, jk_nlev, av_t_ml, av_s_ml, & + & av_b_ml, av_u_ml, av_v_ml, jk_ext, av_dt_ml, & + & av_ds_ml, av_db_ml, av_du_ml, av_dv_ml ) + ! + jk_ext(:,:) = nbld(A2D(nn_hls-1)) + 1 + CALL zdf_osm_external_gradients( Kmm, jk_ext, zdtdz_bl_ext, zdsdz_bl_ext, zdbdz_bl_ext ) + ! Rotate mean currents and changes onto wind aligned co-ordinates + CALL zdf_osm_velocity_rotation( av_u_ml, av_v_ml ) + CALL zdf_osm_velocity_rotation( av_du_ml, av_dv_ml ) + CALL zdf_osm_velocity_rotation( av_u_bl, av_v_bl ) + CALL zdf_osm_velocity_rotation( av_du_bl, av_dv_bl ) + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Eddy viscosity/diffusivity and non-gradient terms in the flux-gradient relationship + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL zdf_osm_diffusivity_viscosity( Kbb, Kmm, zdiffut, zviscos, zhbl, & + & zhml, zdh, zdhdt, zshear, zwb_ent, & + & zwb_min ) + ! + ! Calculate non-gradient components of the flux-gradient relationships + ! -------------------------------------------------------------------- + jk_ext(:,:) = 1 ! ag 19/03 + CALL zdf_osm_fgr_terms( Kmm, jk_ext, zhbl, zhml, zdh, & + & zdhdt, zshear, zdtdz_bl_ext, zdsdz_bl_ext, zdbdz_bl_ext, & + & zdiffut, zviscos ) + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Need to put in code for contributions that are applied explicitly to + ! the prognostic variables + ! 1. Entrainment flux + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + ! Rotate non-gradient velocity terms back to model reference frame + jk_nlev(:,:) = nbld(A2D(nn_hls-1)) + CALL zdf_osm_velocity_rotation( ghamu, ghamv, .FALSE., 2, jk_nlev ) + ! + ! KPP-style Ri# mixing + IF ( ln_kpprimix ) THEN + jkflt = jpk + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( nbld(ji,jj) < jkflt ) jkflt = nbld(ji,jj) + END_2D + DO jk = jkflt+1, jpkm1 + ! Shear production at uw- and vw-points (energy conserving form) + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + z2du(ji,jj) = 0.5_wp * ( uu(ji,jj,jk-1,Kmm) - uu(ji,jj,jk,Kmm) ) * ( uu(ji,jj,jk-1,Kbb) - uu(ji,jj,jk,Kbb) ) * & + & wumask(ji,jj,jk) / ( e3uw(ji,jj,jk,Kmm) * e3uw(ji,jj,jk,Kbb) ) + z2dv(ji,jj) = 0.5_wp * ( vv(ji,jj,jk-1,Kmm) - vv(ji,jj,jk,Kmm) ) * ( vv(ji,jj,jk-1,Kbb) - vv(ji,jj,jk,Kbb) ) * & + & wvmask(ji,jj,jk) / ( e3vw(ji,jj,jk,Kmm) * e3vw(ji,jj,jk,Kbb) ) + END_2D + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( jk > nbld(ji,jj) ) THEN + ! Shear prod. at w-point weightened by mask + zesh2 = ( z2du(ji-1,jj) + z2du(ji,jj) ) / MAX( 1.0_wp , umask(ji-1,jj,jk) + umask(ji,jj,jk) ) + & + & ( z2dv(ji,jj-1) + z2dv(ji,jj) ) / MAX( 1.0_wp , vmask(ji,jj-1,jk) + vmask(ji,jj,jk) ) + ! Local Richardson number + zri = MAX( rn2b(ji,jj,jk), 0.0_wp ) / MAX( zesh2, epsln ) + zfri = MIN( zri / rn_riinfty, 1.0_wp ) + zfri = ( 1.0_wp - zfri * zfri ) + zrimix = zfri * zfri * zfri * wmask(ji, jj, jk) + zdiffut(ji,jj,jk) = MAX( zdiffut(ji,jj,jk), zrimix*rn_difri ) + zviscos(ji,jj,jk) = MAX( zviscos(ji,jj,jk), zrimix*rn_difri ) + END IF + END_2D + END DO + END IF ! ln_kpprimix = .true. + ! + ! KPP-style set diffusivity large if unstable below BL + IF ( ln_convmix) THEN + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + DO jk = nbld(ji,jj) + 1, jpkm1 + IF ( MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1e-12_wp ) zdiffut(ji,jj,jk) = MAX( rn_difconv, zdiffut(ji,jj,jk) ) + END DO + END_2D + END IF ! ln_convmix = .true. + ! + IF ( ln_osm_mle ) THEN ! Set up diffusivity and non-gradient mixing + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( l_flux(ji,jj) ) THEN ! MLE mixing extends below boundary layer + ! Calculate MLE flux contribution from surface fluxes + DO jk = 1, nbld(ji,jj) + znd = gdepw(ji,jj,jk,Kmm) / MAX( zhbl(ji,jj), epsln ) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) - ( swth0(ji,jj) - zrad0(ji,jj) + zradh(ji,jj) ) * ( 1.0_wp - znd ) + ghams(ji,jj,jk) = ghams(ji,jj,jk) - sws0(ji,jj) * ( 1.0_wp - znd ) + END DO + DO jk = 1, mld_prof(ji,jj) + znd = gdepw(ji,jj,jk,Kmm) / MAX( zhmle(ji,jj), epsln ) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + ( swth0(ji,jj) - zrad0(ji,jj) + zradh(ji,jj) ) * ( 1.0_wp - znd ) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + sws0(ji,jj) * ( 1.0_wp -znd ) + END DO + ! Viscosity for MLEs + DO jk = 1, mld_prof(ji,jj) + znd = -1.0_wp * gdepw(ji,jj,jk,Kmm) / MAX( zhmle(ji,jj), epsln ) + zdiffut(ji,jj,jk) = zdiffut(ji,jj,jk) + zdiff_mle(ji,jj) * ( 1.0_wp - ( 2.0_wp * znd + 1.0_wp )**2 ) * & + & ( 1.0_wp + 5.0_wp / 21.0_wp * ( 2.0_wp * znd + 1.0_wp )**2 ) + END DO + ELSE ! Surface transports limited to OSBL + ! Viscosity for MLEs + DO jk = 1, mld_prof(ji,jj) + znd = -1.0_wp * gdepw(ji,jj,jk,Kmm) / MAX( zhmle(ji,jj), epsln ) + zdiffut(ji,jj,jk) = zdiffut(ji,jj,jk) + zdiff_mle(ji,jj) * ( 1.0_wp - ( 2.0_wp * znd + 1.0_wp )**2 ) * & + & ( 1.0_wp + 5.0_wp / 21.0_wp * ( 2.0_wp * znd + 1.0_wp )**2 ) + END DO + END IF + END_2D + ENDIF + ! + ! Lateral boundary conditions on zvicos (sign unchanged), needed to caclulate viscosities on u and v grids + ! CALL lbc_lnk( 'zdfosm', zviscos(:,:,:), 'W', 1.0_wp ) + ! GN 25/8: need to change tmask --> wmask + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + p_avt(ji,jj,jk) = MAX( zdiffut(ji,jj,jk), avtb(jk) ) * tmask(ji,jj,jk) + p_avm(ji,jj,jk) = MAX( zviscos(ji,jj,jk), avmb(jk) ) * tmask(ji,jj,jk) + END_3D + ! + IF ( ln_dia_osm ) THEN + SELECT CASE (nn_osm_wave) + ! Stokes drift set by assumimg onstant La#=0.3 (=0) or Pierson-Moskovitz spectrum (=1) + CASE(0:1) + CALL zdf_osm_iomput( "us_x", tmask(A2D(0),1) * sustke(A2D(0)) * scos_wind(A2D(0)) ) ! x surface Stokes drift + CALL zdf_osm_iomput( "us_y", tmask(A2D(0),1) * sustke(A2D(0)) * scos_wind(A2D(0)) ) ! y surface Stokes drift + CALL zdf_osm_iomput( "wind_wave_abs_power", 1000.0_wp * rho0 * tmask(A2D(0),1) * sustar(A2D(0))**2 * sustke(A2D(0)) ) + ! Stokes drift read in from sbcwave (=2). + CASE(2:3) + CALL zdf_osm_iomput( "us_x", ut0sd(A2D(0)) * umask(A2D(0),1) ) ! x surface Stokes drift + CALL zdf_osm_iomput( "us_y", vt0sd(A2D(0)) * vmask(A2D(0),1) ) ! y surface Stokes drift + CALL zdf_osm_iomput( "wmp", wmp(A2D(0)) * tmask(A2D(0),1) ) ! Wave mean period + CALL zdf_osm_iomput( "hsw", hsw(A2D(0)) * tmask(A2D(0),1) ) ! Significant wave height + CALL zdf_osm_iomput( "wmp_NP", ( 2.0_wp * rpi * 1.026_wp / ( 0.877_wp * grav ) ) * & ! Wave mean period from NP + & wndm(A2D(0)) * tmask(A2D(0),1) ) ! spectrum + CALL zdf_osm_iomput( "hsw_NP", ( 0.22_wp / grav ) * wndm(A2D(0))**2 * tmask(A2D(0),1) ) ! Significant wave height from + ! ! NP spectrum + CALL zdf_osm_iomput( "wndm", wndm(A2D(0)) * tmask(A2D(0),1) ) ! U_10 + CALL zdf_osm_iomput( "wind_wave_abs_power", 1000.0_wp * rho0 * tmask(A2D(0),1) * sustar(A2D(0))**2 * & + & SQRT( ut0sd(A2D(0))**2 + vt0sd(A2D(0))**2 ) ) + END SELECT + CALL zdf_osm_iomput( "zwth0", tmask(A2D(0),1) * swth0(A2D(0)) ) ! + CALL zdf_osm_iomput( "zws0", tmask(A2D(0),1) * sws0(A2D(0)) ) ! + CALL zdf_osm_iomput( "zwb0", tmask(A2D(0),1) * swb0(A2D(0)) ) ! + CALL zdf_osm_iomput( "zwbav", tmask(A2D(0),1) * swth0(A2D(0)) ) ! Upward BL-avged turb buoyancy flux + CALL zdf_osm_iomput( "ibld", tmask(A2D(0),1) * nbld(A2D(0)) ) ! Boundary-layer max k + CALL zdf_osm_iomput( "zdt_bl", tmask(A2D(0),1) * av_dt_bl(A2D(0)) ) ! dt at ml base + CALL zdf_osm_iomput( "zds_bl", tmask(A2D(0),1) * av_ds_bl(A2D(0)) ) ! ds at ml base + CALL zdf_osm_iomput( "zdb_bl", tmask(A2D(0),1) * av_db_bl(A2D(0)) ) ! db at ml base + CALL zdf_osm_iomput( "zdu_bl", tmask(A2D(0),1) * av_du_bl(A2D(0)) ) ! du at ml base + CALL zdf_osm_iomput( "zdv_bl", tmask(A2D(0),1) * av_dv_bl(A2D(0)) ) ! dv at ml base + CALL zdf_osm_iomput( "dh", tmask(A2D(0),1) * dh(A2D(0)) ) ! Initial boundary-layer depth + CALL zdf_osm_iomput( "hml", tmask(A2D(0),1) * hml(A2D(0)) ) ! Initial boundary-layer depth + CALL zdf_osm_iomput( "zdt_ml", tmask(A2D(0),1) * av_dt_ml(A2D(0)) ) ! dt at ml base + CALL zdf_osm_iomput( "zds_ml", tmask(A2D(0),1) * av_ds_ml(A2D(0)) ) ! ds at ml base + CALL zdf_osm_iomput( "zdb_ml", tmask(A2D(0),1) * av_db_ml(A2D(0)) ) ! db at ml base + CALL zdf_osm_iomput( "dstokes", tmask(A2D(0),1) * dstokes(A2D(0)) ) ! Stokes drift penetration depth + CALL zdf_osm_iomput( "zustke", tmask(A2D(0),1) * sustke(A2D(0)) ) ! Stokes drift magnitude at T-points + CALL zdf_osm_iomput( "zwstrc", tmask(A2D(0),1) * swstrc(A2D(0)) ) ! Convective velocity scale + CALL zdf_osm_iomput( "zwstrl", tmask(A2D(0),1) * swstrl(A2D(0)) ) ! Langmuir velocity scale + CALL zdf_osm_iomput( "zustar", tmask(A2D(0),1) * sustar(A2D(0)) ) ! Friction velocity scale + CALL zdf_osm_iomput( "zvstr", tmask(A2D(0),1) * svstr(A2D(0)) ) ! Mixed velocity scale + CALL zdf_osm_iomput( "zla", tmask(A2D(0),1) * sla(A2D(0)) ) ! Langmuir # + CALL zdf_osm_iomput( "wind_power", 1000.0_wp * rho0 * tmask(A2D(0),1) * & ! BL depth internal to zdf_osm routine + & sustar(A2D(0))**3 ) + CALL zdf_osm_iomput( "wind_wave_power", 1000.0_wp * rho0 * tmask(A2D(0),1) * & + & sustar(A2D(0))**2 * sustke(A2D(0)) ) + CALL zdf_osm_iomput( "zhbl", tmask(A2D(0),1) * zhbl(A2D(0)) ) ! BL depth internal to zdf_osm routine + CALL zdf_osm_iomput( "zhml", tmask(A2D(0),1) * zhml(A2D(0)) ) ! ML depth internal to zdf_osm routine + CALL zdf_osm_iomput( "imld", tmask(A2D(0),1) * nmld(A2D(0)) ) ! Index for ML depth internal to zdf_osm + ! ! routine + CALL zdf_osm_iomput( "jp_ext", tmask(A2D(0),1) * jk_ext(A2D(0)) ) ! =1 if pycnocline resolved internal to + ! ! zdf_osm routine + CALL zdf_osm_iomput( "j_ddh", tmask(A2D(0),1) * n_ddh(A2D(0)) ) ! Index forpyc thicknessh internal to + ! ! zdf_osm routine + CALL zdf_osm_iomput( "zshear", tmask(A2D(0),1) * zshear(A2D(0)) ) ! Shear production of TKE internal to + ! ! zdf_osm routine + CALL zdf_osm_iomput( "zdh", tmask(A2D(0),1) * zdh(A2D(0)) ) ! Pyc thicknessh internal to zdf_osm + ! ! routine + CALL zdf_osm_iomput( "zhol", tmask(A2D(0),1) * shol(A2D(0)) ) ! ML depth internal to zdf_osm routine + CALL zdf_osm_iomput( "zwb_ent", tmask(A2D(0),1) * zwb_ent(A2D(0)) ) ! Upward turb buoyancy entrainment flux + CALL zdf_osm_iomput( "zt_ml", tmask(A2D(0),1) * av_t_ml(A2D(0)) ) ! Average T in ML + CALL zdf_osm_iomput( "zmld", tmask(A2D(0),1) * zmld(A2D(0)) ) ! FK target layer depth + CALL zdf_osm_iomput( "zwb_fk", tmask(A2D(0),1) * zwb_fk(A2D(0)) ) ! FK b flux + CALL zdf_osm_iomput( "zwb_fk_b", tmask(A2D(0),1) * zwb_fk_b(A2D(0)) ) ! FK b flux averaged over ML + CALL zdf_osm_iomput( "mld_prof", tmask(A2D(0),1) * mld_prof(A2D(0)) ) ! FK layer max k + CALL zdf_osm_iomput( "zdtdx", umask(A2D(0),1) * zdtdx(A2D(0)) ) ! FK dtdx at u-pt + CALL zdf_osm_iomput( "zdtdy", vmask(A2D(0),1) * zdtdy(A2D(0)) ) ! FK dtdy at v-pt + CALL zdf_osm_iomput( "zdsdx", umask(A2D(0),1) * zdsdx(A2D(0)) ) ! FK dtdx at u-pt + CALL zdf_osm_iomput( "zdsdy", vmask(A2D(0),1) * zdsdy(A2D(0)) ) ! FK dsdy at v-pt + CALL zdf_osm_iomput( "dbdx_mle", umask(A2D(0),1) * dbdx_mle(A2D(0)) ) ! FK dbdx at u-pt + CALL zdf_osm_iomput( "dbdy_mle", vmask(A2D(0),1) * dbdy_mle(A2D(0)) ) ! FK dbdy at v-pt + CALL zdf_osm_iomput( "zdiff_mle", tmask(A2D(0),1) * zdiff_mle(A2D(0)) ) ! FK diff in MLE at t-pt + CALL zdf_osm_iomput( "zvel_mle", tmask(A2D(0),1) * zdiff_mle(A2D(0)) ) ! FK diff in MLE at t-pt + END IF + ! + ! Lateral boundary conditions on ghamu and ghamv, currently on W-grid (sign unchanged), needed to caclulate gham[uv] on u and + ! v grids + IF ( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Finalise ghamu, ghamv, hbl, and hmle only after full domain has been + ! ! processed + IF ( nn_hls == 1 ) CALL lbc_lnk( 'zdfosm', ghamu, 'W', 1.0_wp, & + & ghamv, 'W', 1.0_wp ) + DO jk = 2, jpkm1 + DO jj = Njs0, Nje0 + DO ji = Nis0, Nie0 + ghamu(ji,jj,jk) = ( ghamu(ji,jj,jk) + ghamu(ji+1,jj,jk) ) / & + & MAX( 1.0_wp, tmask(ji,jj,jk) + tmask (ji+1,jj,jk) ) * umask(ji,jj,jk) + ghamv(ji,jj,jk) = ( ghamv(ji,jj,jk) + ghamv(ji,jj+1,jk) ) / & + & MAX( 1.0_wp, tmask(ji,jj,jk) + tmask (ji,jj+1,jk) ) * vmask(ji,jj,jk) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) * tmask(ji,jj,jk) + ghams(ji,jj,jk) = ghams(ji,jj,jk) * tmask(ji,jj,jk) + END DO + END DO + END DO + ! Lateral boundary conditions on final outputs for hbl, on T-grid (sign unchanged) + CALL lbc_lnk( 'zdfosm', hbl, 'T', 1.0_wp, & + & hmle, 'T', 1.0_wp ) + ! + CALL zdf_osm_iomput( "ghamt", tmask * ghamt ) ! + CALL zdf_osm_iomput( "ghams", tmask * ghams ) ! + CALL zdf_osm_iomput( "ghamu", umask * ghamu ) ! + CALL zdf_osm_iomput( "ghamv", vmask * ghamv ) ! + CALL zdf_osm_iomput( "hbl", tmask(:,:,1) * hbl ) ! Boundary-layer depth + CALL zdf_osm_iomput( "hmle", tmask(:,:,1) * hmle ) ! FK layer depth + END IF + ! + END SUBROUTINE zdf_osm + + SUBROUTINE zdf_osm_vertical_average( Kbb, Kmm, knlev, pt, ps, & + & pb, pu, pv, kp_ext, pdt, & + & pds, pdb, pdu, pdv ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_vertical_average *** + !! + !! ** Purpose : Determines vertical averages from surface to knlev, + !! and optionally the differences between these vertical + !! averages and values at an external level + !! + !! ** Method : Averages are calculated from the surface to knlev. + !! The external level used to calculate differences is + !! knlev+kp_ext + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kbb, Kmm ! Ocean time-level indices + INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: knlev ! Number of levels to average over. + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pt, ps ! Average temperature and salinity + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pb ! Average buoyancy + REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pu, pv ! Average current components + INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ), OPTIONAL :: kp_ext ! External-level offsets + REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pdt ! Difference between average temperature, + REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pds ! salinity, + REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pdb ! buoyancy, and + REAL(wp), DIMENSION(jpi,jpj), INTENT( out), OPTIONAL :: pdu, pdv ! velocity components and the OSBL + !! + INTEGER :: jk, jkflt, jkmax, ji, jj ! Loop indices + INTEGER :: ibld_ext ! External-layer index + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zthick ! Layer thickness + REAL(wp) :: zthermal ! Thermal expansion coefficient + REAL(wp) :: zbeta ! Haline contraction coefficient + !!---------------------------------------------------------------------- + ! + ! Averages over depth of boundary layer + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + pt(ji,jj) = 0.0_wp + ps(ji,jj) = 0.0_wp + pu(ji,jj) = 0.0_wp + pv(ji,jj) = 0.0_wp + END_2D + zthick(:,:) = epsln + jkflt = jpk + jkmax = 0 + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( knlev(ji,jj) < jkflt ) jkflt = knlev(ji,jj) + IF ( knlev(ji,jj) > jkmax ) jkmax = knlev(ji,jj) + END_2D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jkflt ) ! Upper, flat part of layer + zthick(ji,jj) = zthick(ji,jj) + e3t(ji,jj,jk,Kmm) + pt(ji,jj) = pt(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) + ps(ji,jj) = ps(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) + pu(ji,jj) = pu(ji,jj) + e3t(ji,jj,jk,Kmm) * & + & ( uu(ji,jj,jk,Kbb) + uu(ji - 1,jj,jk,Kbb) ) / & + & MAX( 1.0_wp , umask(ji,jj,jk) + umask(ji - 1,jj,jk) ) + pv(ji,jj) = pv(ji,jj) + e3t(ji,jj,jk,Kmm) * & + & ( vv(ji,jj,jk,Kbb) + vv(ji,jj - 1,jk,Kbb) ) / & + & MAX( 1.0_wp , vmask(ji,jj,jk) + vmask(ji,jj - 1,jk) ) + END_3D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jkflt+1, jkmax ) ! Lower, non-flat part of layer + IF ( knlev(ji,jj) >= jk ) THEN + zthick(ji,jj) = zthick(ji,jj) + e3t(ji,jj,jk,Kmm) + pt(ji,jj) = pt(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) + ps(ji,jj) = ps(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) + pu(ji,jj) = pu(ji,jj) + e3t(ji,jj,jk,Kmm) * & + & ( uu(ji,jj,jk,Kbb) + uu(ji - 1,jj,jk,Kbb) ) / & + & MAX( 1.0_wp , umask(ji,jj,jk) + umask(ji - 1,jj,jk) ) + pv(ji,jj) = pv(ji,jj) + e3t(ji,jj,jk,Kmm) * & + & ( vv(ji,jj,jk,Kbb) + vv(ji,jj - 1,jk,Kbb) ) / & + & MAX( 1.0_wp , vmask(ji,jj,jk) + vmask(ji,jj - 1,jk) ) + END IF + END_3D + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + pt(ji,jj) = pt(ji,jj) / zthick(ji,jj) + ps(ji,jj) = ps(ji,jj) / zthick(ji,jj) + pu(ji,jj) = pu(ji,jj) / zthick(ji,jj) + pv(ji,jj) = pv(ji,jj) / zthick(ji,jj) + zthermal = rab_n(ji,jj,1,jp_tem) ! ideally use nbld not 1?? + zbeta = rab_n(ji,jj,1,jp_sal) + pb(ji,jj) = grav * zthermal * pt(ji,jj) - grav * zbeta * ps(ji,jj) + END_2D + ! + ! Differences between vertical averages and values at an external layer + IF ( PRESENT( kp_ext ) ) THEN + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ibld_ext = knlev(ji,jj) + kp_ext(ji,jj) + IF ( ibld_ext <= mbkt(ji,jj)-1 ) THEN ! ag 09/03 + ! Two external levels are available + pdt(ji,jj) = pt(ji,jj) - ts(ji,jj,ibld_ext,jp_tem,Kmm) + pds(ji,jj) = ps(ji,jj) - ts(ji,jj,ibld_ext,jp_sal,Kmm) + pdu(ji,jj) = pu(ji,jj) - ( uu(ji,jj,ibld_ext,Kbb) + uu(ji-1,jj,ibld_ext,Kbb ) ) / & + & MAX(1.0_wp , umask(ji,jj,ibld_ext ) + umask(ji-1,jj,ibld_ext ) ) + pdv(ji,jj) = pv(ji,jj) - ( vv(ji,jj,ibld_ext,Kbb) + vv(ji,jj-1,ibld_ext,Kbb ) ) / & + & MAX(1.0_wp , vmask(ji,jj,ibld_ext ) + vmask(ji,jj-1,ibld_ext ) ) + zthermal = rab_n(ji,jj,1,jp_tem) ! ideally use nbld not 1?? + zbeta = rab_n(ji,jj,1,jp_sal) + pdb(ji,jj) = grav * zthermal * pdt(ji,jj) - grav * zbeta * pds(ji,jj) + ELSE + pdt(ji,jj) = 0.0_wp + pds(ji,jj) = 0.0_wp + pdu(ji,jj) = 0.0_wp + pdv(ji,jj) = 0.0_wp + pdb(ji,jj) = 0.0_wp + ENDIF + END_2D + END IF + ! + END SUBROUTINE zdf_osm_vertical_average + + SUBROUTINE zdf_osm_velocity_rotation_2d( pu, pv, fwd ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_velocity_rotation_2d *** + !! + !! ** Purpose : Rotates frame of reference of velocity components pu and + !! pv (2d) + !! + !! ** Method : The velocity components are rotated into (fwd=.TRUE.) or + !! from (fwd=.FALSE.) the frame specified by scos_wind and + !! ssin_wind + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj) :: pu, pv ! Components of current + LOGICAL, OPTIONAL, INTENT(in ) :: fwd ! Forward (default) or reverse rotation + !! + INTEGER :: ji, jj ! Loop indices + REAL(wp) :: ztmp, zfwd ! Auxiliary variables + !!---------------------------------------------------------------------- + ! + zfwd = 1.0_wp + IF( PRESENT(fwd) .AND. ( .NOT. fwd ) ) zfwd = -1.0_wp + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ztmp = pu(ji,jj) + pu(ji,jj) = pu(ji,jj) * scos_wind(ji,jj) + zfwd * pv(ji,jj) * ssin_wind(ji,jj) + pv(ji,jj) = pv(ji,jj) * scos_wind(ji,jj) - zfwd * ztmp * ssin_wind(ji,jj) + END_2D + ! + END SUBROUTINE zdf_osm_velocity_rotation_2d + + SUBROUTINE zdf_osm_velocity_rotation_3d( pu, pv, fwd, ktop, knlev ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_velocity_rotation_3d *** + !! + !! ** Purpose : Rotates frame of reference of velocity components pu and + !! pv (3d) + !! + !! ** Method : The velocity components are rotated into (fwd=.TRUE.) or + !! from (fwd=.FALSE.) the frame specified by scos_wind and + !! ssin_wind; optionally, the rotation can be restricted at + !! each water column to span from the a minimum index ktop to + !! the depth index specified in array knlev + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pu, pv ! Components of current + LOGICAL, OPTIONAL, INTENT(in ) :: fwd ! Forward (default) or reverse rotation + INTEGER, OPTIONAL, INTENT(in ) :: ktop ! Minimum depth index + INTEGER, OPTIONAL, INTENT(in ), DIMENSION(A2D(nn_hls-1)) :: knlev ! Array of maximum depth indices + !! + INTEGER :: ji, jj, jk, jktop, jkmax ! Loop indices + REAL(wp) :: ztmp, zfwd ! Auxiliary variables + LOGICAL :: llkbot ! Auxiliary variable + !!---------------------------------------------------------------------- + ! + zfwd = 1.0_wp + IF( PRESENT(fwd) .AND. ( .NOT. fwd ) ) zfwd = -1.0_wp + jktop = 1 + IF( PRESENT(ktop) ) jktop = ktop + IF( PRESENT(knlev) ) THEN + jkmax = 0 + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( knlev(ji,jj) > jkmax ) jkmax = knlev(ji,jj) + END_2D + llkbot = .FALSE. + ELSE + jkmax = jpk + llkbot = .TRUE. + END IF + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jktop, jkmax ) + IF ( llkbot .OR. knlev(ji,jj) >= jk ) THEN + ztmp = pu(ji,jj,jk) + pu(ji,jj,jk) = pu(ji,jj,jk) * scos_wind(ji,jj) + zfwd * pv(ji,jj,jk) * ssin_wind(ji,jj) + pv(ji,jj,jk) = pv(ji,jj,jk) * scos_wind(ji,jj) - zfwd * ztmp * ssin_wind(ji,jj) + END IF + END_3D + ! + END SUBROUTINE zdf_osm_velocity_rotation_3d + + SUBROUTINE zdf_osm_osbl_state( Kmm, pwb_ent, pwb_min, pshear, phbl, & + & phml, pdh ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_osbl_state *** + !! + !! ** Purpose : Determines the state of the OSBL, stable/unstable, + !! shear/ noshear. Also determines shear production, + !! entrainment buoyancy flux and interfacial Richardson + !! number + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pwb_ent ! Buoyancy fluxes at base + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pwb_min ! of well-mixed layer + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pshear ! Production of TKE due to shear across the pycnocline + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth + !! + INTEGER :: jj, ji ! Loop indices + !! + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zekman + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zri_p, zri_b ! Richardson numbers + REAL(wp) :: zshear_u, zshear_v, zwb_shr + REAL(wp) :: zwcor, zrf_conv, zrf_shear, zrf_langmuir, zr_stokes + !! + REAL(wp), PARAMETER :: pp_a_shr = 0.4_wp, pp_b_shr = 6.5_wp, pp_a_wb_s = 0.8_wp + REAL(wp), PARAMETER :: pp_alpha_c = 0.2_wp, pp_alpha_lc = 0.03_wp + REAL(wp), PARAMETER :: pp_alpha_ls = 0.06_wp, pp_alpha_s = 0.15_wp + REAL(wp), PARAMETER :: pp_ri_p_thresh = 27.0_wp + REAL(wp), PARAMETER :: pp_ri_c = 0.25_wp + REAL(wp), PARAMETER :: pp_ek = 4.0_wp + REAL(wp), PARAMETER :: pp_large = -1e10_wp + !!---------------------------------------------------------------------- + ! + ! Initialise arrays + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + l_conv(ji,jj) = .FALSE. + l_shear(ji,jj) = .FALSE. + n_ddh(ji,jj) = 1 + END_2D + ! Initialise INTENT( out) arrays + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + pwb_ent(ji,jj) = pp_large + pwb_min(ji,jj) = pp_large + END_2D + ! + ! Determins stability and set flag l_conv + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( shol(ji,jj) < 0.0_wp ) THEN + l_conv(ji,jj) = .TRUE. + ELSE + l_conv(ji,jj) = .FALSE. + ENDIF + END_2D + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + pshear(ji,jj) = 0.0_wp + END_2D + zekman(:,:) = EXP( -1.0_wp * pp_ek * ABS( ff_t(A2D(nn_hls-1)) ) * phbl(A2D(nn_hls-1)) / & + & MAX( sustar(A2D(nn_hls-1)), 1.e-8 ) ) + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( l_conv(ji,jj) ) THEN + IF ( av_db_bl(ji,jj) > 0.0_wp ) THEN + zri_p(ji,jj) = MAX ( SQRT( av_db_bl(ji,jj) * pdh(ji,jj) / MAX( av_du_bl(ji,jj)**2 + av_dv_bl(ji,jj)**2, & + & 1e-8_wp ) ) * ( phbl(ji,jj) / pdh(ji,jj) ) * & + & ( svstr(ji,jj) / MAX( sustar(ji,jj), 1e-6_wp ) )**2 / & + & MAX( zekman(ji,jj), 1.0e-6_wp ), 5.0_wp ) + IF ( ff_t(ji,jj) >= 0.0_wp ) THEN ! Northern hemisphere + zri_b(ji,jj) = av_db_ml(ji,jj) * pdh(ji,jj) / ( MAX( av_du_ml(ji,jj), 1e-5_wp )**2 + & + & MAX( -1.0_wp * av_dv_ml(ji,jj), 1e-5_wp)**2 ) + ELSE ! Southern hemisphere + zri_b(ji,jj) = av_db_ml(ji,jj) * pdh(ji,jj) / ( MAX( av_du_ml(ji,jj), 1e-5_wp )**2 + & + & MAX( av_dv_ml(ji,jj), 1e-5_wp)**2 ) + END IF + pshear(ji,jj) = pp_a_shr * zekman(ji,jj) * & + & ( MAX( sustar(ji,jj)**2 * av_du_ml(ji,jj) / phbl(ji,jj), 0.0_wp ) + & + & pp_b_shr * MAX( -1.0_wp * ff_t(ji,jj) * sustke(ji,jj) * dstokes(ji,jj) * & + & av_dv_ml(ji,jj) / phbl(ji,jj), 0.0_wp ) ) + ! Stability dependence + pshear(ji,jj) = pshear(ji,jj) * EXP( -0.75_wp * MAX( 0.0_wp, ( zri_b(ji,jj) - pp_ri_c ) / pp_ri_c ) ) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Test ensures n_ddh=0 is not selected. Change to zri_p<27 when ! + ! full code available ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF ( pshear(ji,jj) > 1e-10 ) THEN + IF ( zri_p(ji,jj) < pp_ri_p_thresh .AND. & + & MIN( hu(ji,jj,Kmm), hu(ji-1,jj,Kmm), hv(ji,jj,Kmm), hv(ji,jj-1,Kmm) ) > 100.0_wp ) THEN + ! Growing shear layer + n_ddh(ji,jj) = 0 + l_shear(ji,jj) = .TRUE. + ELSE + n_ddh(ji,jj) = 1 + ! IF ( zri_b <= 1.5 .and. pshear(ji,jj) > 0._wp ) THEN + ! Shear production large enough to determine layer charcteristics, but can't maintain a shear layer + l_shear(ji,jj) = .TRUE. + ! ELSE + END IF + ELSE + n_ddh(ji,jj) = 2 + l_shear(ji,jj) = .FALSE. + END IF + ! Shear production may not be zero, but is small and doesn't determine characteristics of pycnocline + ! pshear(ji,jj) = 0.5 * pshear(ji,jj) + ! l_shear(ji,jj) = .FALSE. + ! ENDIF + ELSE ! av_db_bl test, note pshear set to zero + n_ddh(ji,jj) = 2 + l_shear(ji,jj) = .FALSE. + ENDIF + ENDIF + END_2D + ! + ! Calculate entrainment buoyancy flux due to surface fluxes. + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( l_conv(ji,jj) ) THEN + zwcor = ABS( ff_t(ji,jj) ) * phbl(ji,jj) + epsln + zrf_conv = TANH( ( swstrc(ji,jj) / zwcor )**0.69_wp ) + zrf_shear = TANH( ( sustar(ji,jj) / zwcor )**0.69_wp ) + zrf_langmuir = TANH( ( swstrl(ji,jj) / zwcor )**0.69_wp ) + IF ( nn_osm_SD_reduce > 0 ) THEN + ! Effective Stokes drift already reduced from surface value + zr_stokes = 1.0_wp + ELSE + ! Effective Stokes drift only reduced by factor rn_zdfodm_adjust_sd, + ! requires further reduction where BL is deep + zr_stokes = 1.0 - EXP( -25.0_wp * dstokes(ji,jj) / hbl(ji,jj) * ( 1.0_wp + 4.0_wp * dstokes(ji,jj) / hbl(ji,jj) ) ) + END IF + pwb_ent(ji,jj) = -2.0_wp * pp_alpha_c * zrf_conv * swbav(ji,jj) - & + & pp_alpha_s * zrf_shear * sustar(ji,jj)**3 / phml(ji,jj) + & + & zr_stokes * ( pp_alpha_s * EXP( -1.5_wp * sla(ji,jj) ) * zrf_shear * sustar(ji,jj)**3 - & + & zrf_langmuir * pp_alpha_lc * swstrl(ji,jj)**3 ) / phml(ji,jj) + ENDIF + END_2D + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( l_shear(ji,jj) ) THEN + IF ( l_conv(ji,jj) ) THEN + ! Unstable OSBL + zwb_shr = -1.0_wp * pp_a_wb_s * zri_b(ji,jj) * pshear(ji,jj) + IF ( n_ddh(ji,jj) == 0 ) THEN + ! Developing shear layer, additional shear production possible. + + ! pshear_u = MAX( zustar(ji,jj)**2 * MAX( av_du_ml(ji,jj), 0._wp ) / phbl(ji,jj), 0._wp ) + ! pshear(ji,jj) = pshear(ji,jj) + pshear_u * ( 1.0 - MIN( zri_p(ji,jj) / pp_ri_p_thresh, 1.d0 )**2 ) + ! pshear(ji,jj) = MIN( pshear(ji,jj), pshear_u ) + + ! zwb_shr = zwb_shr - 0.25 * MAX ( pshear_u, 0._wp) * ( 1.0 - MIN( zri_p(ji,jj) / pp_ri_p_thresh, 1._wp )**2 ) + ! zwb_shr = MAX( zwb_shr, -0.25 * pshear_u ) + ENDIF + pwb_ent(ji,jj) = pwb_ent(ji,jj) + zwb_shr + ! pwb_min(ji,jj) = pwb_ent(ji,jj) + pdh(ji,jj) / phbl(ji,jj) * zwb0(ji,jj) + ELSE ! IF ( l_conv ) THEN - ENDIF + ! Stable OSBL - shear production not coded for first attempt. + ENDIF ! l_conv + END IF ! l_shear + IF ( l_conv(ji,jj) ) THEN + ! Unstable OSBL + pwb_min(ji,jj) = pwb_ent(ji,jj) + pdh(ji,jj) / phbl(ji,jj) * 2.0_wp * swbav(ji,jj) + END IF ! l_conv + END_2D + ! + END SUBROUTINE zdf_osm_osbl_state + + SUBROUTINE zdf_osm_external_gradients( Kmm, kbase, pdtdz, pdsdz, pdbdz ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_external_gradients *** + !! + !! ** Purpose : Calculates the gradients below the OSBL + !! + !! ** Method : Uses nbld and ibld_ext to determine levels to calculate the gradient. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index + INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: kbase ! OSBL base layer index + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pdtdz, pdsdz ! External gradients of temperature, salinity + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pdbdz ! and buoyancy + !! + INTEGER :: ji, jj, jkb, jkb1 + REAL(wp) :: zthermal, zbeta + !! + REAL(wp), PARAMETER :: pp_large = -1e10_wp + !!---------------------------------------------------------------------- + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + pdtdz(ji,jj) = pp_large + pdsdz(ji,jj) = pp_large + pdbdz(ji,jj) = pp_large + END_2D + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( kbase(ji,jj)+1 < mbkt(ji,jj) ) THEN + zthermal = rab_n(ji,jj,1,jp_tem) ! Ideally use nbld not 1?? + zbeta = rab_n(ji,jj,1,jp_sal) + jkb = kbase(ji,jj) + jkb1 = MIN( jkb + 1, mbkt(ji,jj) ) + pdtdz(ji,jj) = -1.0_wp * ( ts(ji,jj,jkb1,jp_tem,Kmm) - ts(ji,jj,jkb,jp_tem,Kmm ) ) / e3w(ji,jj,jkb1,Kmm) + pdsdz(ji,jj) = -1.0_wp * ( ts(ji,jj,jkb1,jp_sal,Kmm) - ts(ji,jj,jkb,jp_sal,Kmm ) ) / e3w(ji,jj,jkb1,Kmm) + pdbdz(ji,jj) = grav * zthermal * pdtdz(ji,jj) - grav * zbeta * pdsdz(ji,jj) + ELSE + pdtdz(ji,jj) = 0.0_wp + pdsdz(ji,jj) = 0.0_wp + pdbdz(ji,jj) = 0.0_wp + END IF + END_2D + ! + END SUBROUTINE zdf_osm_external_gradients + + SUBROUTINE zdf_osm_calculate_dhdt( pdhdt, phbl, pdh, pwb_ent, pwb_min, & + & pdbdz_bl_ext, pwb_fk_b, pwb_fk, pvel_mle ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_calculate_dhdt *** + !! + !! ** Purpose : Calculates the rate at which hbl changes. + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pdhdt ! Rate of change of hbl + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_min + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_fk ! Max MLE buoyancy flux + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pvel_mle ! Vvelocity scale for dhdt with stable ML and FK + !! + INTEGER :: jj, ji + REAL(wp) :: zgamma_b_nd, zgamma_dh_nd, zpert, zpsi, zari + REAL(wp) :: zvel_max, zddhdt + !! + REAL(wp), PARAMETER :: pp_alpha_b = 0.3_wp + REAL(wp), PARAMETER :: pp_ddh = 2.5_wp, pp_ddh_2 = 3.5_wp ! Also in pycnocline_depth + REAL(wp), PARAMETER :: pp_large = -1e10_wp + !!---------------------------------------------------------------------- + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + pdhdt(ji,jj) = pp_large + pwb_fk_b(ji,jj) = pp_large + END_2D + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! + IF ( l_shear(ji,jj) ) THEN + ! + IF ( l_conv(ji,jj) ) THEN ! Convective + ! + IF ( ln_osm_mle ) THEN + IF ( hmle(ji,jj) > hbl(ji,jj) ) THEN ! Fox-Kemper buoyancy flux average over OSBL + pwb_fk_b(ji,jj) = pwb_fk(ji,jj) * ( 1.0_wp + hmle(ji,jj) / ( 6.0_wp * hbl(ji,jj) ) * & + & ( -1.0_wp + ( 1.0_wp - 2.0_wp * hbl(ji,jj) / hmle(ji,jj) )**3 ) ) + ELSE + pwb_fk_b(ji,jj) = 0.5_wp * pwb_fk(ji,jj) * hmle(ji,jj) / hbl(ji,jj) + ENDIF + zvel_max = ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**p2third / hbl(ji,jj) + IF ( ( pwb_ent(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ) < 0.0_wp ) THEN ! OSBL is deepening, + ! ! entrainment > restratification + IF ( av_db_bl(ji,jj) > 1e-15_wp ) THEN + zgamma_b_nd = MAX( pdbdz_bl_ext(ji,jj), 0.0_wp ) * pdh(ji,jj) / & + & ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + zpsi = ( 1.0_wp - 0.5_wp * pdh(ji,jj) / phbl(ji,jj) ) * & + & ( swb0(ji,jj) - MIN( ( pwb_min(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ), 0.0_wp ) ) * pdh(ji,jj) / & + & phbl(ji,jj) + zpsi = zpsi + 1.75_wp * ( 1.0_wp - 0.5_wp * pdh(ji,jj) / phbl(ji,jj) ) * & + & ( pdh(ji,jj) / phbl(ji,jj) + zgamma_b_nd ) * & + & MIN( ( pwb_min(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ), 0.0_wp ) + zpsi = pp_alpha_b * MAX( zpsi, 0.0_wp ) + pdhdt(ji,jj) = -1.0_wp * ( pwb_ent(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ) / & + & ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + & + & zpsi / ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + IF ( n_ddh(ji,jj) == 1 ) THEN + IF ( ( swstrc(ji,jj) / svstr(ji,jj) )**3 <= 0.5_wp ) THEN + zari = MIN( 1.5_wp * av_db_bl(ji,jj) / & + & ( phbl(ji,jj) * ( MAX( pdbdz_bl_ext(ji,jj), 0.0_wp ) + & + & av_db_bl(ji,jj)**2 / MAX( 4.5_wp * svstr(ji,jj)**2, & + & 1e-12_wp ) ) ), 0.2_wp ) + ELSE + zari = MIN( 1.5_wp * av_db_bl(ji,jj) / & + & ( phbl(ji,jj) * ( MAX( pdbdz_bl_ext(ji,jj), 0.0_wp ) + & + & av_db_bl(ji,jj)**2 / MAX( 4.5_wp * swstrc(ji,jj)**2, & + & 1e-12_wp ) ) ), 0.2_wp ) + ENDIF + ! Relaxation to dh_ref = zari * hbl + zddhdt = -1.0_wp * pp_ddh_2 * ( 1.0_wp - pdh(ji,jj) / ( zari * phbl(ji,jj) ) ) * pwb_ent(ji,jj) / & + & ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + ELSE IF ( n_ddh(ji,jj) == 0 ) THEN ! Growing shear layer + zddhdt = -1.0_wp * pp_ddh * ( 1.0_wp - 1.6_wp * pdh(ji,jj) / phbl(ji,jj) ) * pwb_ent(ji,jj) / & + & ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + zddhdt = EXP( -4.0_wp * ABS( ff_t(ji,jj) ) * phbl(ji,jj) / MAX( sustar(ji,jj), 1e-8_wp ) ) * zddhdt + ELSE + zddhdt = 0.0_wp + ENDIF ! n_ddh + pdhdt(ji,jj) = pdhdt(ji,jj) + pp_alpha_b * ( 1.0_wp - 0.5_wp * pdh(ji,jj) / phbl(ji,jj) ) * & + & av_db_ml(ji,jj) * MAX( zddhdt, 0.0_wp ) / & + & ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + ELSE ! av_db_bl >0 + pdhdt(ji,jj) = -1.0_wp * ( pwb_ent(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ) / MAX( zvel_max, 1e-15_wp ) + ENDIF + ELSE ! pwb_min + 2*pwb_fk_b < 0 + ! OSBL shoaling due to restratification flux. This is the velocity defined in Fox-Kemper et al (2008) + pdhdt(ji,jj) = -1.0_wp * MIN( pvel_mle(ji,jj), hbl(ji,jj) / 10800.0_wp ) + ENDIF + ELSE ! Fox-Kemper not used. + zvel_max = -1.0_wp * ( 1.0_wp + 1.0_wp * ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird * & + & rn_Dt / hbl(ji,jj) ) * pwb_ent(ji,jj) / & + & MAX( ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird, epsln ) + pdhdt(ji,jj) = -1.0_wp * pwb_ent(ji,jj) / ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + ! added ajgn 23 July as temporay fix + ENDIF ! ln_osm_mle + ! + ELSE ! l_conv - Stable + ! + pdhdt(ji,jj) = ( 0.06_wp + 0.52_wp * shol(ji,jj) / 2.0_wp ) * svstr(ji,jj)**3 / hbl(ji,jj) + swbav(ji,jj) + IF ( pdhdt(ji,jj) < 0.0_wp ) THEN ! For long timsteps factor in brackets slows the rapid collapse of the OSBL + zpert = 2.0_wp * ( 1.0_wp + 0.0_wp * 2.0_wp * svstr(ji,jj) * rn_Dt / hbl(ji,jj) ) * svstr(ji,jj)**2 / hbl(ji,jj) + ELSE + zpert = MAX( svstr(ji,jj)**2 / hbl(ji,jj), av_db_bl(ji,jj) ) + ENDIF + pdhdt(ji,jj) = 2.0_wp * pdhdt(ji,jj) / MAX( zpert, epsln ) + pdhdt(ji,jj) = MAX( pdhdt(ji,jj), -1.0_wp * hbl(ji,jj) / 5400.0_wp ) + ! + ENDIF ! l_conv + ! + ELSE ! l_shear + ! + IF ( l_conv(ji,jj) ) THEN ! Convective + ! + IF ( ln_osm_mle ) THEN + IF ( hmle(ji,jj) > hbl(ji,jj) ) THEN ! Fox-Kemper buoyancy flux average over OSBL + pwb_fk_b(ji,jj) = pwb_fk(ji,jj) * & + ( 1.0_wp + hmle(ji,jj) / ( 6.0_wp * hbl(ji,jj) ) * & + & ( -1.0_wp + ( 1.0_wp - 2.0_wp * hbl(ji,jj) / hmle(ji,jj))**3) ) + ELSE + pwb_fk_b(ji,jj) = 0.5_wp * pwb_fk(ji,jj) * hmle(ji,jj) / hbl(ji,jj) + ENDIF + zvel_max = ( swstrl(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**p2third / hbl(ji,jj) + IF ( ( pwb_ent(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ) < 0.0_wp ) THEN ! OSBL is deepening, + ! ! entrainment > restratification + IF ( av_db_bl(ji,jj) > 0.0_wp .AND. pdbdz_bl_ext(ji,jj) > 0.0_wp ) THEN + pdhdt(ji,jj) = -1.0_wp * ( pwb_ent(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ) / & + & ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + ELSE + pdhdt(ji,jj) = -1.0_wp * ( pwb_ent(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ) / MAX( zvel_max, 1e-15_wp ) + ENDIF + ELSE ! OSBL shoaling due to restratification flux. This is the velocity defined in Fox-Kemper et al (2008) + pdhdt(ji,jj) = -1.0_wp * MIN( pvel_mle(ji,jj), hbl(ji,jj) / 10800.0_wp ) + ENDIF + ELSE ! Fox-Kemper not used + zvel_max = -1.0_wp * pwb_ent(ji,jj) / MAX( ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird, epsln ) + pdhdt(ji,jj) = -1.0_wp * pwb_ent(ji,jj) / ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15_wp ) ) + ! added ajgn 23 July as temporay fix + ENDIF ! ln_osm_mle + ! + ELSE ! Stable + ! + pdhdt(ji,jj) = ( 0.06_wp + 0.52_wp * shol(ji,jj) / 2.0_wp ) * svstr(ji,jj)**3 / hbl(ji,jj) + swbav(ji,jj) + IF ( pdhdt(ji,jj) < 0.0_wp ) THEN + ! For long timsteps factor in brackets slows the rapid collapse of the OSBL + zpert = 2.0_wp * svstr(ji,jj)**2 / hbl(ji,jj) + ELSE + zpert = MAX( svstr(ji,jj)**2 / hbl(ji,jj), av_db_bl(ji,jj) ) + ENDIF + pdhdt(ji,jj) = 2.0_wp * pdhdt(ji,jj) / MAX(zpert, epsln) + pdhdt(ji,jj) = MAX( pdhdt(ji,jj), -1.0_wp * hbl(ji,jj) / 5400.0_wp ) + ! + ENDIF ! l_conv + ! + ENDIF ! l_shear + ! + END_2D + ! + END SUBROUTINE zdf_osm_calculate_dhdt + + SUBROUTINE zdf_osm_timestep_hbl( Kmm, pdhdt, phbl, phbl_t, pwb_ent, & + & pwb_fk_b ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_timestep_hbl *** + !! + !! ** Purpose : Increments hbl. + !! + !! ** Method : If the change in hbl exceeds one model level the change is + !! is calculated by moving down the grid, changing the + !! buoyancy jump. This is to ensure that the change in hbl + !! does not overshoot a stable layer. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdhdt ! Rates of change of hbl + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl_t ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL + !! + INTEGER :: jk, jj, ji, jm + REAL(wp) :: zhbl_s, zvel_max, zdb + REAL(wp) :: zthermal, zbeta + !!---------------------------------------------------------------------- + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( nbld(ji,jj) - nmld(ji,jj) > 1 ) THEN + ! + ! If boundary layer changes by more than one level, need to check for stable layers between initial and final depths. + ! + zhbl_s = hbl(ji,jj) + jm = nmld(ji,jj) + zthermal = rab_n(ji,jj,1,jp_tem) + zbeta = rab_n(ji,jj,1,jp_sal) + ! + IF ( l_conv(ji,jj) ) THEN ! Unstable + ! + IF( ln_osm_mle ) THEN + zvel_max = ( swstrl(ji,jj)**3 + swstrc(ji,jj)**3 )**p2third / hbl(ji,jj) + ELSE + zvel_max = -1.0_wp * ( 1.0_wp + 1.0_wp * ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird * rn_Dt / & + & hbl(ji,jj) ) * pwb_ent(ji,jj) / & + & ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird + ENDIF + DO jk = nmld(ji,jj), nbld(ji,jj) + zdb = MAX( grav * ( zthermal * ( av_t_bl(ji,jj) - ts(ji,jj,jm,jp_tem,Kmm) ) - & + & zbeta * ( av_s_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ), 0.0_wp ) + zvel_max + ! + IF ( ln_osm_mle ) THEN + zhbl_s = zhbl_s + MIN( rn_Dt * ( ( -1.0_wp * pwb_ent(ji,jj) - 2.0_wp * pwb_fk_b(ji,jj) ) / zdb ) / & + & REAL( nbld(ji,jj) - nmld(ji,jj), KIND=wp ), e3w(ji,jj,jm,Kmm) ) + ELSE + zhbl_s = zhbl_s + MIN( rn_Dt * ( -1.0_wp * pwb_ent(ji,jj) / zdb ) / & + & REAL( nbld(ji,jj) - nmld(ji,jj), KIND=wp ), e3w(ji,jj,jm,Kmm) ) + ENDIF + ! zhbl_s = MIN(zhbl_s, gdepw(ji,jj, mbkt(ji,jj) + 1,Kmm) - depth_tol) + IF ( zhbl_s >= gdepw(ji,jj,mbkt(ji,jj) + 1,Kmm) ) THEN + zhbl_s = MIN( zhbl_s, gdepw(ji,jj, mbkt(ji,jj) + 1, Kmm ) - depth_tol ) + l_pyc(ji,jj) = .FALSE. + ENDIF + IF ( zhbl_s >= gdepw(ji,jj,jm+1,Kmm) ) jm = jm + 1 + END DO + hbl(ji,jj) = zhbl_s + nbld(ji,jj) = jm + ELSE ! Stable + DO jk = nmld(ji,jj), nbld(ji,jj) + zdb = MAX( grav * ( zthermal * ( av_t_bl(ji,jj) - ts(ji,jj,jm,jp_tem,Kmm) ) - & + & zbeta * ( av_s_bl(ji,jj) - ts(ji,jj,jm,jp_sal,Kmm) ) ), 0.0_wp ) + & + & 2.0_wp * svstr(ji,jj)**2 / zhbl_s + ! + ! Alan is thuis right? I have simply changed hbli to hbl + shol(ji,jj) = -1.0_wp * zhbl_s / ( ( svstr(ji,jj)**3 + epsln ) / swbav(ji,jj) ) + pdhdt(ji,jj) = -1.0_wp * ( swbav(ji,jj) - 0.04_wp / 2.0_wp * swstrl(ji,jj)**3 / zhbl_s - & + & 0.15_wp / 2.0_wp * ( 1.0_wp - EXP( -1.5_wp * sla(ji,jj) ) ) * & + & sustar(ji,jj)**3 / zhbl_s ) * & + & ( 0.725_wp + 0.225_wp * EXP( -7.5_wp * shol(ji,jj) ) ) + pdhdt(ji,jj) = pdhdt(ji,jj) + swbav(ji,jj) + zhbl_s = zhbl_s + MIN( pdhdt(ji,jj) / zdb * rn_Dt / REAL( nbld(ji,jj) - nmld(ji,jj), KIND=wp ), & + & e3w(ji,jj,jm,Kmm) ) + + ! zhbl_s = MIN(zhbl_s, gdepw(ji,jj, mbkt(ji,jj) + 1,Kmm) - depth_tol) + IF ( zhbl_s >= mbkt(ji,jj) + 1 ) THEN + zhbl_s = MIN( zhbl_s, gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) - depth_tol ) + l_pyc(ji,jj) = .FALSE. + ENDIF + IF ( zhbl_s >= gdepw(ji,jj,jm,Kmm) ) jm = jm + 1 + END DO + ENDIF ! IF ( l_conv ) + hbl(ji,jj) = MAX( zhbl_s, gdepw(ji,jj,4,Kmm) ) + nbld(ji,jj) = MAX( jm, 4 ) + ELSE + ! change zero or one model level. + hbl(ji,jj) = MAX( phbl_t(ji,jj), gdepw(ji,jj,4,Kmm) ) + ENDIF + phbl(ji,jj) = gdepw(ji,jj,nbld(ji,jj),Kmm) + END_2D + ! + END SUBROUTINE zdf_osm_timestep_hbl + + SUBROUTINE zdf_osm_pycnocline_thickness( Kmm, pdh, phml, pdhdt, phbl, & + & pwb_ent, pdbdz_bl_ext, pwb_fk_b ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_pycnocline_thickness *** + !! + !! ** Purpose : Calculates thickness of the pycnocline + !! + !! ** Method : The thickness is calculated from a prognostic equation + !! that relaxes the pycnocine thickness to a diagnostic + !! value. The time change is calculated assuming the + !! thickness relaxes exponentially. This is done to deal + !! with large timesteps. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdh ! Pycnocline thickness + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: phml ! ML depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_fk_b ! MLE buoyancy flux averaged over OSBL + !! + INTEGER :: jj, ji + INTEGER :: inhml + REAL(wp) :: zari, ztau, zdh_ref, zddhdt, zvel_max + REAL(wp) :: ztmp ! Auxiliary variable + !! + REAL(wp), PARAMETER :: pp_ddh = 2.5_wp, pp_ddh_2 = 3.5_wp ! Also in pycnocline_depth + !!---------------------------------------------------------------------- + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! + IF ( l_shear(ji,jj) ) THEN + ! + IF ( l_conv(ji,jj) ) THEN + ! + IF ( av_db_bl(ji,jj) > 1e-15_wp ) THEN + IF ( n_ddh(ji,jj) == 0 ) THEN + zvel_max = ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**p2third / hbl(ji,jj) + ! ddhdt for pycnocline determined in osm_calculate_dhdt + zddhdt = -1.0_wp * pp_ddh * ( 1.0_wp - 1.6_wp * pdh(ji,jj) / phbl(ji,jj) ) * pwb_ent(ji,jj) / & + & ( zvel_max + MAX( av_db_bl(ji,jj), 1e-15 ) ) + zddhdt = EXP( -4.0_wp * ABS( ff_t(ji,jj) ) * phbl(ji,jj) / MAX( sustar(ji,jj), 1e-8 ) ) * zddhdt + ! Maximum limit for how thick the shear layer can grow relative to the thickness of the boundary layer + dh(ji,jj) = MIN( dh(ji,jj) + zddhdt * rn_Dt, 0.625_wp * hbl(ji,jj) ) + ELSE ! Need to recalculate because hbl has been updated + IF ( ( swstrc(ji,jj) / svstr(ji,jj) )**3 <= 0.5_wp ) THEN + ztmp = svstr(ji,jj) + ELSE + ztmp = swstrc(ji,jj) + END IF + zari = MIN( 1.5_wp * av_db_bl(ji,jj) / ( phbl(ji,jj) * ( MAX( pdbdz_bl_ext(ji,jj), 0.0_wp ) + & + & av_db_bl(ji,jj)**2 / MAX( 4.5_wp * ztmp**2, & + & 1e-12_wp ) ) ), 0.2_wp ) + ztau = MAX( av_db_bl(ji,jj) * ( zari * hbl(ji,jj) ) / & + & ( pp_ddh_2 * MAX( -1.0_wp * pwb_ent(ji,jj), 1e-12_wp ) ), 2.0_wp * rn_Dt ) + dh(ji,jj) = dh(ji,jj) * EXP( -1.0_wp * rn_Dt / ztau ) + & + & zari * phbl(ji,jj) * ( 1.0_wp - EXP( -1.0_wp * rn_Dt / ztau ) ) + IF ( dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zari * phbl(ji,jj) + END IF + ELSE + ztau = MAX( MAX( hbl(ji,jj) / ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird, epsln), 2.0_wp * rn_Dt ) + dh(ji,jj) = dh(ji,jj) * EXP( -1.0_wp * rn_Dt / ztau ) + & + & 0.2_wp * phbl(ji,jj) * ( 1.0_wp - EXP( -1.0_wp * rn_Dt / ztau ) ) + IF ( dh(ji,jj) > hbl(ji,jj) ) dh(ji,jj) = 0.2_wp * hbl(ji,jj) + END IF + ! + ELSE ! l_conv + ! Initially shear only for entraining OSBL. Stable code will be needed if extended to stable OSBL + ztau = hbl(ji,jj) / MAX(svstr(ji,jj), epsln) + IF ( pdhdt(ji,jj) >= 0.0_wp ) THEN ! Probably shouldn't include wm here + ! Boundary layer deepening + IF ( av_db_bl(ji,jj) > 0.0_wp ) THEN + ! Pycnocline thickness set by stratification - use same relationship as for neutral conditions + zari = MIN( 4.5_wp * ( svstr(ji,jj)**2 ) / MAX( av_db_bl(ji,jj) * phbl(ji,jj), epsln ) + 0.01_wp, 0.2_wp ) + zdh_ref = MIN( zari, 0.2_wp ) * hbl(ji,jj) + ELSE + zdh_ref = 0.2_wp * hbl(ji,jj) + ENDIF + ELSE ! IF(dhdt < 0) + zdh_ref = 0.2_wp * hbl(ji,jj) + ENDIF ! IF (dhdt >= 0) + dh(ji,jj) = dh(ji,jj) * EXP( -1.0_wp * rn_Dt / ztau ) + zdh_ref * ( 1.0_wp - EXP( -1.0_wp * rn_Dt / ztau ) ) + IF ( pdhdt(ji,jj) < 0.0_wp .AND. dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref ! Can be a problem with dh>hbl for + ! ! rapid collapse + ENDIF + ! + ELSE ! l_shear = .FALSE., calculate ddhdt here + ! + IF ( l_conv(ji,jj) ) THEN + ! + IF( ln_osm_mle ) THEN + IF ( ( pwb_ent(ji,jj) + 2.0_wp * pwb_fk_b(ji,jj) ) < 0.0_wp ) THEN ! OSBL is deepening. Note wb_fk_b is zero if + ! ! ln_osm_mle=F + IF ( av_db_bl(ji,jj) > 0.0_wp .AND. pdbdz_bl_ext(ji,jj) > 0.0_wp ) THEN + IF ( ( swstrc(ji,jj) / MAX( svstr(ji,jj), epsln) )**3 <= 0.5_wp ) THEN ! Near neutral stability + ztmp = svstr(ji,jj) + ELSE ! Unstable + ztmp = swstrc(ji,jj) + END IF + zari = MIN( 1.5_wp * av_db_bl(ji,jj) / & + & ( phbl(ji,jj) * ( MAX( pdbdz_bl_ext(ji,jj), 0.0_wp ) + & + & av_db_bl(ji,jj)**2 / MAX( 4.5_wp * ztmp**2 , 1e-12_wp ) ) ), 0.2_wp ) + ELSE + zari = 0.2_wp + END IF + ELSE + zari = 0.2_wp + END IF + ztau = 0.2_wp * hbl(ji,jj) / MAX( epsln, ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird ) + zdh_ref = zari * hbl(ji,jj) + ELSE ! ln_osm_mle + IF ( av_db_bl(ji,jj) > 0.0_wp .AND. pdbdz_bl_ext(ji,jj) > 0.0_wp ) THEN + IF ( ( swstrc(ji,jj) / MAX( svstr(ji,jj), epsln ) )**3 <= 0.5_wp ) THEN ! Near neutral stability + ztmp = svstr(ji,jj) + ELSE ! Unstable + ztmp = swstrc(ji,jj) + END IF + zari = MIN( 1.5_wp * av_db_bl(ji,jj) / & + & ( phbl(ji,jj) * ( MAX( pdbdz_bl_ext(ji,jj), 0.0_wp ) + & + & av_db_bl(ji,jj)**2 / MAX( 4.5_wp * ztmp**2 , 1e-12_wp ) ) ), 0.2_wp ) + ELSE + zari = 0.2_wp + END IF + ztau = hbl(ji,jj) / MAX( epsln, ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird ) + zdh_ref = zari * hbl(ji,jj) + END IF ! ln_osm_mle + dh(ji,jj) = dh(ji,jj) * EXP( -1.0_wp * rn_Dt / ztau ) + zdh_ref * ( 1.0_wp - EXP( -1.0_wp * rn_Dt / ztau ) ) + ! IF ( pdhdt(ji,jj) < 0._wp .and. dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref + IF ( dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref + ! Alan: this hml is never defined or used + ELSE ! IF (l_conv) + ! + ztau = hbl(ji,jj) / MAX( svstr(ji,jj), epsln ) + IF ( pdhdt(ji,jj) >= 0.0_wp ) THEN ! Probably shouldn't include wm here + ! Boundary layer deepening + IF ( av_db_bl(ji,jj) > 0.0_wp ) THEN + ! Pycnocline thickness set by stratification - use same relationship as for neutral conditions. + zari = MIN( 4.5_wp * ( svstr(ji,jj)**2 ) / MAX( av_db_bl(ji,jj) * phbl(ji,jj), epsln ) + 0.01_wp , 0.2_wp ) + zdh_ref = MIN( zari, 0.2_wp ) * hbl(ji,jj) + ELSE + zdh_ref = 0.2_wp * hbl(ji,jj) + END IF + ELSE ! IF(dhdt < 0) + zdh_ref = 0.2_wp * hbl(ji,jj) + END IF ! IF (dhdt >= 0) + dh(ji,jj) = dh(ji,jj) * EXP( -1.0_wp * rn_Dt / ztau ) + zdh_ref * ( 1.0_wp - EXP( -1.0_wp * rn_Dt / ztau ) ) + IF ( pdhdt(ji,jj) < 0.0_wp .AND. dh(ji,jj) >= hbl(ji,jj) ) dh(ji,jj) = zdh_ref ! Can be a problem with dh>hbl for + ! ! rapid collapse + END IF ! IF (l_conv) + ! + END IF ! l_shear + ! + hml(ji,jj) = hbl(ji,jj) - dh(ji,jj) + inhml = MAX( INT( dh(ji,jj) / MAX( e3t(ji,jj,nbld(ji,jj)-1,Kmm), 1e-3_wp ) ), 1 ) + nmld(ji,jj) = MAX( nbld(ji,jj) - inhml, 3 ) + phml(ji,jj) = gdepw(ji,jj,nmld(ji,jj),Kmm) + pdh(ji,jj) = phbl(ji,jj) - phml(ji,jj) + ! + END_2D + ! + END SUBROUTINE zdf_osm_pycnocline_thickness + + SUBROUTINE zdf_osm_pycnocline_buoyancy_profiles( Kmm, kp_ext, pdbdz, palpha, pdh, & + & phbl, pdbdz_bl_ext, phml, pdhdt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_pycnocline_buoyancy_profiles *** + !! + !! ** Purpose : calculate pycnocline buoyancy profiles + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Ocean time-level index + INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: kp_ext ! External-level offsets + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT( out) :: pdbdz ! Gradients in the pycnocline + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT( out) :: palpha + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline thickness + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! Rates of change of hbl + !! + INTEGER :: jk, jj, ji + REAL(wp) :: zbgrad + REAL(wp) :: zgamma_b_nd, znd + REAL(wp) :: zzeta_m + REAL(wp) :: ztmp ! Auxiliary variable + !! + REAL(wp), PARAMETER :: pp_gamma_b = 2.25_wp + REAL(wp), PARAMETER :: pp_large = -1e10_wp + !!---------------------------------------------------------------------- + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + pdbdz(ji,jj,:) = pp_large + palpha(ji,jj) = pp_large + END_2D + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! + IF ( nbld(ji,jj) + kp_ext(ji,jj) < mbkt(ji,jj) ) THEN + ! + IF ( l_conv(ji,jj) ) THEN ! Convective conditions + ! + IF ( l_pyc(ji,jj) ) THEN + ! + zzeta_m = 0.1_wp + 0.3_wp / ( 1.0_wp + EXP( -3.5_wp * LOG10( -1.0_wp * shol(ji,jj) ) ) ) + palpha(ji,jj) = 2.0_wp * ( 1.0_wp - ( 0.80_wp * zzeta_m + 0.5_wp * SQRT( 3.14159_wp / pp_gamma_b ) ) * & + & pdbdz_bl_ext(ji,jj) * pdh(ji,jj) / av_db_ml(ji,jj) ) / & + & ( 0.723_wp + SQRT( 3.14159_wp / pp_gamma_b ) ) + palpha(ji,jj) = MAX( palpha(ji,jj), 0.0_wp ) + ztmp = 1.0_wp / MAX( pdh(ji,jj), epsln ) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Commented lines in this section are not needed in new code, once tested ! + ! can be removed ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! ztgrad = zalpha * av_dt_ml(ji,jj) * ztmp + zdtdz_bl_ext(ji,jj) + ! zsgrad = zalpha * av_ds_ml(ji,jj) * ztmp + zdsdz_bl_ext(ji,jj) + zbgrad = palpha(ji,jj) * av_db_ml(ji,jj) * ztmp + pdbdz_bl_ext(ji,jj) + zgamma_b_nd = pdbdz_bl_ext(ji,jj) * pdh(ji,jj) / MAX( av_db_ml(ji,jj), epsln ) + DO jk = 2, nbld(ji,jj) + znd = -1.0_wp * ( gdepw(ji,jj,jk,Kmm) - phbl(ji,jj) ) * ztmp + IF ( znd <= zzeta_m ) THEN + ! zdtdz(ji,jj,jk) = zdtdz_bl_ext(ji,jj) + zalpha * av_dt_ml(ji,jj) * ztmp * & + ! & EXP( -6.0 * ( znd -zzeta_m )**2 ) + ! zdsdz(ji,jj,jk) = zdsdz_bl_ext(ji,jj) + zalpha * av_ds_ml(ji,jj) * ztmp * & + ! & EXP( -6.0 * ( znd -zzeta_m )**2 ) + pdbdz(ji,jj,jk) = pdbdz_bl_ext(ji,jj) + palpha(ji,jj) * av_db_ml(ji,jj) * ztmp * & + & EXP( -6.0_wp * ( znd -zzeta_m )**2 ) + ELSE + ! zdtdz(ji,jj,jk) = ztgrad * EXP( -pp_gamma_b * ( znd - zzeta_m )**2 ) + ! zdsdz(ji,jj,jk) = zsgrad * EXP( -pp_gamma_b * ( znd - zzeta_m )**2 ) + pdbdz(ji,jj,jk) = zbgrad * EXP( -1.0_wp * pp_gamma_b * ( znd - zzeta_m )**2 ) + END IF + END DO + END IF ! If no pycnocline pycnocline gradients set to zero + ! + ELSE ! Stable conditions + ! If pycnocline profile only defined when depth steady of increasing. + IF ( pdhdt(ji,jj) > 0.0_wp ) THEN ! Depth increasing, or steady. + IF ( av_db_bl(ji,jj) > 0.0_wp ) THEN + IF ( shol(ji,jj) >= 0.5_wp ) THEN ! Very stable - 'thick' pycnocline + ztmp = 1.0_wp / MAX( phbl(ji,jj), epsln ) + zbgrad = av_db_bl(ji,jj) * ztmp + DO jk = 2, nbld(ji,jj) + znd = gdepw(ji,jj,jk,Kmm) * ztmp + pdbdz(ji,jj,jk) = zbgrad * EXP( -15.0_wp * ( znd - 0.9_wp )**2 ) + END DO + ELSE ! Slightly stable - 'thin' pycnoline - needed when stable layer begins to form. + ztmp = 1.0_wp / MAX( pdh(ji,jj), epsln ) + zbgrad = av_db_bl(ji,jj) * ztmp + DO jk = 2, nbld(ji,jj) + znd = -1.0_wp * ( gdepw(ji,jj,jk,Kmm) - phml(ji,jj) ) * ztmp + pdbdz(ji,jj,jk) = zbgrad * EXP( -1.75_wp * ( znd + 0.75_wp )**2 ) + END DO + END IF ! IF (shol >=0.5) + END IF ! IF (av_db_bl> 0.) + END IF ! IF (pdhdt >= 0) pdhdt < 0 not considered since pycnocline profile is zero and profile arrays are + ! ! intialized to zero + ! + END IF ! IF (l_conv) + ! + END IF ! IF ( nbld(ji,jj) < mbkt(ji,jj) ) + ! + END_2D + ! + IF ( ln_dia_pyc_scl ) THEN ! Output of pycnocline gradient profiles + CALL zdf_osm_iomput( "zdbdz_pyc", wmask(A2D(0),:) * pdbdz(A2D(0),:) ) + END IF + ! + END SUBROUTINE zdf_osm_pycnocline_buoyancy_profiles + + SUBROUTINE zdf_osm_diffusivity_viscosity( Kbb, Kmm, pdiffut, pviscos, phbl, & + & phml, pdh, pdhdt, pshear, & + & pwb_ent, pwb_min ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_diffusivity_viscosity *** + !! + !! ** Purpose : Determines the eddy diffusivity and eddy viscosity + !! profiles in the mixed layer and the pycnocline. + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kbb, Kmm ! Ocean time-level indices + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(inout) :: pdiffut ! t-diffusivity + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(inout) :: pviscos ! Viscosity + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pshear ! Shear production + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_min + !! + INTEGER :: ji, jj, jk ! Loop indices + !! Scales used to calculate eddy diffusivity and viscosity profiles + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdifml_sc, zvisml_sc + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zdifpyc_n_sc, zdifpyc_s_sc + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zvispyc_n_sc, zvispyc_s_sc + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zbeta_d_sc, zbeta_v_sc + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zb_coup, zc_coup_vis, zc_coup_dif + !! + REAL(wp) :: zvel_sc_pyc, zvel_sc_ml, zstab_fac, zz_b + REAL(wp) :: za_cubic, zb_d_cubic, zc_d_cubic, zd_d_cubic, & ! Coefficients in cubic polynomial specifying diffusivity + & zb_v_cubic, zc_v_cubic, zd_v_cubic ! and viscosity in pycnocline + REAL(wp) :: zznd_ml, zznd_pyc, ztmp + REAL(wp) :: zmsku, zmskv + !! + REAL(wp), PARAMETER :: pp_dif_ml = 0.8_wp, pp_vis_ml = 0.375_wp + REAL(wp), PARAMETER :: pp_dif_pyc = 0.15_wp, pp_vis_pyc = 0.142_wp + REAL(wp), PARAMETER :: pp_vispyc_shr = 0.15_wp + !!---------------------------------------------------------------------- + ! + zb_coup(:,:) = 0.0_wp + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( l_conv(ji,jj) ) THEN + ! + zvel_sc_pyc = ( 0.15_wp * svstr(ji,jj)**3 + swstrc(ji,jj)**3 + 4.25_wp * pshear(ji,jj) * phbl(ji,jj) )**pthird + zvel_sc_ml = ( svstr(ji,jj)**3 + 0.5_wp * swstrc(ji,jj)**3 )**pthird + zstab_fac = ( phml(ji,jj) / zvel_sc_ml * & + & ( 1.4_wp - 0.4_wp / ( 1.0_wp + EXP(-3.5_wp * LOG10( -1.0_wp * shol(ji,jj) ) ) )**1.25_wp ) )**2 + ! + zdifml_sc(ji,jj) = pp_dif_ml * phml(ji,jj) * zvel_sc_ml + zvisml_sc(ji,jj) = pp_vis_ml * zdifml_sc(ji,jj) + ! + IF ( l_pyc(ji,jj) ) THEN + zdifpyc_n_sc(ji,jj) = pp_dif_pyc * zvel_sc_ml * pdh(ji,jj) + zvispyc_n_sc(ji,jj) = 0.09_wp * zvel_sc_pyc * ( 1.0_wp - phbl(ji,jj) / pdh(ji,jj) )**2 * & + & ( 0.005_wp * ( av_u_ml(ji,jj) - av_u_bl(ji,jj) )**2 + & + & 0.0075_wp * ( av_v_ml(ji,jj) - av_v_bl(ji,jj) )**2 ) / & + & pdh(ji,jj) + zvispyc_n_sc(ji,jj) = pp_vis_pyc * zvel_sc_ml * pdh(ji,jj) + zvispyc_n_sc(ji,jj) * zstab_fac + ! + IF ( l_shear(ji,jj) .AND. n_ddh(ji,jj) /= 2 ) THEN + ztmp = pp_vispyc_shr * ( pshear(ji,jj) * phbl(ji,jj) )**pthird * phbl(ji,jj) + zdifpyc_n_sc(ji,jj) = zdifpyc_n_sc(ji,jj) + ztmp + zvispyc_n_sc(ji,jj) = zvispyc_n_sc(ji,jj) + ztmp + ENDIF + ! + zdifpyc_s_sc(ji,jj) = pwb_ent(ji,jj) + 0.0025_wp * zvel_sc_pyc * ( phbl(ji,jj) / pdh(ji,jj) - 1.0_wp ) * & + & ( av_b_ml(ji,jj) - av_b_bl(ji,jj) ) + zvispyc_s_sc(ji,jj) = 0.09_wp * ( pwb_min(ji,jj) + 0.0025_wp * zvel_sc_pyc * & + & ( phbl(ji,jj) / pdh(ji,jj) - 1.0_wp ) * & + & ( av_b_ml(ji,jj) - av_b_bl(ji,jj) ) ) + zdifpyc_s_sc(ji,jj) = 0.09_wp * zdifpyc_s_sc(ji,jj) * zstab_fac + zvispyc_s_sc(ji,jj) = zvispyc_s_sc(ji,jj) * zstab_fac + ! + zdifpyc_s_sc(ji,jj) = MAX( zdifpyc_s_sc(ji,jj), -0.5_wp * zdifpyc_n_sc(ji,jj) ) + zvispyc_s_sc(ji,jj) = MAX( zvispyc_s_sc(ji,jj), -0.5_wp * zvispyc_n_sc(ji,jj) ) + + zbeta_d_sc(ji,jj) = 1.0_wp - ( ( zdifpyc_n_sc(ji,jj) + 1.4_wp * zdifpyc_s_sc(ji,jj) ) / & + & ( zdifml_sc(ji,jj) + epsln ) )**p2third + zbeta_v_sc(ji,jj) = 1.0_wp - 2.0_wp * ( zvispyc_n_sc(ji,jj) + zvispyc_s_sc(ji,jj) ) / ( zvisml_sc(ji,jj) + epsln ) + ELSE + zdifpyc_n_sc(ji,jj) = pp_dif_pyc * zvel_sc_ml * pdh(ji,jj) ! ag 19/03 + zdifpyc_s_sc(ji,jj) = 0.0_wp ! ag 19/03 + zvispyc_n_sc(ji,jj) = pp_vis_pyc * zvel_sc_ml * pdh(ji,jj) ! ag 19/03 + zvispyc_s_sc(ji,jj) = 0.0_wp ! ag 19/03 + IF(l_coup(ji,jj) ) THEN ! ag 19/03 + ! code from SUBROUTINE tke_tke zdftke.F90; uses bottom drag velocity rCdU_bot(ji,jj) = -Cd|ub| + ! already calculated at T-points in SUBROUTINE zdf_drg from zdfdrg.F90 + ! Gives friction velocity sqrt bottom drag/rho_0 i.e. u* = SQRT(rCdU_bot*ub) + ! wet-cell averaging .. + zmsku = 0.5_wp * ( 2.0_wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) + zmskv = 0.5_wp * ( 2.0_wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) + zb_coup(ji,jj) = 0.4_wp * SQRT(-1.0_wp * rCdU_bot(ji,jj) * & + & SQRT( ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2 & + & + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2 ) ) + + zz_b = -1.0_wp * gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) ! ag 19/03 + zc_coup_vis(ji,jj) = -0.5_wp * ( 0.5_wp * zvisml_sc(ji,jj) / phml(ji,jj) - zb_coup(ji,jj) ) / & + & ( phml(ji,jj) + zz_b ) ! ag 19/03 + zz_b = -1.0_wp * phml(ji,jj) + gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) ! ag 19/03 + zbeta_v_sc(ji,jj) = 1.0_wp - 2.0_wp * ( zb_coup(ji,jj) * zz_b + zc_coup_vis(ji,jj) * zz_b**2 ) / & + & zvisml_sc(ji,jj) ! ag 19/03 + zbeta_d_sc(ji,jj) = 1.0_wp - ( ( zb_coup(ji,jj) * zz_b + zc_coup_vis(ji,jj) * zz_b**2 ) / & + & zdifml_sc(ji,jj) )**p2third + zc_coup_dif(ji,jj) = 0.5_wp * ( -zdifml_sc(ji,jj) / phml(ji,jj) * ( 1.0_wp - zbeta_d_sc(ji,jj) )**1.5_wp + & + & 1.5_wp * ( zdifml_sc(ji,jj) / phml(ji,jj) ) * zbeta_d_sc(ji,jj) * & + & SQRT( 1.0_wp - zbeta_d_sc(ji,jj) ) - zb_coup(ji,jj) ) / zz_b ! ag 19/03 + ELSE ! ag 19/03 + zbeta_d_sc(ji,jj) = 1.0_wp - ( ( zdifpyc_n_sc(ji,jj) + 1.4_wp * zdifpyc_s_sc(ji,jj) ) / & + & ( zdifml_sc(ji,jj) + epsln ) )**p2third ! ag 19/03 + zbeta_v_sc(ji,jj) = 1.0_wp - 2.0_wp * ( zvispyc_n_sc(ji,jj) + zvispyc_s_sc(ji,jj) ) / & + & ( zvisml_sc(ji,jj) + epsln ) ! ag 19/03 + ENDIF ! ag 19/03 + ENDIF ! ag 19/03 + ELSE + zdifml_sc(ji,jj) = svstr(ji,jj) * phbl(ji,jj) * MAX( EXP ( -1.0_wp * ( shol(ji,jj) / 0.6_wp )**2 ), 0.2_wp) + zvisml_sc(ji,jj) = zdifml_sc(ji,jj) + END IF + END_2D + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( l_conv(ji,jj) ) THEN + DO jk = 2, nmld(ji,jj) ! Mixed layer diffusivity + zznd_ml = gdepw(ji,jj,jk,Kmm) / phml(ji,jj) + pdiffut(ji,jj,jk) = zdifml_sc(ji,jj) * zznd_ml * ( 1.0_wp - zbeta_d_sc(ji,jj) * zznd_ml )**1.5 + pviscos(ji,jj,jk) = zvisml_sc(ji,jj) * zznd_ml * ( 1.0_wp - zbeta_v_sc(ji,jj) * zznd_ml ) * & + & ( 1.0_wp - 0.5_wp * zznd_ml**2 ) + END DO + ! + ! Coupling to bottom + ! + IF ( l_coup(ji,jj) ) THEN ! ag 19/03 + DO jk = mbkt(ji,jj), nmld(ji,jj), -1 ! ag 19/03 + zz_b = -1.0_wp * ( gdepw(ji,jj,jk,Kmm) - gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) ) ! ag 19/03 + pviscos(ji,jj,jk) = zb_coup(ji,jj) * zz_b + zc_coup_vis(ji,jj) * zz_b**2 ! ag 19/03 + pdiffut(ji,jj,jk) = zb_coup(ji,jj) * zz_b + zc_coup_dif(ji,jj) * zz_b**2 ! ag 19/03 + END DO ! ag 19/03 + ENDIF ! ag 19/03 + ! Pycnocline + IF ( l_pyc(ji,jj) ) THEN + ! Diffusivity and viscosity profiles in the pycnocline given by + ! cubic polynomial. Note, if l_pyc TRUE can't be coupled to seabed. + za_cubic = 0.5_wp + zb_d_cubic = -1.75_wp * zdifpyc_s_sc(ji,jj) / zdifpyc_n_sc(ji,jj) + zd_d_cubic = ( pdh(ji,jj) * zdifml_sc(ji,jj) / phml(ji,jj) * SQRT( 1.0_wp - zbeta_d_sc(ji,jj) ) * & + & ( 2.5_wp * zbeta_d_sc(ji,jj) - 1.0_wp ) - 0.85_wp * zdifpyc_s_sc(ji,jj) ) / & + & MAX( zdifpyc_n_sc(ji,jj), 1.0e-8_wp ) + zd_d_cubic = zd_d_cubic - zb_d_cubic - 2.0_wp * ( 1.0_wp - za_cubic - zb_d_cubic ) + zc_d_cubic = 1.0_wp - za_cubic - zb_d_cubic - zd_d_cubic + zb_v_cubic = -1.75_wp * zvispyc_s_sc(ji,jj) / zvispyc_n_sc(ji,jj) + zd_v_cubic = ( 0.5_wp * zvisml_sc(ji,jj) * pdh(ji,jj) / phml(ji,jj) - 0.85_wp * zvispyc_s_sc(ji,jj) ) / & + & MAX( zvispyc_n_sc(ji,jj), 1.0e-8_wp ) + zd_v_cubic = zd_v_cubic - zb_v_cubic - 2.0_wp * ( 1.0_wp - za_cubic - zb_v_cubic ) + zc_v_cubic = 1.0_wp - za_cubic - zb_v_cubic - zd_v_cubic + DO jk = nmld(ji,jj) , nbld(ji,jj) + zznd_pyc = -1.0_wp * ( gdepw(ji,jj,jk,Kmm) - phbl(ji,jj) ) / MAX(pdh(ji,jj), 1.0e-6_wp ) + ztmp = ( 1.75_wp * zznd_pyc - 0.15_wp * zznd_pyc**2 - 0.2_wp * zznd_pyc**3 ) + ! + pdiffut(ji,jj,jk) = zdifpyc_n_sc(ji,jj) * & + & ( za_cubic + zb_d_cubic * zznd_pyc + zc_d_cubic * zznd_pyc**2 + zd_d_cubic * zznd_pyc**3 ) + ! + pdiffut(ji,jj,jk) = pdiffut(ji,jj,jk) + zdifpyc_s_sc(ji,jj) * ztmp + pviscos(ji,jj,jk) = zvispyc_n_sc(ji,jj) * & + & ( za_cubic + zb_v_cubic * zznd_pyc + zc_v_cubic * zznd_pyc**2 + zd_v_cubic * zznd_pyc**3 ) + pviscos(ji,jj,jk) = pviscos(ji,jj,jk) + zvispyc_s_sc(ji,jj) * ztmp + END DO + ! IF ( pdhdt(ji,jj) > 0._wp ) THEN + ! zdiffut(ji,jj,nbld(ji,jj)+1) = MAX( 0.5 * pdhdt(ji,jj) * e3w(ji,jj,nbld(ji,jj)+1,Kmm), 1.0e-6 ) + ! zviscos(ji,jj,nbld(ji,jj)+1) = MAX( 0.5 * pdhdt(ji,jj) * e3w(ji,jj,nbld(ji,jj)+1,Kmm), 1.0e-6 ) + ! ELSE + ! zdiffut(ji,jj,nbld(ji,jj)) = 0._wp + ! zviscos(ji,jj,nbld(ji,jj)) = 0._wp + ! ENDIF + ENDIF + ELSE + ! Stable conditions + DO jk = 2, nbld(ji,jj) + zznd_ml = gdepw(ji,jj,jk,Kmm) / phbl(ji,jj) + pdiffut(ji,jj,jk) = 0.75_wp * zdifml_sc(ji,jj) * zznd_ml * ( 1.0_wp - zznd_ml )**1.5_wp + pviscos(ji,jj,jk) = 0.375_wp * zvisml_sc(ji,jj) * zznd_ml * ( 1.0_wp - zznd_ml ) * ( 1.0_wp - zznd_ml**2 ) + END DO + ! + IF ( pdhdt(ji,jj) > 0.0_wp ) THEN + pdiffut(ji,jj,nbld(ji,jj)) = MAX( pdhdt(ji,jj), 1.0e-6_wp) * e3w(ji, jj, nbld(ji,jj), Kmm) + pviscos(ji,jj,nbld(ji,jj)) = pdiffut(ji,jj,nbld(ji,jj)) + ENDIF + ENDIF ! End if ( l_conv ) + ! + END_2D + CALL zdf_osm_iomput( "pb_coup", tmask(A2D(0),1) * zb_coup(A2D(0)) ) ! BBL-coupling velocity scale + ! + END SUBROUTINE zdf_osm_diffusivity_viscosity + + SUBROUTINE zdf_osm_fgr_terms( Kmm, kp_ext, phbl, phml, pdh, & + & pdhdt, pshear, pdtdz_bl_ext, pdsdz_bl_ext, pdbdz_bl_ext, & + & pdiffut, pviscos ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_fgr_terms *** + !! + !! ** Purpose : Compute non-gradient terms in flux-gradient relationship + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Time-level index + INTEGER, DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: kp_ext ! Offset for external level + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phml ! ML depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdh ! Pycnocline depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdhdt ! BL depth tendency + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pshear ! Shear production + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdtdz_bl_ext ! External temperature gradients + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdsdz_bl_ext ! External salinity gradients + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbdz_bl_ext ! External buoyancy gradients + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(in ) :: pdiffut ! t-diffusivity + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk), INTENT(in ) :: pviscos ! Viscosity + !! + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zalpha_pyc ! + REAL(wp), DIMENSION(A2D(nn_hls-1),jpk) :: zdbdz_pyc ! Parametrised gradient of buoyancy in the pycnocline + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: z3ddz_pyc_1, z3ddz_pyc_2 ! Pycnocline gradient/shear profiles + !! + INTEGER :: ji, jj, jk, jkm_bld, jkf_mld, jkm_mld ! Loop indices + INTEGER :: istat ! Memory allocation status + REAL(wp) :: zznd_d, zznd_ml, zznd_pyc, znd ! Temporary non-dimensional depths + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zsc_wth_1,zsc_ws_1 ! Temporary scales + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zsc_uw_1, zsc_uw_2 ! Temporary scales + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zsc_vw_1, zsc_vw_2 ! Temporary scales + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: ztau_sc_u ! Dissipation timescale at base of WML + REAL(wp) :: zbuoy_pyc_sc, zdelta_pyc ! + REAL(wp) :: zl_c,zl_l,zl_eps ! Used to calculate turbulence length scale + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: za_cubic, zb_cubic ! Coefficients in cubic polynomial specifying + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zc_cubic, zd_cubic ! diffusivity in pycnocline + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwt_pyc_sc_1, zws_pyc_sc_1 ! + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zzeta_pyc ! + REAL(wp) :: zomega, zvw_max ! + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zuw_bse,zvw_bse ! Momentum, heat, and salinity fluxes + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zwth_ent,zws_ent ! at the top of the pycnocline + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: zsc_wth_pyc, zsc_ws_pyc ! Scales for pycnocline transport term + REAL(wp) :: ztmp ! + REAL(wp) :: ztgrad, zsgrad, zbgrad ! Variables used to calculate pycnocline + !! ! gradients + REAL(wp) :: zugrad, zvgrad ! Variables for calculating pycnocline shear + REAL(wp) :: zdtdz_pyc ! Parametrized gradient of temperature in + !! ! pycnocline + REAL(wp) :: zdsdz_pyc ! Parametrised gradient of salinity in + !! ! pycnocline + REAL(wp) :: zdudz_pyc ! u-shear across the pycnocline + REAL(wp) :: zdvdz_pyc ! v-shear across the pycnocline + !!---------------------------------------------------------------------- + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Pycnocline gradients for scalars and velocity + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL zdf_osm_pycnocline_buoyancy_profiles( Kmm, kp_ext, zdbdz_pyc, zalpha_pyc, pdh, & + & phbl, pdbdz_bl_ext, phml, pdhdt ) + ! + ! Auxiliary indices + ! ----------------- + jkm_bld = 0 + jkf_mld = jpk + jkm_mld = 0 + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( nbld(ji,jj) > jkm_bld ) jkm_bld = nbld(ji,jj) + IF ( nmld(ji,jj) < jkf_mld ) jkf_mld = nmld(ji,jj) + IF ( nmld(ji,jj) > jkm_mld ) jkm_mld = nmld(ji,jj) + END_2D + ! + ! Stokes term in scalar flux, flux-gradient relationship + ! ------------------------------------------------------ + WHERE ( l_conv(A2D(nn_hls-1)) ) + zsc_wth_1(:,:) = swstrl(A2D(nn_hls-1))**3 * swth0(A2D(nn_hls-1)) / & + & ( svstr(A2D(nn_hls-1))**3 + 0.5_wp * swstrc(A2D(nn_hls-1))**3 + epsln ) + zsc_ws_1(:,:) = swstrl(A2D(nn_hls-1))**3 * sws0(A2D(nn_hls-1)) / & + & ( svstr(A2D(nn_hls-1))**3 + 0.5_wp * swstrc(A2D(nn_hls-1))**3 + epsln ) + ELSEWHERE + zsc_wth_1(:,:) = 2.0_wp * swthav(A2D(nn_hls-1)) + zsc_ws_1(:,:) = 2.0_wp * swsav(A2D(nn_hls-1)) + ENDWHERE + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, MAX( jkm_mld, jkm_bld ) ) + IF ( l_conv(ji,jj) ) THEN + IF ( jk <= nmld(ji,jj) ) THEN + zznd_d = gdepw(ji,jj,jk,Kmm) / dstokes(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 1.35_wp * EXP( -1.0_wp * zznd_d ) * & + & ( 1.0_wp - EXP( -2.0_wp * zznd_d ) ) * zsc_wth_1(ji,jj) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 1.35_wp * EXP( -1.0_wp * zznd_d ) * & + & ( 1.0_wp - EXP( -2.0_wp * zznd_d ) ) * zsc_ws_1(ji,jj) + END IF + ELSE ! Stable conditions + IF ( jk <= nbld(ji,jj) ) THEN + zznd_d = gdepw(ji,jj,jk,Kmm) / dstokes(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 2.15_wp * EXP( -0.85_wp * zznd_d ) * & + & ( 1.0_wp - EXP( -4.0_wp * zznd_d ) ) * zsc_wth_1(ji,jj) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 2.15_wp * EXP( -0.85_wp * zznd_d ) * & + & ( 1.0_wp - EXP( -4.0_wp * zznd_d ) ) * zsc_ws_1(ji,jj) + END IF + END IF ! Check on l_conv + END_3D + ! + IF ( ln_dia_osm ) THEN + CALL zdf_osm_iomput( "ghamu_00", wmask(A2D(0),:) * ghamu(A2D(0),:) ) + CALL zdf_osm_iomput( "ghamv_00", wmask(A2D(0),:) * ghamv(A2D(0),:) ) + END IF + ! + ! Stokes term in flux-gradient relationship (note in zsc_uw_n don't use + ! svstr since term needs to go to zero as swstrl goes to zero) + ! --------------------------------------------------------------------- + WHERE ( l_conv(A2D(nn_hls-1)) ) + zsc_uw_1(:,:) = ( swstrl(A2D(nn_hls-1))**3 + & + & 0.5_wp * swstrc(A2D(nn_hls-1))**3 )**pthird * sustke(A2D(nn_hls-1)) / & + & MAX( ( 1.0_wp - 1.0_wp * 6.5_wp * sla(A2D(nn_hls-1))**( 8.0_wp / 3.0_wp ) ), 0.2_wp ) + zsc_uw_2(:,:) = ( swstrl(A2D(nn_hls-1))**3 + & + & 0.5_wp * swstrc(A2D(nn_hls-1))**3 )**pthird * sustke(A2D(nn_hls-1)) / & + & MIN( sla(A2D(nn_hls-1))**( 8.0_wp / 3.0_wp ) + epsln, 0.12_wp ) + zsc_vw_1(:,:) = ff_t(A2D(nn_hls-1)) * phml(A2D(nn_hls-1)) * sustke(A2D(nn_hls-1))**3 * & + & MIN( sla(A2D(nn_hls-1))**( 8.0_wp / 3.0_wp ), 0.12_wp ) / & + & ( ( svstr(A2D(nn_hls-1))**3 + 0.5_wp * swstrc(A2D(nn_hls-1))**3 )**( 2.0_wp / 3.0_wp ) + epsln ) + ELSEWHERE + zsc_uw_1(:,:) = sustar(A2D(nn_hls-1))**2 + zsc_vw_1(:,:) = ff_t(A2D(nn_hls-1)) * phbl(A2D(nn_hls-1)) * sustke(A2D(nn_hls-1))**3 * & + & MIN( sla(A2D(nn_hls-1))**( 8.0_wp / 3.0_wp ), 0.12_wp ) / ( svstr(A2D(nn_hls-1))**2 + epsln ) + ENDWHERE + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, MAX( jkm_mld, jkm_bld ) ) + IF ( l_conv(ji,jj) ) THEN + IF ( jk <= nmld(ji,jj) ) THEN + zznd_d = gdepw(ji,jj,jk,Kmm) / dstokes(ji,jj) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + ( -0.05_wp * EXP( -0.4_wp * zznd_d ) * zsc_uw_1(ji,jj) + & + & 0.00125_wp * EXP( -1.0_wp * zznd_d ) * zsc_uw_2(ji,jj) ) * & + & ( 1.0_wp - EXP( -2.0_wp * zznd_d ) ) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) - 0.65_wp * 0.15_wp * EXP( -1.0_wp * zznd_d ) * & + & ( 1.0_wp - EXP( -2.0_wp * zznd_d ) ) * zsc_vw_1(ji,jj) + END IF + ELSE ! Stable conditions + IF ( jk <= nbld(ji,jj) ) THEN ! Corrected to nbld + zznd_d = gdepw(ji,jj,jk,Kmm) / dstokes(ji,jj) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) - 0.75_wp * 1.3_wp * EXP( -0.5_wp * zznd_d ) * & + & ( 1.0_wp - EXP( -4.0_wp * zznd_d ) ) * zsc_uw_1(ji,jj) + END IF + END IF + END_3D + ! + ! Buoyancy term in flux-gradient relationship [note : includes ROI ratio + ! (X0.3) and pressure (X0.5)] + ! ---------------------------------------------------------------------- + WHERE ( l_conv(A2D(nn_hls-1)) ) + zsc_wth_1(:,:) = swbav(A2D(nn_hls-1)) * swth0(A2D(nn_hls-1)) * ( 1.0_wp + EXP( 0.2_wp * shol(A2D(nn_hls-1)) ) ) * & + & phml(A2D(nn_hls-1)) / ( svstr(A2D(nn_hls-1))**3 + 0.5_wp * swstrc(A2D(nn_hls-1))**3 + epsln ) + zsc_ws_1(:,:) = swbav(A2D(nn_hls-1)) * sws0(A2D(nn_hls-1)) * ( 1.0_wp + EXP( 0.2_wp * shol(A2D(nn_hls-1)) ) ) * & + & phml(A2D(nn_hls-1)) / ( svstr(A2D(nn_hls-1))**3 + 0.5_wp * swstrc(A2D(nn_hls-1))**3 + epsln ) + ELSEWHERE + zsc_wth_1(:,:) = 0.0_wp + zsc_ws_1(:,:) = 0.0_wp + ENDWHERE + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, MAX( jkm_mld, jkm_bld ) ) + IF ( l_conv(ji,jj) ) THEN + IF ( jk <= nmld(ji,jj) ) THEN + zznd_ml = gdepw(ji,jj,jk,Kmm) / phml(ji,jj) + ! Calculate turbulent time scale + zl_c = 0.9_wp * ( 1.0_wp - EXP( -5.0_wp * ( zznd_ml + zznd_ml**3 / 3.0_wp ) ) ) * & + & ( 1.0_wp - EXP( -15.0_wp * ( 1.2_wp - zznd_ml ) ) ) + zl_l = 2.0_wp * ( 1.0_wp - EXP( -2.0_wp * ( zznd_ml + zznd_ml**3 / 3.0_wp ) ) ) * & + & ( 1.0_wp - EXP( -8.0_wp * ( 1.15_wp - zznd_ml ) ) ) * ( 1.0_wp + dstokes(ji,jj) / phml (ji,jj) ) + zl_eps = zl_l + ( zl_c - zl_l ) / ( 1.0_wp + EXP( -3.0_wp * LOG10( -1.0_wp * shol(ji,jj) ) ) )**( 3.0_wp / 2.0_wp ) + ! Non-gradient buoyancy terms + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3_wp * 0.4_wp * zsc_wth_1(ji,jj) * zl_eps / ( 0.15_wp + zznd_ml ) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3_wp * 0.4_wp * zsc_ws_1(ji,jj) * zl_eps / ( 0.15_wp + zznd_ml ) + END IF + ELSE ! Stable conditions + IF ( jk <= nbld(ji,jj) ) THEN + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zsc_wth_1(ji,jj) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + zsc_ws_1(ji,jj) + END IF + END IF + END_3D + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( l_conv(ji,jj) .AND. l_pyc(ji,jj) ) THEN + ztau_sc_u(ji,jj) = phml(ji,jj) / ( svstr(ji,jj)**3 + swstrc(ji,jj)**3 )**pthird * & + & ( 1.4_wp - 0.4_wp / ( 1.0_wp + EXP( -3.5_wp * LOG10( -1.0_wp * shol(ji,jj) ) ) )**1.5_wp ) + zwth_ent(ji,jj) = -0.003_wp * ( 0.15_wp * svstr(ji,jj)**3 + swstrc(ji,jj)**3 )**pthird * & + & ( 1.0_wp - pdh(ji,jj) / phbl(ji,jj) ) * av_dt_ml(ji,jj) + zws_ent(ji,jj) = -0.003_wp * ( 0.15_wp * svstr(ji,jj)**3 + swstrc(ji,jj)**3 )**pthird * & + & ( 1.0_wp - pdh(ji,jj) / phbl(ji,jj) ) * av_ds_ml(ji,jj) + IF ( dh(ji,jj) < 0.2_wp * hbl(ji,jj) ) THEN + zbuoy_pyc_sc = 2.0_wp * MAX( av_db_ml(ji,jj), 0.0_wp ) / pdh(ji,jj) + zdelta_pyc = ( svstr(ji,jj)**3 + swstrc(ji,jj)**3 )**pthird / & + & SQRT( MAX( zbuoy_pyc_sc, ( svstr(ji,jj)**3 + swstrc(ji,jj)**3 )**p2third / pdh(ji,jj)**2 ) ) + zwt_pyc_sc_1(ji,jj) = 0.325_wp * ( zalpha_pyc(ji,jj) * av_dt_ml(ji,jj) / pdh(ji,jj) + pdtdz_bl_ext(ji,jj) ) * & + & zdelta_pyc**2 / pdh(ji,jj) + zws_pyc_sc_1(ji,jj) = 0.325_wp * ( zalpha_pyc(ji,jj) * av_ds_ml(ji,jj) / pdh(ji,jj) + pdsdz_bl_ext(ji,jj) ) * & + & zdelta_pyc**2 / pdh(ji,jj) + zzeta_pyc(ji,jj) = 0.15_wp - 0.175_wp / ( 1.0_wp + EXP( -3.5_wp * LOG10( -1.0_wp * shol(ji,jj) ) ) ) + END IF + END IF + END_2D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jkm_bld ) + IF ( l_conv(ji,jj) .AND. l_pyc(ji,jj) .AND. ( jk <= nbld(ji,jj) ) ) THEN + zznd_pyc = -1.0_wp * ( gdepw(ji,jj,jk,Kmm) - phbl(ji,jj) ) / pdh(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) - & + & 0.045_wp * ( ( zwth_ent(ji,jj) * zdbdz_pyc(ji,jj,jk) ) * ztau_sc_u(ji,jj)**2 ) * & + & MAX( ( 1.75_wp * zznd_pyc -0.15_wp * zznd_pyc**2 - 0.2_wp * zznd_pyc**3 ), 0.0_wp ) + ghams(ji,jj,jk) = ghams(ji,jj,jk) - & + & 0.045_wp * ( ( zws_ent(ji,jj) * zdbdz_pyc(ji,jj,jk) ) * ztau_sc_u(ji,jj)**2 ) * & + & MAX( ( 1.75_wp * zznd_pyc -0.15_wp * zznd_pyc**2 - 0.2_wp * zznd_pyc**3 ), 0.0_wp ) + IF ( dh(ji,jj) < 0.2_wp * hbl(ji,jj) .AND. nbld(ji,jj) - nmld(ji,jj) > 3 ) THEN + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.05_wp * zwt_pyc_sc_1(ji,jj) * & + & EXP( -0.25_wp * ( zznd_pyc / zzeta_pyc(ji,jj) )**2 ) * & + & pdh(ji,jj) / ( svstr(ji,jj)**3 + swstrc(ji,jj)**3 )**pthird + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.05_wp * zws_pyc_sc_1(ji,jj) * & + & EXP( -0.25_wp * ( zznd_pyc / zzeta_pyc(ji,jj) )**2 ) * & + & pdh(ji,jj) / ( svstr(ji,jj)**3 + swstrc(ji,jj)**3 )**pthird + END IF + END IF ! End of pycnocline + END_3D + ! + IF ( ln_dia_osm ) THEN + CALL zdf_osm_iomput( "zwth_ent", tmask(A2D(0),1) * zwth_ent(A2D(0)) ) ! Upward turb. temperature entrainment flux + CALL zdf_osm_iomput( "zws_ent", tmask(A2D(0),1) * zws_ent(A2D(0)) ) ! Upward turb. salinity entrainment flux + END IF + ! + zsc_vw_1(:,:) = 0.0_wp + WHERE ( l_conv(A2D(nn_hls-1)) ) + zsc_uw_1(:,:) = -1.0_wp * swb0(A2D(nn_hls-1)) * sustar(A2D(nn_hls-1))**2 * phml(A2D(nn_hls-1)) / & + & ( svstr(A2D(nn_hls-1))**3 + 0.5_wp * swstrc(A2D(nn_hls-1))**3 + epsln ) + zsc_uw_2(:,:) = swb0(A2D(nn_hls-1)) * sustke(A2D(nn_hls-1)) * phml(A2D(nn_hls-1)) / & + & ( svstr(A2D(nn_hls-1))**3 + 0.5_wp * swstrc(A2D(nn_hls-1))**3 + epsln )**( 2.0_wp / 3.0_wp ) + ELSEWHERE + zsc_uw_1(:,:) = 0.0_wp + ENDWHERE + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, MAX( jkm_mld, jkm_bld ) ) + IF ( l_conv(ji,jj) ) THEN + IF ( jk <= nmld(ji,jj) ) THEN + zznd_d = gdepw(ji,jj,jk,Kmm) / dstokes(ji,jj) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + 0.3_wp * 0.5_wp * & + & ( zsc_uw_1(ji,jj) + 0.125_wp * EXP( -0.5_wp * zznd_d ) * & + & ( 1.0_wp - EXP( -0.5_wp * zznd_d ) ) * zsc_uw_2(ji,jj) ) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zsc_vw_1(ji,jj) + END IF + ELSE ! Stable conditions + IF ( jk <= nbld(ji,jj) ) THEN + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zsc_uw_1(ji,jj) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zsc_vw_1(ji,jj) + END IF + ENDIF + END_3D + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( l_conv(ji,jj) .AND. l_pyc(ji,jj) ) THEN + IF ( n_ddh(ji,jj) == 0 ) THEN + ! Place holding code. Parametrization needs checking for these conditions. + zomega = ( 0.15_wp * swstrl(ji,jj)**3 + swstrc(ji,jj)**3 + 4.75_wp * ( pshear(ji,jj) * phbl(ji,jj) ) )**pthird + zuw_bse(ji,jj) = -0.0035_wp * zomega * ( 1.0_wp - pdh(ji,jj) / phbl(ji,jj) ) * av_du_ml(ji,jj) + zvw_bse(ji,jj) = -0.0075_wp * zomega * ( 1.0_wp - pdh(ji,jj) / phbl(ji,jj) ) * av_dv_ml(ji,jj) + ELSE + zomega = ( 0.15_wp * swstrl(ji,jj)**3 + swstrc(ji,jj)**3 + 4.75_wp * ( pshear(ji,jj) * phbl(ji,jj) ) )**pthird + zuw_bse(ji,jj) = -0.0035_wp * zomega * ( 1.0_wp - pdh(ji,jj) / phbl(ji,jj) ) * av_du_ml(ji,jj) + zvw_bse(ji,jj) = -0.0075_wp * zomega * ( 1.0_wp - pdh(ji,jj) / phbl(ji,jj) ) * av_dv_ml(ji,jj) + ENDIF + zb_cubic(ji,jj) = pdh(ji,jj) / phbl(ji,jj) * suw0(ji,jj) - ( 2.0_wp + pdh(ji,jj) / phml(ji,jj) ) * zuw_bse(ji,jj) + za_cubic(ji,jj) = zuw_bse(ji,jj) - zb_cubic(ji,jj) + zvw_max = 0.7_wp * ff_t(ji,jj) * ( sustke(ji,jj) * dstokes(ji,jj) + 0.7_wp * sustar(ji,jj) * phml(ji,jj) ) + zd_cubic(ji,jj) = zvw_max * pdh(ji,jj) / phml(ji,jj) - ( 2.0_wp + pdh(ji,jj) / phml(ji,jj) ) * zvw_bse(ji,jj) + zc_cubic(ji,jj) = zvw_bse(ji,jj) - zd_cubic(ji,jj) + END IF + END_2D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jkf_mld, jkm_bld ) ! Need ztau_sc_u to be available. Change to array. + IF ( l_conv(ji,jj) .AND. l_pyc(ji,jj) .AND. ( jk >= nmld(ji,jj) ) .AND. ( jk <= nbld(ji,jj) ) ) THEN + zznd_pyc = -1.0_wp * ( gdepw(ji,jj,jk,Kmm) - phbl(ji,jj) ) / pdh(ji,jj) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) - 0.045_wp * ( ztau_sc_u(ji,jj)**2 ) * zuw_bse(ji,jj) * & + & ( za_cubic(ji,jj) * zznd_pyc**2 + zb_cubic(ji,jj) * zznd_pyc**3 ) * & + & ( 0.75_wp + 0.25_wp * zznd_pyc )**2 * zdbdz_pyc(ji,jj,jk) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) - 0.045_wp * ( ztau_sc_u(ji,jj)**2 ) * zvw_bse(ji,jj) * & + & ( zc_cubic(ji,jj) * zznd_pyc**2 + zd_cubic(ji,jj) * zznd_pyc**3 ) * & + & ( 0.75_wp + 0.25_wp * zznd_pyc )**2 * zdbdz_pyc(ji,jj,jk) + END IF ! l_conv .AND. l_pyc + END_3D + ! + IF ( ln_dia_osm ) THEN + CALL zdf_osm_iomput( "ghamu_0", wmask(A2D(0),:) * ghamu(A2D(0),:) ) + CALL zdf_osm_iomput( "zsc_uw_1_0", tmask(A2D(0),1) * zsc_uw_1(A2D(0)) ) + END IF + ! + ! Transport term in flux-gradient relationship [note : includes ROI ratio + ! (X0.3) ] + ! ----------------------------------------------------------------------- + WHERE ( l_conv(A2D(nn_hls-1)) ) + zsc_wth_1(:,:) = swth0(A2D(nn_hls-1)) / ( 1.0_wp - 0.56_wp * EXP( shol(A2D(nn_hls-1)) ) ) + zsc_ws_1(:,:) = sws0(A2D(nn_hls-1)) / ( 1.0_wp - 0.56_wp * EXP( shol(A2D(nn_hls-1)) ) ) + WHERE ( l_pyc(A2D(nn_hls-1)) ) ! Pycnocline scales + zsc_wth_pyc(:,:) = -0.003_wp * swstrc(A2D(nn_hls-1)) * ( 1.0_wp - pdh(A2D(nn_hls-1)) / phbl(A2D(nn_hls-1)) ) * & + & av_dt_ml(A2D(nn_hls-1)) + zsc_ws_pyc(:,:) = -0.003_wp * swstrc(A2D(nn_hls-1)) * ( 1.0_wp - pdh(A2D(nn_hls-1)) / phbl(A2D(nn_hls-1)) ) * & + & av_ds_ml(A2D(nn_hls-1)) + END WHERE + ELSEWHERE + zsc_wth_1(:,:) = 2.0_wp * swthav(A2D(nn_hls-1)) + zsc_ws_1(:,:) = sws0(A2D(nn_hls-1)) + END WHERE + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, MAX( jkm_mld, jkm_bld ) ) + IF ( l_conv(ji,jj) ) THEN + IF ( ( jk > 1 ) .AND. ( jk <= nmld(ji,jj) ) ) THEN + zznd_ml = gdepw(ji,jj,jk,Kmm) / phml(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3_wp * zsc_wth_1(ji,jj) * & + & ( -2.0_wp + 2.75_wp * ( ( 1.0_wp + 0.6_wp * zznd_ml**4 ) - & + & EXP( -6.0_wp * zznd_ml ) ) ) * & + & ( 1.0_wp - EXP( -15.0_wp * ( 1.0_wp - zznd_ml ) ) ) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3_wp * zsc_ws_1(ji,jj) * & + & ( -2.0_wp + 2.75_wp * ( ( 1.0_wp + 0.6_wp * zznd_ml**4 ) - & + & EXP( -6.0_wp * zznd_ml ) ) ) * ( 1.0_wp - EXP( -15.0_wp * ( 1.0_wp - zznd_ml ) ) ) + END IF + ! + ! may need to comment out lpyc block + IF ( l_pyc(ji,jj) .AND. ( jk >= nmld(ji,jj) ) .AND. ( jk <= nbld(ji,jj) ) ) THEN ! Pycnocline + zznd_pyc = -1.0_wp * ( gdepw(ji,jj,jk,Kmm) - phbl(ji,jj) ) / pdh(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 4.0_wp * zsc_wth_pyc(ji,jj) * & + & ( 0.48_wp - EXP( -1.5_wp * ( zznd_pyc - 0.3_wp )**2 ) ) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 4.0_wp * zsc_ws_pyc(ji,jj) * & + & ( 0.48_wp - EXP( -1.5_wp * ( zznd_pyc - 0.3_wp )**2 ) ) + END IF + ELSE + IF( pdhdt(ji,jj) > 0. ) THEN + IF ( ( jk > 1 ) .AND. ( jk <= nbld(ji,jj) ) ) THEN + zznd_d = gdepw(ji,jj,jk,Kmm) / dstokes(ji,jj) + znd = gdepw(ji,jj,jk,Kmm) / phbl(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3_wp * ( -4.06_wp * EXP( -2.0_wp * zznd_d ) * ( 1.0_wp - EXP( -4.0_wp * zznd_d ) ) + & + 7.5_wp * EXP ( -10.0_wp * ( 0.95_wp - znd )**2 ) * ( 1.0_wp - znd ) ) * zsc_wth_1(ji,jj) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3_wp * ( -4.06_wp * EXP( -2.0_wp * zznd_d ) * ( 1.0_wp - EXP( -4.0_wp * zznd_d ) ) + & + 7.5_wp * EXP ( -10.0_wp * ( 0.95_wp - znd )**2 ) * ( 1.0_wp - znd ) ) * zsc_ws_1(ji,jj) + END IF + ENDIF + ENDIF + END_3D + ! + WHERE ( l_conv(A2D(nn_hls-1)) ) + zsc_uw_1(:,:) = sustar(A2D(nn_hls-1))**2 + zsc_vw_1(:,:) = ff_t(A2D(nn_hls-1)) * sustke(A2D(nn_hls-1)) * phml(A2D(nn_hls-1)) + ELSEWHERE + zsc_uw_1(:,:) = sustar(A2D(nn_hls-1))**2 + zsc_uw_2(:,:) = ( 2.25_wp - 3.0_wp * ( 1.0_wp - EXP( -1.25_wp * 2.0_wp ) ) ) * ( 1.0_wp - EXP( -4.0_wp * 2.0_wp ) ) * & + & zsc_uw_1(:,:) + zsc_vw_1(:,:) = ff_t(A2D(nn_hls-1)) * sustke(A2D(nn_hls-1)) * phbl(A2D(nn_hls-1)) + zsc_vw_2(:,:) = -0.11_wp * SIN( 3.14159_wp * ( 2.0_wp + 0.4_wp ) ) * EXP( -1.0_wp * ( 1.5_wp + 2.0_wp )**2 ) * & + & zsc_vw_1(:,:) + ENDWHERE + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, MAX( jkm_mld, jkm_bld ) ) + IF ( l_conv(ji,jj) ) THEN + IF ( jk <= nmld(ji,jj) ) THEN + zznd_ml = gdepw(ji,jj,jk,Kmm) / phml(ji,jj) + zznd_d = gdepw(ji,jj,jk,Kmm) / dstokes(ji,jj) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + & + & 0.3_wp * ( -2.0_wp + 2.5_wp * ( 1.0_wp + 0.1_wp * zznd_ml**4 ) - EXP( -8.0_wp * zznd_ml ) ) * & + & zsc_uw_1(ji,jj) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + & + & 0.3_wp * 0.1_wp * ( EXP( -1.0_wp * zznd_d ) + EXP( -5.0_wp * ( 1.0_wp - zznd_ml ) ) ) * & + & zsc_vw_1(ji,jj) + END IF + ELSE + IF ( jk <= nbld(ji,jj) ) THEN + znd = gdepw(ji,jj,jk,Kmm) / phbl(ji,jj) + zznd_d = gdepw(ji,jj,jk,Kmm) / dstokes(ji,jj) + IF ( zznd_d <= 2.0_wp ) THEN + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + 0.5_wp * 0.3_wp * & + & ( 2.25_wp - 3.0_wp * ( 1.0_wp - EXP( -1.25_wp * zznd_d ) ) * & + & ( 1.0_wp - EXP( -2.0_wp * zznd_d ) ) ) * zsc_uw_1(ji,jj) + ELSE + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + 0.5_wp * 0.3_wp * & + & ( 1.0_wp - EXP( -5.0_wp * ( 1.0_wp - znd ) ) ) * zsc_uw_2(ji,jj) + ENDIF + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + 0.3_wp * 0.15_wp * SIN( 3.14159_wp * ( 0.65_wp * zznd_d ) ) * & + & EXP( -0.25_wp * zznd_d**2 ) * zsc_vw_1(ji,jj) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + 0.3_wp * 0.15_wp * EXP( -5.0 * ( 1.0 - znd ) ) * & + & ( 1.0 - EXP( -20.0 * ( 1.0 - znd ) ) ) * zsc_vw_2(ji,jj) + END IF + END IF + END_3D + ! + IF ( ln_dia_osm ) THEN + CALL zdf_osm_iomput( "ghamu_f", wmask(A2D(0),:) * ghamu(A2D(0),:) ) + CALL zdf_osm_iomput( "ghamv_f", wmask(A2D(0),:) * ghamv(A2D(0),:) ) + CALL zdf_osm_iomput( "zsc_uw_1_f", tmask(A2D(0),1) * zsc_uw_1(A2D(0)) ) + CALL zdf_osm_iomput( "zsc_vw_1_f", tmask(A2D(0),1) * zsc_vw_1(A2D(0)) ) + CALL zdf_osm_iomput( "zsc_uw_2_f", tmask(A2D(0),1) * zsc_uw_2(A2D(0)) ) + CALL zdf_osm_iomput( "zsc_vw_2_f", tmask(A2D(0),1) * zsc_vw_2(A2D(0)) ) + END IF + ! + ! Make surface forced velocity non-gradient terms go to zero at the base + ! of the mixed layer. + ! + ! Make surface forced velocity non-gradient terms go to zero at the base + ! of the boundary layer. + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jkm_bld ) + IF ( ( .NOT. l_conv(ji,jj) ) .AND. ( jk <= nbld(ji,jj) ) ) THEN + znd = -1.0_wp * ( gdepw(ji,jj,jk,Kmm) - phbl(ji,jj) ) / phbl(ji,jj) ! ALMG to think about + IF ( znd >= 0.0_wp ) THEN + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) * ( 1.0_wp - EXP( -10.0_wp * znd**2 ) ) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) * ( 1.0_wp - EXP( -10.0_wp * znd**2 ) ) + ELSE + ghamu(ji,jj,jk) = 0.0_wp + ghamv(ji,jj,jk) = 0.0_wp + ENDIF + END IF + END_3D + ! + ! Pynocline contributions + ! + IF ( ln_dia_pyc_scl .OR. ln_dia_pyc_shr ) THEN ! Allocate arrays for output of pycnocline gradient/shear profiles + ALLOCATE( z3ddz_pyc_1(A2D(nn_hls),jpk), z3ddz_pyc_2(A2D(nn_hls),jpk), STAT=istat ) + IF ( istat /= 0 ) CALL ctl_stop( 'zdf_osm: failed to allocate temporary arrays' ) + z3ddz_pyc_1(:,:,:) = 0.0_wp + z3ddz_pyc_2(:,:,:) = 0.0_wp + END IF + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jkm_bld ) + IF ( l_conv (ji,jj) ) THEN + ! Unstable conditions. Shouldn;t be needed with no pycnocline code. + ! zugrad = 0.7 * av_du_ml(ji,jj) / zdh(ji,jj) + 0.3 * zustar(ji,jj)*zustar(ji,jj) / & + ! & ( ( ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * zhml(ji,jj) ) * & + ! & MIN(zla(ji,jj)**(8.0/3.0) + epsln, 0.12 )) + !Alan is this right? + ! zvgrad = ( 0.7 * av_dv_ml(ji,jj) + & + ! & 2.0 * ff_t(ji,jj) * zustke(ji,jj) * dstokes(ji,jj) / & + ! & ( ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird + epsln ) & + ! & )/ (zdh(ji,jj) + epsln ) + ! DO jk = 2, nbld(ji,jj) - 1 + ibld_ext + ! znd = -( gdepw(ji,jj,jk,Kmm) - zhbl(ji,jj) ) / (zdh(ji,jj) + epsln ) - zzeta_v + ! IF ( znd <= 0.0 ) THEN + ! zdudz(ji,jj,jk) = 1.25 * zugrad * EXP( 3.0 * znd ) + ! zdvdz(ji,jj,jk) = 1.25 * zvgrad * EXP( 3.0 * znd ) + ! ELSE + ! zdudz(ji,jj,jk) = 1.25 * zugrad * EXP( -2.0 * znd ) + ! zdvdz(ji,jj,jk) = 1.25 * zvgrad * EXP( -2.0 * znd ) + ! ENDIF + ! END DO + ELSE ! Stable conditions + IF ( nbld(ji,jj) + kp_ext(ji,jj) < mbkt(ji,jj) ) THEN + ! Pycnocline profile only defined when depth steady of increasing. + IF ( pdhdt(ji,jj) > 0.0_wp ) THEN ! Depth increasing, or steady. + IF ( av_db_bl(ji,jj) > 0.0_wp ) THEN + IF ( shol(ji,jj) >= 0.5_wp ) THEN ! Very stable - 'thick' pycnocline + ztmp = 1.0_wp / MAX( phbl(ji,jj), epsln ) + ztgrad = av_dt_bl(ji,jj) * ztmp + zsgrad = av_ds_bl(ji,jj) * ztmp + zbgrad = av_db_bl(ji,jj) * ztmp + IF ( jk <= nbld(ji,jj) ) THEN + znd = gdepw(ji,jj,jk,Kmm) * ztmp + zdtdz_pyc = ztgrad * EXP( -15.0_wp * ( znd - 0.9_wp )**2 ) + zdsdz_pyc = zsgrad * EXP( -15.0_wp * ( znd - 0.9_wp )**2 ) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + pdiffut(ji,jj,jk) * zdtdz_pyc + ghams(ji,jj,jk) = ghams(ji,jj,jk) + pdiffut(ji,jj,jk) * zdsdz_pyc + IF ( ln_dia_pyc_scl ) THEN + z3ddz_pyc_1(ji,jj,jk) = zdtdz_pyc + z3ddz_pyc_2(ji,jj,jk) = zdsdz_pyc + END IF + END IF + ELSE ! Slightly stable - 'thin' pycnoline - needed when stable layer begins to form. + ztmp = 1.0_wp / MAX( pdh(ji,jj), epsln ) + ztgrad = av_dt_bl(ji,jj) * ztmp + zsgrad = av_ds_bl(ji,jj) * ztmp + zbgrad = av_db_bl(ji,jj) * ztmp + IF ( jk <= nbld(ji,jj) ) THEN + znd = -1.0_wp * ( gdepw(ji,jj,jk,Kmm) - phml(ji,jj) ) * ztmp + zdtdz_pyc = ztgrad * EXP( -1.75_wp * ( znd + 0.75_wp )**2 ) + zdsdz_pyc = zsgrad * EXP( -1.75_wp * ( znd + 0.75_wp )**2 ) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + pdiffut(ji,jj,jk) * zdtdz_pyc + ghams(ji,jj,jk) = ghams(ji,jj,jk) + pdiffut(ji,jj,jk) * zdsdz_pyc + IF ( ln_dia_pyc_scl ) THEN + z3ddz_pyc_1(ji,jj,jk) = zdtdz_pyc + z3ddz_pyc_2(ji,jj,jk) = zdsdz_pyc + END IF + END IF + ENDIF ! IF (shol >=0.5) + ENDIF ! IF (av_db_bl> 0.) + ENDIF ! IF (zdhdt >= 0) zdhdt < 0 not considered since pycnocline profile is zero and profile arrays are + ! ! intialized to zero + END IF + END IF + END_3D + IF ( ln_dia_pyc_scl ) THEN ! Output of pycnocline gradient profiles + CALL zdf_osm_iomput( "zdtdz_pyc", wmask(A2D(0),:) * z3ddz_pyc_1(A2D(0),:) ) + CALL zdf_osm_iomput( "zdsdz_pyc", wmask(A2D(0),:) * z3ddz_pyc_2(A2D(0),:) ) + END IF + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jkm_bld ) + IF ( .NOT. l_conv (ji,jj) ) THEN + IF ( nbld(ji,jj) + kp_ext(ji,jj) < mbkt(ji,jj) ) THEN + zugrad = 3.25_wp * av_du_bl(ji,jj) / phbl(ji,jj) + zvgrad = 2.75_wp * av_dv_bl(ji,jj) / phbl(ji,jj) + IF ( jk <= nbld(ji,jj) ) THEN + znd = gdepw(ji,jj,jk,Kmm) / phbl(ji,jj) + IF ( znd < 1.0 ) THEN + zdudz_pyc = zugrad * EXP( -40.0_wp * ( znd - 1.0_wp )**2 ) + ELSE + zdudz_pyc = zugrad * EXP( -20.0_wp * ( znd - 1.0_wp )**2 ) + ENDIF + zdvdz_pyc = zvgrad * EXP( -20.0_wp * ( znd - 0.85_wp )**2 ) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + pviscos(ji,jj,jk) * zdudz_pyc + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + pviscos(ji,jj,jk) * zdvdz_pyc + IF ( ln_dia_pyc_shr ) THEN + z3ddz_pyc_1(ji,jj,jk) = zdudz_pyc + z3ddz_pyc_2(ji,jj,jk) = zdvdz_pyc + END IF + END IF + END IF + END IF + END_3D + IF ( ln_dia_pyc_shr ) THEN ! Output of pycnocline shear profiles + CALL zdf_osm_iomput( "zdudz_pyc", wmask(A2D(0),:) * z3ddz_pyc_1(A2D(0),:) ) + CALL zdf_osm_iomput( "zdvdz_pyc", wmask(A2D(0),:) * z3ddz_pyc_2(A2D(0),:) ) + END IF + IF ( ln_dia_osm ) THEN + CALL zdf_osm_iomput( "ghamu_b", wmask(A2D(0),:) * ghamu(A2D(0),:) ) + CALL zdf_osm_iomput( "ghamv_b", wmask(A2D(0),:) * ghamv(A2D(0),:) ) + END IF + IF ( ln_dia_pyc_scl .OR. ln_dia_pyc_shr ) THEN ! Deallocate arrays used for output of pycnocline gradient/shear profiles + DEALLOCATE( z3ddz_pyc_1, z3ddz_pyc_2 ) + END IF + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ghamt(ji,jj,nbld(ji,jj)) = 0.0_wp + ghams(ji,jj,nbld(ji,jj)) = 0.0_wp + ghamu(ji,jj,nbld(ji,jj)) = 0.0_wp + ghamv(ji,jj,nbld(ji,jj)) = 0.0_wp + END_2D + ! + IF ( ln_dia_osm ) THEN + CALL zdf_osm_iomput( "ghamu_1", wmask(A2D(0),:) * ghamu(A2D(0),:) ) + CALL zdf_osm_iomput( "ghamv_1", wmask(A2D(0),:) * ghamv(A2D(0),:) ) + CALL zdf_osm_iomput( "zviscos", wmask(A2D(0),:) * pviscos(A2D(0),:) ) + END IF + ! + END SUBROUTINE zdf_osm_fgr_terms + + SUBROUTINE zdf_osm_zmld_horizontal_gradients( Kmm, pmld, pdtdx, pdtdy, pdsdx, & + & pdsdy, pdbds_mle ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_zmld_horizontal_gradients *** + !! + !! ** Purpose : Calculates horizontal gradients of buoyancy for use with + !! Fox-Kemper parametrization + !! + !! ** Method : + !! + !! References: Fox-Kemper et al., JPO, 38, 1145-1165, 2008 + !! Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Time-level index + REAL(wp), DIMENSION(A2D(nn_hls)), INTENT( out) :: pmld ! == Estimated FK BLD used for MLE horizontal gradients == ! + REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdtdx ! Horizontal gradient for Fox-Kemper parametrization + REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdtdy ! Horizontal gradient for Fox-Kemper parametrization + REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdsdx ! Horizontal gradient for Fox-Kemper parametrization + REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(inout) :: pdsdy ! Horizontal gradient for Fox-Kemper parametrization + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient + !! + INTEGER :: ji, jj, jk ! Dummy loop indices + INTEGER, DIMENSION(A2D(nn_hls)) :: jk_mld_prof ! Base level of MLE layer + INTEGER :: ikt, ikmax ! Local integers + REAL(wp) :: zc + REAL(wp) :: zN2_c ! Local buoyancy difference from 10m value + REAL(wp), DIMENSION(A2D(nn_hls)) :: ztm + REAL(wp), DIMENSION(A2D(nn_hls)) :: zsm + REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: ztsm_midu + REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: ztsm_midv + REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zabu + REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zabv + REAL(wp), DIMENSION(A2D(nn_hls)) :: zmld_midu + REAL(wp), DIMENSION(A2D(nn_hls)) :: zmld_midv + !!---------------------------------------------------------------------- + ! + ! == MLD used for MLE ==! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + jk_mld_prof(ji,jj) = nlb10 ! Initialization to the number of w ocean point + pmld(ji,jj) = 0.0_wp ! Here hmlp used as a dummy variable, integrating vertically N^2 + END_2D + zN2_c = grav * rn_osm_mle_rho_c * r1_rho0 ! Convert density criteria into N^2 criteria + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, nlb10, jpkm1 ) + ikt = mbkt(ji,jj) + pmld(ji,jj) = pmld(ji,jj) + MAX( rn2b(ji,jj,jk), 0.0_wp ) * e3w(ji,jj,jk,Kmm) + IF( pmld(ji,jj) < zN2_c ) jk_mld_prof(ji,jj) = MIN( jk , ikt ) + 1 ! Mixed layer level + END_3D + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + jk_mld_prof(ji,jj) = MAX( jk_mld_prof(ji,jj), nbld(ji,jj) ) ! Ensure jk_mld_prof .ge. nbld + pmld(ji,jj) = gdepw(ji,jj,jk_mld_prof(ji,jj),Kmm) + END_2D + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + mld_prof(ji,jj) = jk_mld_prof(ji,jj) + END_2D + ! + ikmax = MIN( MAXVAL( jk_mld_prof(A2D(nn_hls)) ), jpkm1 ) ! Max level of the computation + ztm(:,:) = 0.0_wp + zsm(:,:) = 0.0_wp + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, ikmax ) + zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, jk_mld_prof(ji,jj) - jk ), 1 ), KIND=wp ) ! zc being 0 outside the ML + ! ! t-points + ztm(ji,jj) = ztm(ji,jj) + zc * ts(ji,jj,jk,jp_tem,Kmm) + zsm(ji,jj) = zsm(ji,jj) + zc * ts(ji,jj,jk,jp_sal,Kmm) + END_3D + ! Average temperature and salinity + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + ztm(ji,jj) = ztm(ji,jj) / MAX( e3t(ji,jj,1,Kmm), pmld(ji,jj) ) + zsm(ji,jj) = zsm(ji,jj) / MAX( e3t(ji,jj,1,Kmm), pmld(ji,jj) ) + END_2D + ! Calculate horizontal gradients at u & v points + zmld_midu(:,:) = 0.0_wp + ztsm_midu(:,:,:) = 10.0_wp + DO_2D( nn_hls, nn_hls-1, nn_hls-1, nn_hls-1 ) + pdtdx(ji,jj) = ( ztm(ji+1,jj) - ztm(ji,jj) ) * umask(ji,jj,1) / e1u(ji,jj) + pdsdx(ji,jj) = ( zsm(ji+1,jj) - zsm(ji,jj) ) * umask(ji,jj,1) / e1u(ji,jj) + zmld_midu(ji,jj) = 0.25_wp * ( pmld(ji+1,jj) + pmld(ji,jj)) + ztsm_midu(ji,jj,jp_tem) = 0.5_wp * ( ztm( ji+1,jj) + ztm( ji,jj) ) + ztsm_midu(ji,jj,jp_sal) = 0.5_wp * ( zsm( ji+1,jj) + zsm( ji,jj) ) + END_2D + zmld_midv(:,:) = 0.0_wp + ztsm_midv(:,:,:) = 10.0_wp + DO_2D( nn_hls-1, nn_hls-1, nn_hls, nn_hls-1 ) + pdtdy(ji,jj) = ( ztm(ji,jj+1) - ztm(ji,jj) ) * vmask(ji,jj,1) / e1v(ji,jj) + pdsdy(ji,jj) = ( zsm(ji,jj+1) - zsm(ji,jj) ) * vmask(ji,jj,1) / e1v(ji,jj) + zmld_midv(ji,jj) = 0.25_wp * ( pmld(ji,jj+1) + pmld( ji,jj) ) + ztsm_midv(ji,jj,jp_tem) = 0.5_wp * ( ztm( ji,jj+1) + ztm( ji,jj) ) + ztsm_midv(ji,jj,jp_sal) = 0.5_wp * ( zsm( ji,jj+1) + zsm( ji,jj) ) + END_2D + CALL eos_rab( ztsm_midu, zmld_midu, zabu, Kmm ) + CALL eos_rab( ztsm_midv, zmld_midv, zabv, Kmm ) + DO_2D_OVR( nn_hls, nn_hls-1, nn_hls-1, nn_hls-1 ) + dbdx_mle(ji,jj) = grav * ( pdtdx(ji,jj) * zabu(ji,jj,jp_tem) - pdsdx(ji,jj) * zabu(ji,jj,jp_sal) ) + END_2D + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls, nn_hls-1 ) + dbdy_mle(ji,jj) = grav * ( pdtdy(ji,jj) * zabv(ji,jj,jp_tem) - pdsdy(ji,jj) * zabv(ji,jj,jp_sal) ) + END_2D + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + pdbds_mle(ji,jj) = SQRT( 0.5_wp * ( dbdx_mle(ji, jj) * dbdx_mle(ji, jj) + dbdy_mle(ji,jj ) * dbdy_mle(ji,jj ) + & + & dbdx_mle(ji-1,jj) * dbdx_mle(ji-1,jj) + dbdy_mle(ji,jj-1) * dbdy_mle(ji,jj-1) ) ) + END_2D + ! + END SUBROUTINE zdf_osm_zmld_horizontal_gradients + + SUBROUTINE zdf_osm_osbl_state_fk( Kmm, pwb_fk, phbl, phmle, pwb_ent, & + & pdbds_mle ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_osbl_state_fk *** + !! + !! ** Purpose : Determines the state of the OSBL and MLE layer. Info is + !! returned in the logicals l_pyc, l_flux and ldmle. Used + !! with Fox-Kemper scheme. + !! l_pyc :: determines whether pycnocline flux-grad + !! relationship needs to be determined + !! l_flux :: determines whether effects of surface flux + !! extend below the base of the OSBL + !! ldmle :: determines whether the layer with MLE is + !! increasing with time or if base is relaxing + !! towards hbl + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Time-level index + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pwb_fk + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phmle ! MLE depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient + !! + INTEGER :: ji, jj, jk ! Dummy loop indices + REAL(wp), DIMENSION(A2D(nn_hls-1)) :: znd_param + REAL(wp) :: zthermal, zbeta + REAL(wp) :: zbuoy + REAL(wp) :: ztmp + REAL(wp) :: zpe_mle_layer + REAL(wp) :: zpe_mle_ref + REAL(wp) :: zdbdz_mle_int + !!---------------------------------------------------------------------- + ! + znd_param(:,:) = 0.0_wp + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ztmp = r1_ft(ji,jj) * MIN( 111.e3_wp , e1u(ji,jj) ) / rn_osm_mle_lf + pwb_fk(ji,jj) = rn_osm_mle_ce * hmle(ji,jj) * hmle(ji,jj) * ztmp * pdbds_mle(ji,jj) * pdbds_mle(ji,jj) + END_2D + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! + IF ( l_conv(ji,jj) ) THEN + IF ( phmle(ji,jj) > 1.2_wp * phbl(ji,jj) ) THEN + av_t_mle(ji,jj) = ( av_t_mle(ji,jj) * phmle(ji,jj) - av_t_bl(ji,jj) * phbl(ji,jj) ) / ( phmle(ji,jj) - phbl(ji,jj) ) + av_s_mle(ji,jj) = ( av_s_mle(ji,jj) * phmle(ji,jj) - av_s_bl(ji,jj) * phbl(ji,jj) ) / ( phmle(ji,jj) - phbl(ji,jj) ) + av_b_mle(ji,jj) = ( av_b_mle(ji,jj) * phmle(ji,jj) - av_b_bl(ji,jj) * phbl(ji,jj) ) / ( phmle(ji,jj) - phbl(ji,jj) ) + zdbdz_mle_int = ( av_b_bl(ji,jj) - ( 2.0_wp * av_b_mle(ji,jj) - av_b_bl(ji,jj) ) ) / ( phmle(ji,jj) - phbl(ji,jj) ) + ! Calculate potential energies of actual profile and reference profile + zpe_mle_layer = 0.0_wp + zpe_mle_ref = 0.0_wp + zthermal = rab_n(ji,jj,1,jp_tem) + zbeta = rab_n(ji,jj,1,jp_sal) + DO jk = nbld(ji,jj), mld_prof(ji,jj) + zbuoy = grav * ( zthermal * ts(ji,jj,jk,jp_tem,Kmm) - zbeta * ts(ji,jj,jk,jp_sal,Kmm) ) + zpe_mle_layer = zpe_mle_layer + zbuoy * gdepw(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) + zpe_mle_ref = zpe_mle_ref + ( av_b_bl(ji,jj) - zdbdz_mle_int * ( gdepw(ji,jj,jk,Kmm) - phbl(ji,jj) ) ) * & + & gdepw(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) + END DO + ! Non-dimensional parameter to diagnose the presence of thermocline + znd_param(ji,jj) = ( zpe_mle_layer - zpe_mle_ref ) * ABS( ff_t(ji,jj) ) / & + & ( MAX( pwb_fk(ji,jj), 1e-10 ) * phmle(ji,jj) ) + END IF + END IF + ! + END_2D + ! + ! Diagnosis + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ! + IF ( l_conv(ji,jj) ) THEN + IF ( -2.0_wp * pwb_fk(ji,jj) / pwb_ent(ji,jj) > 0.5_wp ) THEN + IF ( phmle(ji,jj) > 1.2_wp * phbl(ji,jj) ) THEN ! MLE layer growing + IF ( znd_param (ji,jj) > 100.0_wp ) THEN ! Thermocline present + l_flux(ji,jj) = .FALSE. + l_mle(ji,jj) = .FALSE. + ELSE ! Thermocline not present + l_flux(ji,jj) = .TRUE. + l_mle(ji,jj) = .TRUE. + ENDIF ! znd_param > 100 + ! + IF ( av_db_bl(ji,jj) < rn_osm_bl_thresh ) THEN + l_pyc(ji,jj) = .FALSE. + ELSE + l_pyc(ji,jj) = .TRUE. + ENDIF + ELSE ! MLE layer restricted to OSBL or just below + IF ( av_db_bl(ji,jj) < rn_osm_bl_thresh ) THEN ! Weak stratification MLE layer can grow + l_pyc(ji,jj) = .FALSE. + l_flux(ji,jj) = .TRUE. + l_mle(ji,jj) = .TRUE. + ELSE ! Strong stratification + l_pyc(ji,jj) = .TRUE. + l_flux(ji,jj) = .FALSE. + l_mle(ji,jj) = .FALSE. + END IF ! av_db_bl < rn_mle_thresh_bl and + END IF ! phmle > 1.2 phbl + ELSE + l_pyc(ji,jj) = .TRUE. + l_flux(ji,jj) = .FALSE. + l_mle(ji,jj) = .FALSE. + IF ( av_db_bl(ji,jj) < rn_osm_bl_thresh ) l_pyc(ji,jj) = .FALSE. + END IF ! -2.0 * pwb_fk(ji,jj) / pwb_ent > 0.5 + ELSE ! Stable Boundary Layer + l_pyc(ji,jj) = .FALSE. + l_flux(ji,jj) = .FALSE. + l_mle(ji,jj) = .FALSE. + END IF ! l_conv + ! + END_2D + ! + END SUBROUTINE zdf_osm_osbl_state_fk + + SUBROUTINE zdf_osm_mle_parameters( Kmm, pmld, phmle, pvel_mle, pdiff_mle, & + & pdbds_mle, phbl, pwb0tot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_mle_parameters *** + !! + !! ** Purpose : Timesteps the mixed layer eddy depth, hmle and calculates + !! the mixed layer eddy fluxes for buoyancy, heat and + !! salinity. + !! + !! ** Method : + !! + !! References: Fox-Kemper et al., JPO, 38, 1145-1165, 2008 + !! Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Time-level index + REAL(wp), DIMENSION(A2D(nn_hls)), INTENT(in ) :: pmld ! == Estimated FK BLD used for MLE horiz gradients == ! + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: phmle ! MLE depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pvel_mle ! Velocity scale for dhdt with stable ML and FK + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(inout) :: pdiff_mle ! Extra MLE vertical diff + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pdbds_mle ! Magnitude of horizontal buoyancy gradient + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: phbl ! BL depth + REAL(wp), DIMENSION(A2D(nn_hls-1)), INTENT(in ) :: pwb0tot ! Total surface buoyancy flux including insolation + !! + INTEGER :: ji, jj, jk ! Dummy loop indices + REAL(wp) :: ztmp + REAL(wp) :: zdbdz + REAL(wp) :: zdtdz + REAL(wp) :: zdsdz + REAL(wp) :: zthermal + REAL(wp) :: zbeta + REAL(wp) :: zbuoy + REAL(wp) :: zdb_mle + !!---------------------------------------------------------------------- + ! + ! Calculate vertical buoyancy, heat and salinity fluxes due to MLE + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( l_conv(ji,jj) ) THEN + ztmp = r1_ft(ji,jj) * MIN( 111e3_wp, e1u(ji,jj) ) / rn_osm_mle_lf + ! This velocity scale, defined in Fox-Kemper et al (2008), is needed for calculating dhdt + pvel_mle(ji,jj) = pdbds_mle(ji,jj) * ztmp * hmle(ji,jj) * tmask(ji,jj,1) + pdiff_mle(ji,jj) = 5e-4_wp * rn_osm_mle_ce * ztmp * pdbds_mle(ji,jj) * phmle(ji,jj)**2 + END IF + END_2D + ! Timestep mixed layer eddy depth + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( l_mle(ji,jj) ) THEN ! MLE layer growing + ! Buoyancy gradient at base of MLE layer + zthermal = rab_n(ji,jj,1,jp_tem) + zbeta = rab_n(ji,jj,1,jp_sal) + zbuoy = grav * ( zthermal * ts(ji,jj,mld_prof(ji,jj)+2,jp_tem,Kmm) - & + & zbeta * ts(ji,jj,mld_prof(ji,jj)+2,jp_sal,Kmm) ) + zdb_mle = av_b_bl(ji,jj) - zbuoy + ! Timestep hmle + hmle(ji,jj) = hmle(ji,jj) + pwb0tot(ji,jj) * rn_Dt / zdb_mle + ELSE + IF ( phmle(ji,jj) > phbl(ji,jj) ) THEN + hmle(ji,jj) = hmle(ji,jj) - ( hmle(ji,jj) - hbl(ji,jj) ) * rn_Dt / rn_osm_mle_tau + ELSE + hmle(ji,jj) = hmle(ji,jj) - 10.0_wp * ( hmle(ji,jj) - hbl(ji,jj) ) * rn_Dt / rn_osm_mle_tau + END IF + END IF + hmle(ji,jj) = MAX( MIN( hmle(ji,jj), ht(ji,jj) ), gdepw(ji,jj,4,Kmm) ) + IF ( ln_osm_hmle_limit ) hmle(ji,jj) = MIN( hmle(ji,jj), rn_osm_hmle_limit*hbl(ji,jj) ) + hmle(ji,jj) = pmld(ji,jj) ! For now try just set hmle to pmld + END_2D + ! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 5, jpkm1 ) + IF ( hmle(ji,jj) >= gdepw(ji,jj,jk,Kmm) ) mld_prof(ji,jj) = MIN( mbkt(ji,jj), jk ) + END_3D + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + phmle(ji,jj) = gdepw(ji,jj,mld_prof(ji,jj),Kmm) + END_2D + ! + END SUBROUTINE zdf_osm_mle_parameters + + SUBROUTINE zdf_osm_init( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_init *** + !! + !! ** Purpose : Initialization of the vertical eddy diffivity and + !! viscosity when using a osm turbulent closure scheme + !! + !! ** Method : Read the namosm namelist and check the parameters + !! called at the first timestep (nit000) + !! + !! ** input : Namlists namzdf_osm and namosm_mle + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: Kmm ! Time level + !! + INTEGER :: ios ! Local integer + INTEGER :: ji, jj, jk ! Dummy loop indices + REAL(wp) :: z1_t2 + !! + REAL(wp), PARAMETER :: pp_large = -1e10_wp + !! + NAMELIST/namzdf_osm/ ln_use_osm_la, rn_osm_la, rn_osm_dstokes, nn_ave, nn_osm_wave, & + & ln_dia_osm, rn_osm_hbl0, rn_zdfosm_adjust_sd, ln_kpprimix, rn_riinfty, & + & rn_difri, ln_convmix, rn_difconv, nn_osm_wave, nn_osm_SD_reduce, & + & ln_osm_mle, rn_osm_hblfrac, rn_osm_bl_thresh, ln_zdfosm_ice_shelter + !! Namelist for Fox-Kemper parametrization + NAMELIST/namosm_mle/ nn_osm_mle, rn_osm_mle_ce, rn_osm_mle_lf, rn_osm_mle_time, rn_osm_mle_lat, & + & rn_osm_mle_rho_c, rn_osm_mle_thresh, rn_osm_mle_tau, ln_osm_hmle_limit, rn_osm_hmle_limit + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namzdf_osm, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_osm in reference namelist' ) + + READ ( numnam_cfg, namzdf_osm, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_osm in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf_osm ) + + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_osm_init : OSMOSIS Parameterisation' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namzdf_osm : set osm mixing parameters' + WRITE(numout,*) ' Use rn_osm_la ln_use_osm_la = ', ln_use_osm_la + WRITE(numout,*) ' Use MLE in OBL, i.e. Fox-Kemper param ln_osm_mle = ', ln_osm_mle + WRITE(numout,*) ' Turbulent Langmuir number rn_osm_la = ', rn_osm_la + WRITE(numout,*) ' Stokes drift reduction factor rn_zdfosm_adjust_sd = ', rn_zdfosm_adjust_sd + WRITE(numout,*) ' Initial hbl for 1D runs rn_osm_hbl0 = ', rn_osm_hbl0 + WRITE(numout,*) ' Depth scale of Stokes drift rn_osm_dstokes = ', rn_osm_dstokes + WRITE(numout,*) ' Horizontal average flag nn_ave = ', nn_ave + WRITE(numout,*) ' Stokes drift nn_osm_wave = ', nn_osm_wave + SELECT CASE (nn_osm_wave) + CASE(0) + WRITE(numout,*) ' Calculated assuming constant La#=0.3' + CASE(1) + WRITE(numout,*) ' Calculated from Pierson Moskowitz wind-waves' + CASE(2) + WRITE(numout,*) ' Calculated from ECMWF wave fields' + END SELECT + WRITE(numout,*) ' Stokes drift reduction nn_osm_SD_reduce = ', nn_osm_SD_reduce + WRITE(numout,*) ' Fraction of hbl to average SD over/fit' + WRITE(numout,*) ' Exponential with nn_osm_SD_reduce = 1 or 2 rn_osm_hblfrac = ', rn_osm_hblfrac + SELECT CASE (nn_osm_SD_reduce) + CASE(0) + WRITE(numout,*) ' No reduction' + CASE(1) + WRITE(numout,*) ' Average SD over upper rn_osm_hblfrac of BL' + CASE(2) + WRITE(numout,*) ' Fit exponential to slope rn_osm_hblfrac of BL' + END SELECT + WRITE(numout,*) ' Reduce surface SD and depth scale under ice ln_zdfosm_ice_shelter = ', ln_zdfosm_ice_shelter + WRITE(numout,*) ' Output osm diagnostics ln_dia_osm = ', ln_dia_osm + WRITE(numout,*) ' Threshold used to define BL rn_osm_bl_thresh = ', rn_osm_bl_thresh, & + & 'm^2/s' + WRITE(numout,*) ' Use KPP-style shear instability mixing ln_kpprimix = ', ln_kpprimix + WRITE(numout,*) ' Local Richardson Number limit for shear instability rn_riinfty = ', rn_riinfty + WRITE(numout,*) ' Maximum shear diffusivity at Rig = 0 (m2/s) rn_difri = ', rn_difri + WRITE(numout,*) ' Use large mixing below BL when unstable ln_convmix = ', ln_convmix + WRITE(numout,*) ' Diffusivity when unstable below BL (m2/s) rn_difconv = ', rn_difconv + ENDIF + ! + ! ! Check wave coupling settings ! + ! ! Further work needed - see ticket #2447 ! + IF ( nn_osm_wave == 2 ) THEN + IF (.NOT. ( ln_wave .AND. ln_sdw )) & + & CALL ctl_stop( 'zdf_osm_init : ln_zdfosm and nn_osm_wave=2, ln_wave and ln_sdw must be true' ) + END IF + ! + ! Flags associated with diagnostic output + IF ( ln_dia_osm .AND. ( iom_use("zdudz_pyc") .OR. iom_use("zdvdz_pyc") ) ) ln_dia_pyc_shr = .TRUE. + IF ( ln_dia_osm .AND. ( iom_use("zdtdz_pyc") .OR. iom_use("zdsdz_pyc") .OR. iom_use("zdbdz_pyc" ) ) ) ln_dia_pyc_scl = .TRUE. + ! + ! Allocate zdfosm arrays + IF( zdf_osm_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_osm_init : unable to allocate arrays' ) + ! + IF( ln_osm_mle ) THEN ! Initialise Fox-Kemper parametrization + READ ( numnam_ref, namosm_mle, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam( ios, 'namosm_mle in reference namelist' ) + READ ( numnam_cfg, namosm_mle, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam( ios, 'namosm_mle in configuration namelist' ) + IF(lwm) WRITE ( numond, namosm_mle ) + ! + IF(lwp) THEN ! Namelist print + WRITE(numout,*) + WRITE(numout,*) 'zdf_osm_init : initialise mixed layer eddy (MLE)' + WRITE(numout,*) '~~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namosm_mle : ' + WRITE(numout,*) ' MLE type: =0 standard Fox-Kemper ; =1 new formulation nn_osm_mle = ', nn_osm_mle + WRITE(numout,*) ' Magnitude of the MLE (typical value: 0.06 to 0.08) rn_osm_mle_ce = ', rn_osm_mle_ce + WRITE(numout,*) ' Scale of ML front (ML radius of deform.) (nn_osm_mle=0) rn_osm_mle_lf = ', rn_osm_mle_lf, & + & 'm' + WRITE(numout,*) ' Maximum time scale of MLE (nn_osm_mle=0) rn_osm_mle_time = ', & + & rn_osm_mle_time, 's' + WRITE(numout,*) ' Reference latitude (deg) of MLE coef. (nn_osm_mle=1) rn_osm_mle_lat = ', rn_osm_mle_lat, & + & 'deg' + WRITE(numout,*) ' Density difference used to define ML for FK rn_osm_mle_rho_c = ', rn_osm_mle_rho_c + WRITE(numout,*) ' Threshold used to define MLE for FK rn_osm_mle_thresh = ', & + & rn_osm_mle_thresh, 'm^2/s' + WRITE(numout,*) ' Timescale for OSM-FK rn_osm_mle_tau = ', rn_osm_mle_tau, 's' + WRITE(numout,*) ' Switch to limit hmle ln_osm_hmle_limit = ', ln_osm_hmle_limit + WRITE(numout,*) ' hmle limit (fraction of zmld) (ln_osm_hmle_limit = .T.) rn_osm_hmle_limit = ', rn_osm_hmle_limit + END IF + END IF + ! + IF(lwp) THEN + WRITE(numout,*) + IF ( ln_osm_mle ) THEN + WRITE(numout,*) ' ==>>> Mixed Layer Eddy induced transport added to OSMOSIS BL calculation' + IF( nn_osm_mle == 0 ) WRITE(numout,*) ' Fox-Kemper et al 2010 formulation' + IF( nn_osm_mle == 1 ) WRITE(numout,*) ' New formulation' + ELSE + WRITE(numout,*) ' ==>>> Mixed Layer induced transport NOT added to OSMOSIS BL calculation' + END IF + END IF + ! + IF( ln_osm_mle ) THEN ! MLE initialisation + ! + rb_c = grav * rn_osm_mle_rho_c / rho0 ! Mixed Layer buoyancy criteria + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ML buoyancy criteria = ', rb_c, ' m/s2 ' + IF(lwp) WRITE(numout,*) ' associated ML density criteria defined in zdfmxl = ', rn_osm_mle_rho_c, 'kg/m3' + ! + IF( nn_osm_mle == 1 ) THEN + rc_f = rn_osm_mle_ce / ( 5e3_wp * 2.0_wp * omega * SIN( rad * rn_osm_mle_lat ) ) + END IF + ! 1/(f^2+tau^2)^1/2 at t-point (needed in both nn_osm_mle case) + z1_t2 = 2e-5_wp + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + r1_ft(ji,jj) = MIN( 1.0_wp / ( ABS( ff_t(ji,jj)) + epsln ), ABS( ff_t(ji,jj) ) / z1_t2**2 ) + END_2D + ! z1_t2 = 1._wp / ( rn_osm_mle_time * rn_osm_mle_timeji,jj ) + ! r1_ft(:,:) = 1._wp / SQRT( ff_t(:,:) * ff_t(:,:) + z1_t2 ) + ! + END IF + ! + CALL osm_rst( nit000, Kmm, 'READ' ) ! Read or initialize hbl, dh, hmle + ! + IF ( ln_zdfddm ) THEN + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Double diffusion mixing on temperature and salinity ' + WRITE(numout,*) ' CAUTION : done in routine zdfosm, not in routine zdfddm ' + END IF + END IF + ! + ! Set constants not in namelist + ! ----------------------------- + IF(lwp) THEN + WRITE(numout,*) + END IF + ! + dstokes(:,:) = pp_large + IF (nn_osm_wave == 0) THEN + dstokes(:,:) = rn_osm_dstokes + END IF + ! + ! Horizontal average : initialization of weighting arrays + ! ------------------- + SELECT CASE ( nn_ave ) + CASE ( 0 ) ! no horizontal average + IF(lwp) WRITE(numout,*) ' no horizontal average on avt' + IF(lwp) WRITE(numout,*) ' only in very high horizontal resolution !' + ! Weighting mean arrays etmean + ! ( 1 1 ) + ! avt = 1/4 ( 1 1 ) + ! + etmean(:,:,:) = 0.0_wp + ! + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + etmean(ji,jj,jk) = tmask(ji,jj,jk) / MAX( 1.0_wp, umask(ji-1,jj, jk) + umask(ji,jj,jk) + & + & vmask(ji, jj-1,jk) + vmask(ji,jj,jk) ) + END_3D + CASE ( 1 ) ! horizontal average + IF(lwp) WRITE(numout,*) ' horizontal average on avt' + ! Weighting mean arrays etmean + ! ( 1/2 1 1/2 ) + ! avt = 1/8 ( 1 2 1 ) + ! ( 1/2 1 1/2 ) + etmean(:,:,:) = 0.0_wp + ! + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + etmean(ji,jj,jk) = tmask(ji, jj,jk) / MAX( 1.0_wp, 2.0_wp * tmask(ji,jj,jk) + & + & 0.5_wp * ( tmask(ji-1,jj+1,jk) + tmask(ji-1,jj-1,jk) + & + & tmask(ji+1,jj+1,jk) + tmask(ji+1,jj-1,jk) ) + & + & 1.0_wp * ( tmask(ji-1,jj, jk) + tmask(ji, jj+1,jk) + & + & tmask(ji, jj-1,jk) + tmask(ji+1,jj, jk) ) ) + END_3D + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for nn_ave = ', nn_ave + CALL ctl_stop( ctmp1 ) + END SELECT + ! + ! Initialization of vertical eddy coef. to the background value + ! ------------------------------------------------------------- + DO jk = 1, jpk + avt(:,:,jk) = avtb(jk) * tmask(:,:,jk) + END DO + ! + ! Zero the surface flux for non local term and osm mixed layer depth + ! ------------------------------------------------------------------ + ghamt(:,:,:) = 0.0_wp + ghams(:,:,:) = 0.0_wp + ghamu(:,:,:) = 0.0_wp + ghamv(:,:,:) = 0.0_wp + ! + IF ( ln_dia_osm ) THEN ! Initialise auxiliary arrays for diagnostic output + osmdia2d(:,:) = 0.0_wp + osmdia3d(:,:,:) = 0.0_wp + END IF + ! + END SUBROUTINE zdf_osm_init + + SUBROUTINE osm_rst( kt, Kmm, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE osm_rst *** + !! + !! ** Purpose : Read or write BL fields in restart file + !! + !! ** Method : use of IOM library. If the restart does not contain + !! required fields, they are recomputed from stratification + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! Ocean time step index + INTEGER , INTENT(in ) :: Kmm ! Ocean time level index (middle) + CHARACTER(len=*), INTENT(in ) :: cdrw ! "READ"/"WRITE" flag + !! + INTEGER :: id1, id2, id3 ! iom enquiry index + INTEGER :: ji, jj, jk ! Dummy loop indices + INTEGER :: iiki, ikt ! Local integer + REAL(wp) :: zhbf ! Tempory scalars + REAL(wp) :: zN2_c ! Local scalar + REAL(wp) :: rho_c = 0.01_wp ! Density criterion for mixed layer depth + INTEGER, DIMENSION(jpi,jpj) :: imld_rst ! Level of mixed-layer depth (pycnocline top) + !!---------------------------------------------------------------------- + ! + !!----------------------------------------------------------------------------- + ! If READ/WRITE Flag is 'READ', try to get hbl from restart file. If successful then return + !!----------------------------------------------------------------------------- + IF( TRIM(cdrw) == 'READ' .AND. ln_rstart) THEN + id1 = iom_varid( numror, 'wn', ldstop = .FALSE. ) + IF( id1 > 0 ) THEN ! 'wn' exists; read + CALL iom_get( numror, jpdom_auto, 'wn', ww ) + WRITE(numout,*) ' ===>>>> : wn read from restart file' + ELSE + ww(:,:,:) = 0.0_wp + WRITE(numout,*) ' ===>>>> : wn not in restart file, set to zero initially' + END IF + ! + id1 = iom_varid( numror, 'hbl', ldstop = .FALSE. ) + id2 = iom_varid( numror, 'dh', ldstop = .FALSE. ) + IF( id1 > 0 .AND. id2 > 0 ) THEN ! 'hbl' exists; read and return + CALL iom_get( numror, jpdom_auto, 'hbl', hbl ) + CALL iom_get( numror, jpdom_auto, 'dh', dh ) + hml(:,:) = hbl(:,:) - dh(:,:) ! Initialise ML depth + WRITE(numout,*) ' ===>>>> : hbl & dh read from restart file' + IF( ln_osm_mle ) THEN + id3 = iom_varid( numror, 'hmle', ldstop = .FALSE. ) + IF( id3 > 0 ) THEN + CALL iom_get( numror, jpdom_auto, 'hmle', hmle ) + WRITE(numout,*) ' ===>>>> : hmle read from restart file' + ELSE + WRITE(numout,*) ' ===>>>> : hmle not found, set to hbl' + hmle(:,:) = hbl(:,:) ! Initialise MLE depth + END IF + END IF + RETURN + ELSE ! 'hbl' & 'dh' not in restart file, recalculate + WRITE(numout,*) ' ===>>>> : previous run without osmosis scheme, hbl computed from stratification' + END IF + END IF + ! + !!----------------------------------------------------------------------------- + ! If READ/WRITE Flag is 'WRITE', write hbl into the restart file, then return + !!----------------------------------------------------------------------------- + IF ( TRIM(cdrw) == 'WRITE' ) THEN + IF(lwp) WRITE(numout,*) '---- osm-rst ----' + CALL iom_rstput( kt, nitrst, numrow, 'wn', ww ) + CALL iom_rstput( kt, nitrst, numrow, 'hbl', hbl ) + CALL iom_rstput( kt, nitrst, numrow, 'dh', dh ) + IF ( ln_osm_mle ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'hmle', hmle ) + END IF + RETURN + END IF + ! + !!----------------------------------------------------------------------------- + ! Getting hbl, no restart file with hbl, so calculate from surface stratification + !!----------------------------------------------------------------------------- + IF( lwp ) WRITE(numout,*) ' ===>>>> : calculating hbl computed from stratification' + ! w-level of the mixing and mixed layers + CALL eos_rab( ts(:,:,:,:,Kmm), rab_n, Kmm ) + CALL bn2( ts(:,:,:,:,Kmm), rab_n, rn2, Kmm ) + imld_rst(:,:) = nlb10 ! Initialization to the number of w ocean point + hbl(:,:) = 0.0_wp ! Here hbl used as a dummy variable, integrating vertically N^2 + zN2_c = grav * rho_c * r1_rho0 ! Convert density criteria into N^2 criteria + ! + hbl(:,:) = 0.0_wp ! Here hbl used as a dummy variable, integrating vertically N^2 + DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) + ikt = mbkt(ji,jj) + hbl(ji,jj) = hbl(ji,jj) + MAX( rn2(ji,jj,jk) , 0.0_wp ) * e3w(ji,jj,jk,Kmm) + IF ( hbl(ji,jj) < zN2_c ) imld_rst(ji,jj) = MIN( jk , ikt ) + 1 ! Mixed layer level + END_3D + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + iiki = MAX( 4, imld_rst(ji,jj) ) + hbl(ji,jj) = gdepw(ji,jj,iiki,Kmm ) ! Turbocline depth + dh(ji,jj) = e3t(ji,jj,iiki-1,Kmm ) ! Turbocline depth + hml(ji,jj) = hbl(ji,jj) - dh(ji,jj) + END_2D + ! + WRITE(numout,*) ' ===>>>> : hbl computed from stratification' + ! + IF( ln_osm_mle ) THEN + hmle(:,:) = hbl(:,:) ! Initialise MLE depth. + WRITE(numout,*) ' ===>>>> : hmle set = to hbl' + END IF + ! + ww(:,:,:) = 0.0_wp + WRITE(numout,*) ' ===>>>> : wn not in restart file, set to zero initially' + ! + END SUBROUTINE osm_rst + + SUBROUTINE tra_osm( kt, Kmm, pts, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_osm *** + !! + !! ** Purpose : compute and add to the tracer trend the non-local tracer flux + !! + !! ** Method : ??? + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! Time step index + INTEGER , INTENT(in ) :: Kmm, Krhs ! Time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! Active tracers and RHS of tracer equation + !! + INTEGER :: ji, jj, jk + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds ! 3D workspace + !!---------------------------------------------------------------------- + ! + IF ( kt == nit000 ) THEN + IF ( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_osm : OSM non-local tracer fluxes' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + END IF + END IF + ! + IF ( l_trdtra ) THEN ! Save ta and sa trends + ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) + END IF + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) + pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) & + & - ( ghamt(ji,jj,jk ) & + & - ghamt(ji,jj,jk+1) ) /e3t(ji,jj,jk,Kmm) + pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) & + & - ( ghams(ji,jj,jk ) & + & - ghams(ji,jj,jk+1) ) / e3t(ji,jj,jk,Kmm) + END_3D + ! + IF ( l_trdtra ) THEN ! Save the non-local tracer flux trends for diagnostics + ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) + ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_osm, ztrdt ) + CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_osm, ztrds ) + DEALLOCATE( ztrdt, ztrds ) + END IF + ! + IF ( sn_cfctl%l_prtctl ) THEN + CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' osm - Ta: ', mask1=tmask, & + & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + END IF + ! + END SUBROUTINE tra_osm + + SUBROUTINE trc_osm( kt ) ! Dummy routine + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_osm *** + !! + !! ** Purpose : compute and add to the passive tracer trend the non-local + !! passive tracer flux + !! + !! + !! ** Method : ??? + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + !!---------------------------------------------------------------------- + ! + WRITE(*,*) 'trc_osm: Not written yet', kt + ! + END SUBROUTINE trc_osm + + SUBROUTINE dyn_osm( kt, Kmm, puu, pvv, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_osm *** + !! + !! ** Purpose : compute and add to the velocity trend the non-local flux + !! copied/modified from tra_osm + !! + !! ** Method : ??? + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! Ocean time step index + INTEGER , INTENT(in ) :: Kmm, Krhs ! Ocean time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! Ocean velocities and RHS of momentum equation + !! + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF ( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_osm : OSM non-local velocity' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + END IF + ! + ! Code saving tracer trends removed, replace with trdmxl_oce + ! + DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Add non-local u and v fluxes + puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( ghamu(ji,jj,jk ) - & + & ghamu(ji,jj,jk+1) ) / e3u(ji,jj,jk,Kmm) + pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( ghamv(ji,jj,jk ) - & + & ghamv(ji,jj,jk+1) ) / e3v(ji,jj,jk,Kmm) + END_3D + ! + ! Code for saving tracer trends removed + ! + END SUBROUTINE dyn_osm + + SUBROUTINE zdf_osm_iomput_2d( cdname, posmdia2d ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_iomput_2d *** + !! + !! ** Purpose : Wrapper for subroutine iom_put that accepts 2D arrays + !! with and without halo + !! + !!---------------------------------------------------------------------- + CHARACTER(LEN=*), INTENT(in ) :: cdname + REAL(wp), DIMENSION(:,:), INTENT(in ) :: posmdia2d + !!---------------------------------------------------------------------- + ! + IF ( ln_dia_osm .AND. iom_use( cdname ) ) THEN + IF ( SIZE( posmdia2d, 1 ) == ntei-ntsi+1 .AND. SIZE( posmdia2d, 2 ) == ntej-ntsj+1 ) THEN ! Halo absent + osmdia2d(A2D(0)) = posmdia2d(:,:) + CALL iom_put( cdname, osmdia2d(A2D(nn_hls)) ) + ELSE ! Halo present + CALL iom_put( cdname, osmdia2d ) + END IF + END IF + ! + END SUBROUTINE zdf_osm_iomput_2d + + SUBROUTINE zdf_osm_iomput_3d( cdname, posmdia3d ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_osm_iomput_3d *** + !! + !! ** Purpose : Wrapper for subroutine iom_put that accepts 3D arrays + !! with and without halo + !! + !!---------------------------------------------------------------------- + CHARACTER(LEN=*), INTENT(in ) :: cdname + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: posmdia3d + !!---------------------------------------------------------------------- + ! + IF ( ln_dia_osm .AND. iom_use( cdname ) ) THEN + IF ( SIZE( posmdia3d, 1 ) == ntei-ntsi+1 .AND. SIZE( posmdia3d, 2 ) == ntej-ntsj+1 ) THEN ! Halo absent + osmdia3d(A2D(0),:) = posmdia3d(:,:,:) + CALL iom_put( cdname, osmdia3d(A2D(nn_hls),:) ) + ELSE ! Halo present + CALL iom_put( cdname, osmdia3d ) + END IF + END IF + ! + END SUBROUTINE zdf_osm_iomput_3d + + !!====================================================================== + +END MODULE zdfosm \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfphy.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfphy.F90 new file mode 100644 index 0000000..963dd3a --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfphy.F90 @@ -0,0 +1,405 @@ +MODULE zdfphy + !!====================================================================== + !! *** MODULE zdfphy *** + !! Vertical ocean physics : manager of all vertical physics packages + !!====================================================================== + !! History : 4.0 ! 2017-04 (G. Madec) original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_phy_init : initialization of all vertical physics packages + !! zdf_phy : upadate at each time-step the vertical mixing coeff. + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + ! TEMP: [tiling] This change not necessary after finalisation of zdf_osm (not yet tiled) + USE domtile + USE zdf_oce ! vertical physics: shared variables + USE zdfdrg ! vertical physics: top/bottom drag coef. + USE zdfsh2 ! vertical physics: shear production term of TKE + USE zdfric ! vertical physics: RIChardson dependent vertical mixing + USE zdftke ! vertical physics: TKE vertical mixing + USE zdfgls ! vertical physics: GLS vertical mixing + USE zdfosm ! vertical physics: OSMOSIS vertical mixing + USE zdfddm ! vertical physics: double diffusion mixing + USE zdfevd ! vertical physics: convection via enhanced vertical diffusion + USE zdfmfc ! vertical physics: Mass Flux Convection + USE zdfiwm ! vertical physics: internal wave-induced mixing + USE zdfswm ! vertical physics: surface wave-induced mixing + USE zdfmxl ! vertical physics: mixed layer + USE tranpc ! convection: non penetrative adjustment + USE trc_oce ! variables shared between passive tracer & ocean + USE sbc_oce ! surface module (only for nn_isf in the option compatibility test) + USE sbcrnf ! surface boundary condition: runoff variables + USE sbc_ice ! sea ice drag +#if defined key_agrif + USE agrif_oce_interp ! interpavm +#endif + ! + USE in_out_manager ! I/O manager + USE iom ! IOM library + USE lbclnk ! lateral boundary conditions + USE lib_mpp ! distribued memory computing + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_phy_init ! called by nemogcm.F90 + PUBLIC zdf_phy ! called by step.F90 + + INTEGER :: nzdf_phy ! type of vertical closure used + ! ! associated indicators + INTEGER, PARAMETER :: np_CST = 1 ! Constant Kz + INTEGER, PARAMETER :: np_RIC = 2 ! Richardson number dependent Kz + INTEGER, PARAMETER :: np_TKE = 3 ! Turbulente Kinetic Eenergy closure scheme for Kz + INTEGER, PARAMETER :: np_GLS = 4 ! Generic Length Scale closure scheme for Kz + INTEGER, PARAMETER :: np_OSM = 5 ! OSMOSIS-OBL closure scheme for Kz + + LOGICAL, PUBLIC :: l_zdfsh2 ! shear production term flag (=F for CST, =T otherwise (i.e. TKE, GLS, RIC)) + + REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm_k_n !: "Now" avm_k used for calculation of zsh2 with tiling + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfphy.F90 15553 2021-11-29 11:36:23Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_phy_init( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_phy_init *** + !! + !! ** Purpose : initializations of the vertical ocean physics + !! + !! ** Method : Read namelist namzdf, control logicals + !! set horizontal shape and vertical profile of background mixing coef. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: Kmm ! time level index (middle) + ! + INTEGER :: jk ! dummy loop indices + INTEGER :: ioptio, ios ! local integers + !! + NAMELIST/namzdf/ ln_zdfcst, ln_zdfric, ln_zdftke, ln_zdfgls, & ! type of closure scheme + & ln_zdfosm, & ! type of closure scheme + & ln_zdfmfc, & ! convection : mass flux + & ln_zdfevd, nn_evdm, rn_evd , & ! convection : evd + & ln_zdfnpc, nn_npc , nn_npcp, & ! convection : npc + & ln_zdfddm, rn_avts, rn_hsbfr, & ! double diffusion + & ln_zdfswm, & ! surface wave-induced mixing + & ln_zdfiwm, & ! internal - - - + & ln_zad_Aimp, & ! apdative-implicit vertical advection + & rn_avm0, rn_avt0, nn_avb, nn_havtb ! coefficients + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'zdf_phy_init: ocean vertical physics' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + ! !== Namelist ==! + READ ( numnam_ref, namzdf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf in reference namelist' ) + ! + READ ( numnam_cfg, namzdf, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf ) + ! + IF(lwp) THEN ! Parameter print + WRITE(numout,*) ' Namelist namzdf : set vertical mixing mixing parameters' + WRITE(numout,*) ' adaptive-implicit vertical advection' + WRITE(numout,*) ' Courant number targeted application ln_zad_Aimp = ', ln_zad_Aimp + WRITE(numout,*) ' vertical closure scheme' + WRITE(numout,*) ' constant vertical mixing coefficient ln_zdfcst = ', ln_zdfcst + WRITE(numout,*) ' Richardson number dependent closure ln_zdfric = ', ln_zdfric + WRITE(numout,*) ' Turbulent Kinetic Energy closure (TKE) ln_zdftke = ', ln_zdftke + WRITE(numout,*) ' Generic Length Scale closure (GLS) ln_zdfgls = ', ln_zdfgls + WRITE(numout,*) ' OSMOSIS-OBL closure (OSM) ln_zdfosm = ', ln_zdfosm + WRITE(numout,*) ' convection: ' + WRITE(numout,*) ' convection mass flux (mfc) ln_zdfmfc = ', ln_zdfmfc + WRITE(numout,*) ' enhanced vertical diffusion ln_zdfevd = ', ln_zdfevd + WRITE(numout,*) ' applied on momentum (=1/0) nn_evdm = ', nn_evdm + WRITE(numout,*) ' vertical coefficient for evd rn_evd = ', rn_evd + WRITE(numout,*) ' non-penetrative convection (npc) ln_zdfnpc = ', ln_zdfnpc + WRITE(numout,*) ' npc call frequency nn_npc = ', nn_npc + WRITE(numout,*) ' npc print frequency nn_npcp = ', nn_npcp + WRITE(numout,*) ' double diffusive mixing ln_zdfddm = ', ln_zdfddm + WRITE(numout,*) ' maximum avs for dd mixing rn_avts = ', rn_avts + WRITE(numout,*) ' heat/salt buoyancy flux ratio rn_hsbfr= ', rn_hsbfr + WRITE(numout,*) ' gravity wave-induced mixing' + WRITE(numout,*) ' surface wave (Qiao et al 2010) ln_zdfswm = ', ln_zdfswm ! surface wave induced mixing + WRITE(numout,*) ' internal wave (de Lavergne et al 2017) ln_zdfiwm = ', ln_zdfiwm + WRITE(numout,*) ' coefficients : ' + WRITE(numout,*) ' vertical eddy viscosity rn_avm0 = ', rn_avm0 + WRITE(numout,*) ' vertical eddy diffusivity rn_avt0 = ', rn_avt0 + WRITE(numout,*) ' constant background or profile nn_avb = ', nn_avb + WRITE(numout,*) ' horizontal variation for avtb nn_havtb = ', nn_havtb + ENDIF + + IF( ln_zad_Aimp ) THEN + IF( zdf_phy_alloc() /= 0 ) & + & CALL ctl_stop( 'STOP', 'zdf_phy_init : unable to allocate adaptive-implicit z-advection arrays' ) + Cu_adv(:,:,:) = 0._wp + wi (:,:,:) = 0._wp + ENDIF + ! ! Initialise zdf_mxl arrays (only hmld as not set everywhere when nn_hls > 1) + IF( zdf_mxl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_mxl : unable to allocate arrays' ) + hmld(:,:) = 0._wp + ! !== Background eddy viscosity and diffusivity ==! + IF( nn_avb == 0 ) THEN ! Define avmb, avtb from namelist parameter + avmb(:) = rn_avm0 + avtb(:) = rn_avt0 + ELSE ! Background profile of avt (fit a theoretical/observational profile (Krauss 1990) + avmb(:) = rn_avm0 + avtb(:) = rn_avt0 + ( 3.e-4_wp - 2._wp * rn_avt0 ) * 1.e-4_wp * gdepw_1d(:) ! m2/s + IF(ln_sco .AND. lwp) CALL ctl_warn( 'avtb profile not valid in sco' ) + ENDIF + ! ! 2D shape of the avtb + avtb_2d(:,:) = 1._wp ! uniform + ! + IF( nn_havtb == 1 ) THEN ! decrease avtb by a factor of ten in the equatorial band + ! ! -15S -5S : linear decrease from avt0 to avt0/10. + ! ! -5S +5N : cst value avt0/10. + ! ! 5N 15N : linear increase from avt0/10, to avt0 + WHERE(-15. <= gphit .AND. gphit < -5 ) avtb_2d = (1. - 0.09 * (gphit + 15.)) + WHERE( -5. <= gphit .AND. gphit < 5 ) avtb_2d = 0.1 + WHERE( 5. <= gphit .AND. gphit < 15 ) avtb_2d = (0.1 + 0.09 * (gphit - 5.)) + ENDIF + ! + DO jk = 1, jpk ! set turbulent closure Kz to the background value (avt_k, avm_k) + avt_k(:,:,jk) = avtb_2d(:,:) * avtb(jk) * wmask (:,:,jk) + avm_k(:,:,jk) = avmb(jk) * wmask (:,:,jk) + END DO +!!gm to be tested only the 1st & last levels +! avt (:,:, 1 ) = 0._wp ; avs(:,:, 1 ) = 0._wp ; avm (:,:, 1 ) = 0._wp +! avt (:,:,jpk) = 0._wp ; avs(:,:,jpk) = 0._wp ; avm (:,:,jpk) = 0._wp +!!gm + avt (:,:,:) = 0._wp ; avs(:,:,:) = 0._wp ; avm (:,:,:) = 0._wp + + ! !== Convection ==! + ! + IF( ln_zdfnpc .AND. ln_zdfevd ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfnpc and ln_zdfevd' ) + IF( ln_zdfosm .AND. ln_zdfevd ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfosm and ln_zdfevd' ) + IF( ln_zdfmfc .AND. ln_zdfevd ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfmfc and ln_zdfevd' ) + IF( ln_zdfmfc .AND. ln_zdfnpc ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfmfc and ln_zdfnpc' ) + IF( ln_zdfmfc .AND. ln_zdfosm ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfmfc and ln_zdfosm' ) + IF( lk_top .AND. ln_zdfnpc ) CALL ctl_stop( 'zdf_phy_init: npc scheme is not working with key_top' ) + IF( lk_top .AND. ln_zdfosm ) CALL ctl_warn( 'zdf_phy_init: osmosis gives no non-local fluxes for TOP tracers yet' ) + IF( lk_top .AND. ln_zdfmfc ) CALL ctl_stop( 'zdf_phy_init: Mass Flux scheme is not working with key_top' ) + IF(lwp) THEN + WRITE(numout,*) + IF ( ln_zdfnpc ) THEN ; WRITE(numout,*) ' ==>>> convection: use non penetrative convective scheme' + ELSEIF( ln_zdfevd ) THEN ; WRITE(numout,*) ' ==>>> convection: use enhanced vertical diffusion scheme' + ELSEIF( ln_zdfmfc ) THEN ; WRITE(numout,*) ' ==>>> convection: use Mass Flux scheme' + ELSE ; WRITE(numout,*) ' ==>>> convection: no specific scheme used' + ENDIF + ENDIF + + IF(lwp) THEN !== Double Diffusion Mixing parameterization ==! (ddm) + WRITE(numout,*) + IF( ln_zdfddm ) THEN ; WRITE(numout,*) ' ==>>> use double diffusive mixing: avs /= avt' + ELSE ; WRITE(numout,*) ' ==>>> No double diffusive mixing: avs = avt' + ENDIF + ENDIF + + ! !== type of vertical turbulent closure ==! (set nzdf_phy) + ioptio = 0 + IF( ln_zdfcst ) THEN ; ioptio = ioptio + 1 ; nzdf_phy = np_CST ; ENDIF + IF( ln_zdfric ) THEN ; ioptio = ioptio + 1 ; nzdf_phy = np_RIC ; CALL zdf_ric_init ; ENDIF + IF( ln_zdftke ) THEN ; ioptio = ioptio + 1 ; nzdf_phy = np_TKE ; CALL zdf_tke_init( Kmm ) ; ENDIF + IF( ln_zdfgls ) THEN ; ioptio = ioptio + 1 ; nzdf_phy = np_GLS ; CALL zdf_gls_init ; ENDIF + IF( ln_zdfosm ) THEN ; ioptio = ioptio + 1 ; nzdf_phy = np_OSM ; CALL zdf_osm_init( Kmm ) ; ENDIF + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'zdf_phy_init: one and only one vertical diffusion option has to be defined ' ) + IF( ln_isfcav ) THEN + IF( ln_zdfric ) CALL ctl_stop( 'zdf_phy_init: zdfric never tested with ice shelves cavities ' ) + ENDIF + ! ! shear production term flag + IF( ln_zdfcst .OR. ln_zdfosm ) THEN ; l_zdfsh2 = .FALSE. + ELSE ; l_zdfsh2 = .TRUE. + ENDIF + IF( ln_tile .AND. l_zdfsh2 ) ALLOCATE( avm_k_n(jpi,jpj,jpk) ) + ! !== Mass Flux Convectiive algorithm ==! + IF( ln_zdfmfc ) CALL zdf_mfc_init ! Convection computed with eddy diffusivity mass flux + ! + ! !== gravity wave-driven mixing ==! + IF( ln_zdfiwm ) CALL zdf_iwm_init ! internal wave-driven mixing + IF( ln_zdfswm ) CALL zdf_swm_init ! surface wave-driven mixing + + ! !== top/bottom friction ==! + CALL zdf_drg_init + ! + ! !== time-stepping ==! + ! Check/update of time stepping done in dynzdf_init/trazdf_init + !!gm move it here ? + ! + END SUBROUTINE zdf_phy_init + + + SUBROUTINE zdf_phy( kt, Kbb, Kmm, Krhs ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_phy *** + !! + !! ** Purpose : Update ocean physics at each time-step + !! + !! ** Method : + !! + !! ** Action : avm, avt vertical eddy viscosity and diffusivity at w-points + !! nmld ??? mixed layer depth in level and meters <<<<====verifier ! + !! bottom stress..... <<<<====verifier ! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in) :: Kbb, Kmm, Krhs ! ocean time level indices + ! + INTEGER :: ji, jj, jk ! dummy loop indice + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zsh2 ! shear production + !! --------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('zdf_phy') + ! + IF( l_zdfdrg ) THEN !== update top/bottom drag ==! (non-linear cases) + ! + ! !* bottom drag + CALL zdf_drg( kt, Kmm, mbkt , r_Cdmin_bot, r_Cdmax_bot, & ! <<== in + & r_z0_bot, r_ke0_bot, rCd0_bot, & + & rCdU_bot ) ! ==>> out : bottom drag [m/s] + IF( ln_isfcav ) THEN !* top drag (ocean cavities) + CALL zdf_drg( kt, Kmm, mikt , r_Cdmin_top, r_Cdmax_top, & ! <<== in + & r_z0_top, r_ke0_top, rCd0_top, & + & rCdU_top ) ! ==>> out : bottom drag [m/s] + ENDIF + ENDIF + ! +#if defined key_si3 + IF ( ln_drgice_imp) THEN + IF ( ln_isfcav ) THEN + DO_2D_OVR( 1, 1, 1, 1 ) + rCdU_top(ji,jj) = rCdU_top(ji,jj) + ssmask(ji,jj) * tmask(ji,jj,1) * rCdU_ice(ji,jj) + END_2D + ELSE + DO_2D_OVR( 1, 1, 1, 1 ) + rCdU_top(ji,jj) = rCdU_ice(ji,jj) + END_2D + ENDIF + ENDIF +#endif + ! + CALL zdf_mxl( kt, Kmm ) !* mixed layer depth, and level + ! + ! !== Kz from chosen turbulent closure ==! (avm_k, avt_k) + ! + ! NOTE: [tiling] the closure schemes (zdf_tke etc) will update avm_k. With tiling, the calculation of zsh2 on adjacent tiles then uses both updated (next timestep) and non-updated (current timestep) values of avm_k. To preserve results, we save a read-only copy of the "now" avm_k to use in the calculation of zsh2. + IF( l_zdfsh2 ) THEN !* shear production at w-points (energy conserving form) + IF( ln_tile ) THEN + IF( ntile == 1 ) avm_k_n(:,:,:) = avm_k(:,:,:) ! Preserve "now" avm_k for calculation of zsh2 + CALL zdf_sh2( Kbb, Kmm, avm_k_n, & ! <<== in + & zsh2 ) ! ==>> out : shear production + ELSE + CALL zdf_sh2( Kbb, Kmm, avm_k, & ! <<== in + & zsh2 ) ! ==>> out : shear production + ENDIF + ENDIF + ! + SELECT CASE ( nzdf_phy ) !* Vertical eddy viscosity and diffusivity coefficients at w-points + CASE( np_RIC ) ; CALL zdf_ric( kt, Kmm, zsh2, avm_k, avt_k ) ! Richardson number dependent Kz + CASE( np_TKE ) ; CALL zdf_tke( kt, Kbb, Kmm, zsh2, avm_k, avt_k ) ! TKE closure scheme for Kz + CASE( np_GLS ) ; CALL zdf_gls( kt, Kbb, Kmm, zsh2, avm_k, avt_k ) ! GLS closure scheme for Kz + CASE( np_OSM ) ; CALL zdf_osm( kt, Kbb, Kmm, Krhs, avm_k, avt_k ) ! OSMOSIS closure scheme for Kz + ! CASE( np_CST ) ! Constant Kz (reset avt, avm to the background value) + ! ! avt_k and avm_k set one for all at initialisation phase +!!gm avt(2:jpim1,2:jpjm1,1:jpkm1) = rn_avt0 * wmask(2:jpim1,2:jpjm1,1:jpkm1) +!!gm avm(2:jpim1,2:jpjm1,1:jpkm1) = rn_avm0 * wmask(2:jpim1,2:jpjm1,1:jpkm1) + END SELECT + ! + ! !== ocean Kz ==! (avt, avs, avm) +#if defined key_agrif + ! interpolation parent grid => child grid for avm_k ( ex : at west border: update column 1 and 2) + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF( l_zdfsh2 ) CALL Agrif_avm + ENDIF +#endif + ! + ! !* start from turbulent closure values + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + avt(ji,jj,jk) = avt_k(ji,jj,jk) + avm(ji,jj,jk) = avm_k(ji,jj,jk) + END_3D + ! + IF( ln_rnf_mouth ) THEN !* increase diffusivity at rivers mouths + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, nkrnf ) + avt(ji,jj,jk) = avt(ji,jj,jk) + 2._wp * rn_avt_rnf * rnfmsk(ji,jj) * wmask(ji,jj,jk) + END_3D + ENDIF + ! + IF( ln_zdfevd ) CALL zdf_evd( kt, Kmm, Krhs, avm, avt ) !* convection: enhanced vertical eddy diffusivity + ! + ! !* double diffusive mixing + IF( ln_zdfddm ) THEN ! update avt and compute avs + CALL zdf_ddm( kt, Kmm, avm, avt, avs ) + ELSE ! same mixing on all tracers + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + avs(ji,jj,jk) = avt(ji,jj,jk) + END_3D + ENDIF + ! + ! !* wave-induced mixing + IF( ln_zdfswm ) CALL zdf_swm( kt, Kmm, avm, avt, avs ) ! surface wave (Qiao et al. 2004) + IF( ln_zdfiwm ) CALL zdf_iwm( kt, Kmm, avm, avt, avs ) ! internal wave (de Lavergne et al 2017) + + ! !* Lateral boundary conditions (sign unchanged) + IF(nn_hls==1) THEN + IF( l_zdfsh2 ) THEN + CALL lbc_lnk( 'zdfphy', avm_k, 'W', 1.0_wp , avt_k, 'W', 1.0_wp, & + & avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp ) + ELSE + CALL lbc_lnk( 'zdfphy', avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp ) + ENDIF + ! + IF( l_zdfdrg ) THEN ! drag have been updated (non-linear cases) + IF( ln_isfcav ) THEN ; CALL lbc_lnk( 'zdfphy', rCdU_top, 'T', 1.0_wp , rCdU_bot, 'T', 1.0_wp ) ! top & bot drag + ELSE ; CALL lbc_lnk( 'zdfphy', rCdU_bot, 'T', 1.0_wp ) ! bottom drag only + ENDIF + ENDIF + ENDIF + ! + CALL zdf_mxl_turb( kt, Kmm ) !* turbocline depth + ! + IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile + IF( lrst_oce ) THEN !* write TKE, GLS or RIC fields in the restart file + IF( ln_zdftke ) CALL tke_rst( kt, 'WRITE' ) + IF( ln_zdfgls ) CALL gls_rst( kt, 'WRITE' ) + IF( ln_zdfric ) CALL ric_rst( kt, 'WRITE' ) + ! NB. OSMOSIS restart (osm_rst) will be called in step.F90 after ww has been updated + ENDIF + ENDIF + ! + ! diagnostics of energy dissipation + IF( iom_use('avt_k') .OR. iom_use('avm_k') .OR. iom_use('eshear_k') .OR. iom_use('estrat_k') ) THEN + IF( l_zdfsh2 ) THEN + CALL iom_put( 'avt_k' , avt_k * wmask ) + CALL iom_put( 'avm_k' , avm_k * wmask ) + CALL iom_put( 'eshear_k', zsh2 * wmask ) + CALL iom_put( 'estrat_k', - avt_k * rn2 * wmask ) + ENDIF + ENDIF + ! + IF( ln_timing ) CALL timing_stop('zdf_phy') + ! + END SUBROUTINE zdf_phy + + + INTEGER FUNCTION zdf_phy_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_phy_alloc *** + !!---------------------------------------------------------------------- + ! Allocate wi array (declared in oce.F90) for use with the adaptive-implicit vertical velocity option + ALLOCATE( wi(jpi,jpj,jpk), Cu_adv(jpi,jpj,jpk), STAT= zdf_phy_alloc ) + IF( zdf_phy_alloc /= 0 ) CALL ctl_warn('zdf_phy_alloc: failed to allocate ln_zad_Aimp=T required arrays') + CALL mpp_sum ( 'zdfphy', zdf_phy_alloc ) + END FUNCTION zdf_phy_alloc + + !!====================================================================== +END MODULE zdfphy \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfric.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfric.F90 new file mode 100644 index 0000000..386c62b --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfric.F90 @@ -0,0 +1,230 @@ +MODULE zdfric + !!====================================================================== + !! *** MODULE zdfric *** + !! Ocean physics: vertical mixing coefficient compute from the local + !! Richardson number dependent formulation + !!====================================================================== + !! History : OPA ! 1987-09 (P. Andrich) Original code + !! 4.0 ! 1991-11 (G. Madec) + !! 7.0 ! 1996-01 (G. Madec) complete rewriting of multitasking suppression of common work arrays + !! 8.0 ! 1997-06 (G. Madec) complete rewriting of zdfmix + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.3.1! 2011-09 (P. Oddo) Mixed layer depth parameterization + !! 4.0 ! 2017-04 (G. Madec) remove CPP ddm key & avm at t-point only + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_ric_init : initialization, namelist read, & parameters control + !! zdf_ric : update momentum and tracer Kz from the Richardson number + !! ric_rst : read/write RIC restart in ocean restart file + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE zdf_oce ! vertical physics: variables + USE phycst ! physical constants + USE sbc_oce, ONLY : taum + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_ric ! called by zdfphy.F90 + PUBLIC ric_rst ! called by zdfphy.F90 + PUBLIC zdf_ric_init ! called by nemogcm.F90 + + ! !!* Namelist namzdf_ric : Richardson number dependent Kz * + INTEGER :: nn_ric ! coefficient of the parameterization + REAL(wp) :: rn_avmri ! maximum value of the vertical eddy viscosity + REAL(wp) :: rn_alp ! coefficient of the parameterization + REAL(wp) :: rn_ekmfc ! Ekman Factor Coeff + REAL(wp) :: rn_mldmin ! minimum mixed layer (ML) depth + REAL(wp) :: rn_mldmax ! maximum mixed layer depth + REAL(wp) :: rn_wtmix ! Vertical eddy Diff. in the ML + REAL(wp) :: rn_wvmix ! Vertical eddy Visc. in the ML + LOGICAL :: ln_mldw ! Use or not the MLD parameters + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfric.F90 15277 2021-09-22 13:19:40Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_ric_init + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_ric_init *** + !! + !! ** Purpose : Initialization of the vertical eddy diffusivity and + !! viscosity coef. for the Richardson number dependent formulation. + !! + !! ** Method : Read the namzdf_ric namelist and check the parameter values + !! + !! ** input : Namelist namzdf_ric + !! + !! ** Action : increase by 1 the nstop flag is setting problem encounter + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/namzdf_ric/ rn_avmri, rn_alp , nn_ric , rn_ekmfc, & + & rn_mldmin, rn_mldmax, rn_wtmix, rn_wvmix, ln_mldw + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namzdf_ric, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_ric in reference namelist' ) + + READ ( numnam_cfg, namzdf_ric, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_ric in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf_ric ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_ric_init : Ri depend vertical mixing scheme' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namzdf_ric : set Kz=F(Ri) parameters' + WRITE(numout,*) ' maximum vertical viscosity rn_avmri = ', rn_avmri + WRITE(numout,*) ' coefficient rn_alp = ', rn_alp + WRITE(numout,*) ' exponent nn_ric = ', nn_ric + WRITE(numout,*) ' Ekman layer enhanced mixing ln_mldw = ', ln_mldw + WRITE(numout,*) ' Ekman Factor Coeff rn_ekmfc = ', rn_ekmfc + WRITE(numout,*) ' minimum mixed layer depth rn_mldmin = ', rn_mldmin + WRITE(numout,*) ' maximum mixed layer depth rn_mldmax = ', rn_mldmax + WRITE(numout,*) ' Vertical eddy Diff. in the ML rn_wtmix = ', rn_wtmix + WRITE(numout,*) ' Vertical eddy Visc. in the ML rn_wvmix = ', rn_wvmix + ENDIF + ! + CALL ric_rst( nit000, 'READ' ) !* read or initialize all required files + ! + END SUBROUTINE zdf_ric_init + + + SUBROUTINE zdf_ric( kt, Kmm, p_sh2, p_avm, p_avt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdfric *** + !! + !! ** Purpose : Compute the before eddy viscosity and diffusivity as + !! a function of the local richardson number. + !! + !! ** Method : Local richardson number dependent formulation of the + !! vertical eddy viscosity and diffusivity coefficients. + !! The eddy coefficients are given by: + !! avm = avm0 + avmb + !! avt = avm0 / (1 + rn_alp*ri) + !! with ri = N^2 / dz(u)**2 + !! = e3w**2 * rn2/[ mi( dk(uu(:,:,:,Kbb)) )+mj( dk(vv(:,:,:,Kbb)) ) ] + !! avm0= rn_avmri / (1 + rn_alp*Ri)**nn_ric + !! where ri is the before local Richardson number, + !! rn_avmri is the maximum value reaches by avm and avt + !! and rn_alp, nn_ric are adjustable parameters. + !! Typical values : rn_alp=5. and nn_ric=2. + !! + !! As second step compute Ekman depth from wind stress forcing + !! and apply namelist provided vertical coeff within this depth. + !! The Ekman depth is: + !! Ustar = SQRT(Taum/rho0) + !! ekd= rn_ekmfc * Ustar / f0 + !! Large et al. (1994, eq.24) suggest rn_ekmfc=0.7; however, the derivation + !! of the above equation indicates the value is somewhat arbitrary; therefore + !! we allow the freedom to increase or decrease this value, if the + !! Ekman depth estimate appears too shallow or too deep, respectively. + !! Ekd is then limited by rn_mldmin and rn_mldmax provided in the + !! namelist + !! N.B. the mask are required for implicit scheme, and surface + !! and bottom value already set in zdfphy.F90 + !! + !! ** Action : avm, avt mixing coeff (inner domain values only) + !! + !! References : Pacanowski & Philander 1981, JPO, 1441-1451. + !! PFJ Lermusiaux 2001. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step + INTEGER , INTENT(in ) :: Kmm ! ocean time level index + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcfRi, zav, zustar, zhek ! local scalars + REAL(wp), DIMENSION(A2D(nn_hls)) :: zh_ekm ! 2D workspace + !!---------------------------------------------------------------------- + ! + ! !== avm and avt = F(Richardson number) ==! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! coefficient = F(richardson number) (avm-weighted Ri) + zcfRi = 1._wp / ( 1._wp + rn_alp * MAX( 0._wp , avm(ji,jj,jk) * rn2(ji,jj,jk) / ( p_sh2(ji,jj,jk) + 1.e-20 ) ) ) + zav = rn_avmri * zcfRi**nn_ric + ! ! avm and avt coefficients + p_avm(ji,jj,jk) = MAX( zav , avmb(jk) ) * wmask(ji,jj,jk) + p_avt(ji,jj,jk) = MAX( zav * zcfRi , avtb(jk) ) * wmask(ji,jj,jk) + END_3D + ! +!!gm BUG <<<<==== This param can't work at low latitude +!!gm it provides there much to thick mixed layer ( summer 150m in GYRE configuration !!! ) + ! + IF( ln_mldw ) THEN !== set a minimum value in the Ekman layer ==! + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zustar = SQRT( taum(ji,jj) * r1_rho0 ) + zhek = rn_ekmfc * zustar / ( ABS( ff_t(ji,jj) ) + rsmall ) ! Ekman depth + zh_ekm(ji,jj) = MAX( rn_mldmin , MIN( zhek , rn_mldmax ) ) ! set allowed range + END_2D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !* minimum mixing coeff. within the Ekman layer + IF( gdept(ji,jj,jk,Kmm) < zh_ekm(ji,jj) ) THEN + p_avm(ji,jj,jk) = MAX( p_avm(ji,jj,jk), rn_wvmix ) * wmask(ji,jj,jk) + p_avt(ji,jj,jk) = MAX( p_avt(ji,jj,jk), rn_wtmix ) * wmask(ji,jj,jk) + ENDIF + END_3D + ENDIF + ! + END SUBROUTINE zdf_ric + + + SUBROUTINE ric_rst( kt, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE ric_rst *** + !! + !! ** Purpose : Read or write TKE file (en) in restart file + !! + !! ** Method : use of IOM library + !! if the restart does not contain TKE, en is either + !! set to rn_emin or recomputed + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + ! + INTEGER :: jit, jk ! dummy loop indices + INTEGER :: id1, id2 ! local integers + !!---------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise + ! ! --------------- + ! !* Read the restart file + IF( ln_rstart ) THEN + id1 = iom_varid( numror, 'avt_k', ldstop = .FALSE. ) + id2 = iom_varid( numror, 'avm_k', ldstop = .FALSE. ) + ! + IF( MIN( id1, id2 ) > 0 ) THEN ! restart exists => read it + CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k ) + CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k ) + ENDIF + ENDIF + ! !* otherwise Kz already set to the background value in zdf_phy_init + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! ------------------- + IF(lwp) WRITE(numout,*) '---- ric-rst ----' + CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k ) + CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k) + ! + ENDIF + ! + END SUBROUTINE ric_rst + + !!====================================================================== +END MODULE zdfric \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfsh2.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfsh2.F90 new file mode 100644 index 0000000..7b9a7fe --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfsh2.F90 @@ -0,0 +1,106 @@ +MODULE zdfsh2 + !!====================================================================== + !! *** MODULE zdfsh2 *** + !! Ocean physics: shear production term of TKE + !!===================================================================== + !! History : - ! 2014-10 (A. Barthelemy, G. Madec) original code + !! NEMO 4.0 ! 2017-04 (G. Madec) remove u-,v-pts avm + !! NEMO 4.2 ! 2020-12 (G. Madec, E. Clementi) add Stokes Drift Shear + ! ! for wave coupling + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_sh2 : compute mixing the shear production term of TKE + !!---------------------------------------------------------------------- + USE oce + USE dom_oce ! domain: ocean + USE sbcwave ! Surface Waves (add Stokes shear) + USE sbc_oce , ONLY: ln_stshear !Stoked Drift shear contribution + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_sh2 ! called by zdftke, zdfglf, and zdfric + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfsh2.F90 15293 2021-09-27 15:43:00Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_sh2( Kbb, Kmm, p_avm, p_sh2 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_sh2 *** + !! + !! ** Purpose : Compute the shear production term of a TKE equation + !! + !! ** Method : - a stable discretization of this term is linked to the + !! time-space discretization of the vertical diffusion + !! of the OGCM. NEMO uses C-grid, a leap-frog environment + !! and an implicit computation of vertical mixing term, + !! so the shear production at w-point is given by: + !! sh2 = mi[ mi(avm) * dk[ub]/e3ub * dk[un]/e3un ] + !! + mj[ mj(avm) * dk[vb]/e3vb * dk[vn]/e3vn ] + !! NB: wet-point only horizontal averaging of shear + !! + !! ** Action : - p_sh2 shear prod. term at w-point (inner domain only) + !! ***** + !! References : Bruchard, OM 2002 + !! --------------------------------------------------------------------- + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm ! vertical eddy viscosity (w-points) + REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT( out) :: p_sh2 ! shear production of TKE (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop arguments + REAL(wp), DIMENSION(A2D(nn_hls)) :: zsh2u, zsh2v ! 2D workspace + !!-------------------------------------------------------------------- + ! + DO jk = 2, jpkm1 !* Shear production at uw- and vw-points (energy conserving form) + IF ( cpl_sdrftx .AND. ln_stshear ) THEN ! Surface Stokes Drift available ===>>> shear + stokes drift contibution + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) + zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & + & * ( uu (ji,jj,jk-1,Kmm) - uu (ji,jj,jk,Kmm) & + & + usd(ji,jj,jk-1) - usd(ji,jj,jk) ) & + & * ( uu (ji,jj,jk-1,Kbb) - uu (ji,jj,jk,Kbb) ) & + & / ( e3uw(ji,jj,jk,Kmm) * e3uw(ji,jj,jk,Kbb) ) * wumask(ji,jj,jk) + zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) ) & + & * ( vv (ji,jj,jk-1,Kmm) - vv (ji,jj,jk,Kmm) & + & + vsd(ji,jj,jk-1) - vsd(ji,jj,jk) ) & + & * ( vv (ji,jj,jk-1,Kbb) - vv (ji,jj,jk,Kbb) ) & + &/ ( e3vw(ji,jj,jk,Kmm) * e3vw(ji,jj,jk,Kbb) ) * wvmask(ji,jj,jk) + END_2D + ELSE + DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) !* 2 x shear production at uw- and vw-points (energy conserving form) + zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & + & * ( uu(ji,jj,jk-1,Kmm) - uu(ji,jj,jk,Kmm) ) & + & * ( uu(ji,jj,jk-1,Kbb) - uu(ji,jj,jk,Kbb) ) & + & / ( e3uw(ji,jj,jk ,Kmm) * e3uw(ji,jj,jk,Kbb) ) & + & * wumask(ji,jj,jk) + zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) ) & + & * ( vv(ji,jj,jk-1,Kmm) - vv(ji,jj,jk,Kmm) ) & + & * ( vv(ji,jj,jk-1,Kbb) - vv(ji,jj,jk,Kbb) ) & + & / ( e3vw(ji,jj,jk ,Kmm) * e3vw(ji,jj,jk,Kbb) ) & + & * wvmask(ji,jj,jk) + END_2D + ENDIF + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* shear production at w-point ! coast mask: =2 at the coast ; =1 otherwise (NB: wmask useless as zsh2 are masked) + p_sh2(ji,jj,jk) = 0.25 * ( ( zsh2u(ji-1,jj) + zsh2u(ji,jj) ) * ( 2. - umask(ji-1,jj,jk) * umask(ji,jj,jk) ) & + & + ( zsh2v(ji,jj-1) + zsh2v(ji,jj) ) * ( 2. - vmask(ji,jj-1,jk) * vmask(ji,jj,jk) ) ) + END_2D + END DO + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! set p_sh2 to 0 at the surface and bottom for output purpose + p_sh2(ji,jj,1) = 0._wp + p_sh2(ji,jj,jpk) = 0._wp + END_2D + ! + END SUBROUTINE zdf_sh2 + + !!====================================================================== +END MODULE zdfsh2 \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfswm.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfswm.F90 new file mode 100644 index 0000000..be2aa94 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdfswm.F90 @@ -0,0 +1,97 @@ +MODULE zdfswm + !!====================================================================== + !! *** MODULE zdfswm *** + !! vertical physics : surface wave-induced mixing + !!====================================================================== + !! History : 3.6 ! 2014-10 (E. Clementi) Original code + !! 4.0 ! 2017-04 (G. Madec) debug + simplifications + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_swm : update Kz due to surface wave-induced mixing + !! zdf_swm_init : initilisation + !!---------------------------------------------------------------------- + USE dom_oce ! ocean domain variable + USE zdf_oce ! vertical physics: mixing coefficients + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbcwave ! wave module + ! + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distribued memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_swm ! routine called in zdp_phy + PUBLIC zdf_swm_init ! routine called in zdf_phy_init + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdfswm.F90 15062 2021-06-28 11:19:48Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_swm( kt, Kmm, p_avm, p_avt, p_avs ) + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_swm *** + !! + !! ** Purpose :Compute the swm term (qbv) to be added to + !! vertical viscosity and diffusivity coeffs. + !! + !! ** Method : Compute the swm term Bv (zqb) and added it to + !! vertical viscosity and diffusivity coefficients + !! zqb = alpha * A * Us(0) * exp (3 * k * z) + !! where alpha is set here to 1 + !! + !! ** action : avt, avs, avm updated by the surface wave-induced mixing + !! (inner domain only) + !! + !! reference : Qiao et al. GRL, 2004 + !!--------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: Kmm ! time level index + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm ! momentum Kz (w-points) + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avt, p_avs ! tracer Kz (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp):: zcoef, zqb ! local scalar + !!--------------------------------------------------------------------- + ! + zcoef = 1._wp * 0.353553_wp + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + zqb = zcoef * hsw(ji,jj) * tsd2d(ji,jj) * EXP( -3. * wnum(ji,jj) * gdepw(ji,jj,jk,Kmm) ) * wmask(ji,jj,jk) + ! + p_avt(ji,jj,jk) = p_avt(ji,jj,jk) + zqb + p_avs(ji,jj,jk) = p_avs(ji,jj,jk) + zqb + p_avm(ji,jj,jk) = p_avm(ji,jj,jk) + zqb + END_3D + ! + END SUBROUTINE zdf_swm + + + SUBROUTINE zdf_swm_init + !!--------------------------------------------------------------------- + !! *** ROUTINE zdf_swm_init *** + !! + !! ** Purpose : surface wave-induced mixing initialisation + !! + !! ** Method : check the availability of surface wave fields + !!--------------------------------------------------------------------- + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_swm_init : surface wave-driven mixing' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + IF( .NOT.ln_wave .OR. & + & .NOT.ln_sdw ) CALL ctl_stop ( 'zdf_swm_init: ln_zdfswm=T but ln_wave and ln_sdw /= T') + ! + END SUBROUTINE zdf_swm_init + + !!====================================================================== +END MODULE zdfswm \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdftke.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdftke.F90 new file mode 100644 index 0000000..458858d --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/ZDF/zdftke.F90 @@ -0,0 +1,889 @@ +MODULE zdftke + !!====================================================================== + !! *** MODULE zdftke *** + !! Ocean physics: vertical mixing coefficient computed from the tke + !! turbulent closure parameterization + !!===================================================================== + !! History : OPA ! 1991-03 (b. blanke) Original code + !! 7.0 ! 1991-11 (G. Madec) bug fix + !! 7.1 ! 1992-10 (G. Madec) new mixing length and eav + !! 7.2 ! 1993-03 (M. Guyon) symetrical conditions + !! 7.3 ! 1994-08 (G. Madec, M. Imbard) nn_pdl flag + !! 7.5 ! 1996-01 (G. Madec) s-coordinates + !! 8.0 ! 1997-07 (G. Madec) lbc + !! 8.1 ! 1999-01 (E. Stretta) new option for the mixing length + !! NEMO 1.0 ! 2002-06 (G. Madec) add tke_init routine + !! - ! 2004-10 (C. Ethe ) 1D configuration + !! 2.0 ! 2006-07 (S. Masson) distributed restart using iom + !! 3.0 ! 2008-05 (C. Ethe, G.Madec) : update TKE physics: + !! ! - tke penetration (wind steering) + !! ! - suface condition for tke & mixing length + !! ! - Langmuir cells + !! - ! 2008-05 (J.-M. Molines, G. Madec) 2D form of avtb + !! - ! 2008-06 (G. Madec) style + DOCTOR name for namelist parameters + !! - ! 2008-12 (G. Reffray) stable discretization of the production term + !! 3.2 ! 2009-06 (G. Madec, S. Masson) TKE restart compatible with key_cpl + !! ! + cleaning of the parameters + bugs correction + !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability + !! 4.0 ! 2017-04 (G. Madec) remove CPP ddm key & avm at t-point only + !! - ! 2017-05 (G. Madec) add top/bottom friction as boundary condition + !! 4.2 ! 2020-12 (G. Madec, E. Clementi) add wave coupling + ! ! following Couvelard et al., 2019 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_tke : update momentum and tracer Kz from a tke scheme + !! tke_tke : tke time stepping: update tke at now time step (en) + !! tke_avn : compute mixing length scale and deduce avm and avt + !! zdf_tke_init : initialization, namelist read, and parameters control + !! tke_rst : read/write tke restart in ocean restart file + !!---------------------------------------------------------------------- + USE oce ! ocean: dynamics and active tracers variables + USE phycst ! physical constants + USE dom_oce ! domain: ocean + USE domvvl ! domain: variable volume layer + USE sbc_oce ! surface boundary condition: ocean + USE zdfdrg ! vertical physics: top/bottom drag coef. + USE zdfmxl ! vertical physics: mixed layer +#if defined key_si3 + USE ice, ONLY: hm_i, h_i +#endif +#if defined key_cice + USE sbc_ice, ONLY: h_i +#endif + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! MPP library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE prtctl ! Print control + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + USE sbcwave ! Surface boundary waves + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_tke ! routine called in step module + PUBLIC zdf_tke_init ! routine called in opa module + PUBLIC tke_rst ! routine called in step module + + ! !!** Namelist namzdf_tke ** + LOGICAL :: ln_mxl0 ! mixing length scale surface value as function of wind stress or not + LOGICAL :: ln_mxhsw ! mixing length scale surface value as a fonction of wave height + INTEGER :: nn_mxlice ! type of scaling under sea-ice (=0/1/2/3) + REAL(wp) :: rn_mxlice ! ice thickness value when scaling under sea-ice + INTEGER :: nn_mxl ! type of mixing length (=0/1/2/3) + REAL(wp) :: rn_mxl0 ! surface min value of mixing length (kappa*z_o=0.4*0.1 m) [m] + INTEGER :: nn_pdl ! Prandtl number or not (ratio avt/avm) (=0/1) + REAL(wp) :: rn_ediff ! coefficient for avt: avt=rn_ediff*mxl*sqrt(e) + REAL(wp) :: rn_ediss ! coefficient of the Kolmogoroff dissipation + REAL(wp) :: rn_ebb ! coefficient of the surface input of tke + REAL(wp) :: rn_emin ! minimum value of tke [m2/s2] + REAL(wp) :: rn_emin0 ! surface minimum value of tke [m2/s2] + REAL(wp) :: rn_bshear ! background shear (>0) currently a numerical threshold (do not change it) + INTEGER :: nn_etau ! type of depth penetration of surface tke (=0/1/2/3) + INTEGER :: nn_htau ! type of tke profile of penetration (=0/1) + INTEGER :: nn_bc_surf! surface condition (0/1=Dir/Neum) ! Only applicable for wave coupling + INTEGER :: nn_bc_bot ! surface condition (0/1=Dir/Neum) ! Only applicable for wave coupling + REAL(wp) :: rn_efr ! fraction of TKE surface value which penetrates in the ocean + LOGICAL :: ln_lc ! Langmuir cells (LC) as a source term of TKE or not + REAL(wp) :: rn_lc ! coef to compute vertical velocity of Langmuir cells + INTEGER :: nn_eice ! attenutaion of langmuir & surface wave breaking under ice (=0/1/2/3) + + REAL(wp) :: ri_cri ! critic Richardson number (deduced from rn_ediff and rn_ediss values) + REAL(wp) :: rmxl_min ! minimum mixing length value (deduced from rn_ediff and rn_emin values) [m] + REAL(wp) :: rhftau_add = 1.e-3_wp ! add offset applied to HF part of taum (nn_etau=3) + REAL(wp) :: rhftau_scl = 1.0_wp ! scale factor applied to HF part of taum (nn_etau=3) + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htau ! depth of tke penetration (nn_htau) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dissl ! now mixing lenght of dissipation + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: apdlr ! now mixing lenght of dissipation + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: zdftke.F90 15071 2021-07-02 13:12:08Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_tke_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_tke_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( htau(jpi,jpj) , dissl(jpi,jpj,jpk) , apdlr(jpi,jpj,jpk) , STAT= zdf_tke_alloc ) + ! + CALL mpp_sum ( 'zdftke', zdf_tke_alloc ) + IF( zdf_tke_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_tke_alloc: failed to allocate arrays' ) + ! + END FUNCTION zdf_tke_alloc + + + SUBROUTINE zdf_tke( kt, Kbb, Kmm, p_sh2, p_avm, p_avt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_tke *** + !! + !! ** Purpose : Compute the vertical eddy viscosity and diffusivity + !! coefficients using a turbulent closure scheme (TKE). + !! + !! ** Method : The time evolution of the turbulent kinetic energy (tke) + !! is computed from a prognostic equation : + !! d(en)/dt = avm (d(u)/dz)**2 ! shear production + !! + d( avm d(en)/dz )/dz ! diffusion of tke + !! + avt N^2 ! stratif. destruc. + !! - rn_ediss / emxl en**(2/3) ! Kolmogoroff dissipation + !! with the boundary conditions: + !! surface: en = max( rn_emin0, rn_ebb * taum ) + !! bottom : en = rn_emin + !! The associated critical Richardson number is: ri_cri = 2/(2+rn_ediss/rn_ediff) + !! + !! The now Turbulent kinetic energy is computed using the following + !! time stepping: implicit for vertical diffusion term, linearized semi + !! implicit for kolmogoroff dissipation term, and explicit forward for + !! both buoyancy and shear production terms. Therefore a tridiagonal + !! linear system is solved. Note that buoyancy and shear terms are + !! discretized in a energy conserving form (Bruchard 2002). + !! + !! The dissipative and mixing length scale are computed from en and + !! the stratification (see tke_avn) + !! + !! The now vertical eddy vicosity and diffusivity coefficients are + !! given by: + !! avm = max( avtb, rn_ediff * zmxlm * en^1/2 ) + !! avt = max( avmb, pdl * avm ) + !! eav = max( avmb, avm ) + !! where pdl, the inverse of the Prandtl number is 1 if nn_pdl=0 and + !! given by an empirical funtion of the localRichardson number if nn_pdl=1 + !! + !! ** Action : compute en (now turbulent kinetic energy) + !! update avt, avm (before vertical eddy coef.) + !! + !! References : Gaspar et al., JGR, 1990, + !! Blanke and Delecluse, JPO, 1991 + !! Mellor and Blumberg, JPO 2004 + !! Axell, JGR, 2002 + !! Bruchard OM 2002 + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + !!---------------------------------------------------------------------- + ! + CALL tke_tke( Kbb, Kmm, p_sh2, p_avm, p_avt ) ! now tke (en) + ! + CALL tke_avn( Kbb, Kmm, p_avm, p_avt ) ! now avt, avm, dissl + ! + END SUBROUTINE zdf_tke + + + SUBROUTINE tke_tke( Kbb, Kmm, p_sh2, p_avm, p_avt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tke_tke *** + !! + !! ** Purpose : Compute the now Turbulente Kinetic Energy (TKE) + !! + !! ** Method : - TKE surface boundary condition + !! - source term due to Langmuir cells (Axell JGR 2002) (ln_lc=T) + !! - source term due to shear (= Kz dz[Ub] * dz[Un] ) + !! - Now TKE : resolution of the TKE equation by inverting + !! a tridiagonal linear system by a "methode de chasse" + !! - increase TKE due to surface and internal wave breaking + !! NB: when sea-ice is present, both LC parameterization + !! and TKE penetration are turned off when the ice fraction + !! is smaller than 0.25 + !! + !! ** Action : - en : now turbulent kinetic energy) + !! --------------------------------------------------------------------- + USE zdf_oce , ONLY : en ! ocean vertical physics + !! + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in ) :: p_sh2 ! shear production term + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop arguments + REAL(wp) :: zetop, zebot, zmsku, zmskv ! local scalars + REAL(wp) :: zrhoa = 1.22 ! Air density kg/m3 + REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient + REAL(wp) :: zbbrau, zbbirau, zri ! local scalars + REAL(wp) :: zfact1, zfact2, zfact3 ! - - + REAL(wp) :: ztx2 , zty2 , zcof ! - - + REAL(wp) :: ztau , zdif ! - - + REAL(wp) :: zus , zwlc , zind ! - - + REAL(wp) :: zzd_up, zzd_lw ! - - + REAL(wp) :: ztaui, ztauj, z1_norm + INTEGER , DIMENSION(A2D(nn_hls)) :: imlc + REAL(wp), DIMENSION(A2D(nn_hls)) :: zice_fra, zhlc, zus3, zWlc2 + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpelc, zdiag, zd_up, zd_lw + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztmp ! for diags + !!-------------------------------------------------------------------- + ! + zbbrau = rn_ebb / rho0 ! Local constant initialisation + zbbirau = 3.75_wp / rho0 + zfact1 = -.5_wp * rn_Dt + zfact2 = 1.5_wp * rn_Dt * rn_ediss + zfact3 = 0.5_wp * rn_ediss + ! + zpelc(:,:,:) = 0._wp ! need to be initialised in case ln_lc is not used + ! + ! ice fraction considered for attenuation of langmuir & wave breaking + SELECT CASE ( nn_eice ) + CASE( 0 ) ; zice_fra(:,:) = 0._wp + CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(A2D(nn_hls)) * 10._wp ) + CASE( 2 ) ; zice_fra(:,:) = fr_i(A2D(nn_hls)) + CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(A2D(nn_hls)) , 1._wp ) + END SELECT + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Surface/top/bottom boundary condition on tke + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) + zdiag(ji,jj,1) = 1._wp/en(ji,jj,1) + zd_lw(ji,jj,1) = 1._wp + zd_up(ji,jj,1) = 0._wp + END_2D + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Bottom boundary condition on tke + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + ! en(bot) = (ebb0/rho0)*0.5*sqrt(u_botfr^2+v_botfr^2) (min value rn_emin) + ! where ebb0 does not includes surface wave enhancement (i.e. ebb0=3.75) + ! Note that stress averaged is done using an wet-only calculation of u and v at t-point like in zdfsh2 + ! + IF( .NOT.ln_drg_OFF ) THEN !== friction used as top/bottom boundary condition on TKE + ! + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! bottom friction + zmsku = ( 2. - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) + zmskv = ( 2. - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) + ! ! where 0.001875 = (rn_ebb0/rho0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0) + zebot = - 0.001875_wp * rCdU_bot(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2 & + & + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2 ) + en(ji,jj,mbkt(ji,jj)+1) = MAX( zebot, rn_emin ) * ssmask(ji,jj) + END_2D + IF( ln_isfcav ) THEN + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! top friction + zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) + zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) + ! ! where 0.001875 = (rn_ebb0/rho0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0) + zetop = - 0.001875_wp * rCdU_top(ji,jj) * SQRT( ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2 & + & + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2 ) + ! (1._wp - tmask(ji,jj,1)) * ssmask(ji,jj) = 1 where ice shelves are present + en(ji,jj,mikt(ji,jj)) = en(ji,jj,1) * tmask(ji,jj,1) & + & + MAX( zetop, rn_emin ) * (1._wp - tmask(ji,jj,1)) * ssmask(ji,jj) + END_2D + ENDIF + ! + ENDIF + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_lc ) THEN ! Langmuir circulation source term added to tke (Axell JGR 2002) + ! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! + ! !* Langmuir velocity scale + ! + IF ( cpl_sdrftx ) THEN ! Surface Stokes Drift available + ! ! Craik-Leibovich velocity scale Wlc = ( u* u_s )^1/2 with u* = (taum/rho0)^1/2 + ! ! associated kinetic energy : 1/2 (Wlc)^2 = u* u_s + ! ! more precisely, it is the dot product that must be used : + ! ! 1/2 (W_lc)^2 = MAX( u* u_s + v* v_s , 0 ) only the positive part +!!gm ! PS: currently we don't have neither the 2 stress components at t-point !nor the angle between u* and u_s +!!gm ! so we will overestimate the LC velocity.... !!gm I will do the work if !LC have an effect ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) +!!XC zWlc2(ji,jj) = 0.5_wp * SQRT( taum(ji,jj) * r1_rho0 * ( ut0sd(ji,jj)**2 +vt0sd(ji,jj)**2 ) ) + zWlc2(ji,jj) = 0.5_wp * ( ut0sd(ji,jj)**2 +vt0sd(ji,jj)**2 ) + END_2D +! +! Projection of Stokes drift in the wind stress direction +! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ztaui = 0.5_wp * ( utau(ji,jj) + utau(ji-1,jj) ) + ztauj = 0.5_wp * ( vtau(ji,jj) + vtau(ji,jj-1) ) + z1_norm = 1._wp / MAX( SQRT(ztaui*ztaui+ztauj*ztauj), 1.e-12 ) * tmask(ji,jj,1) + zWlc2(ji,jj) = 0.5_wp * z1_norm * ( MAX( ut0sd(ji,jj)*ztaui + vt0sd(ji,jj)*ztauj, 0._wp ) )**2 + END_2D + ELSE ! Surface Stokes drift deduced from surface stress + ! ! Wlc = u_s with u_s = 0.016*U_10m, the surface stokes drift (Axell 2002, Eq.44) + ! ! using |tau| = rho_air Cd |U_10m|^2 , it comes: + ! ! Wlc = 0.016 * [|tau|/(rho_air Cdrag) ]^1/2 and thus: + ! ! 1/2 Wlc^2 = 0.5 * 0.016 * 0.016 |tau| /( rho_air Cdrag ) + zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) ! to convert stress in 10m wind using a constant drag + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zWlc2(ji,jj) = zcof * taum(ji,jj) + END_2D + ! + ENDIF + ! + ! !* Depth of the LC circulation (Axell 2002, Eq.47) + ! !- LHS of Eq.47 + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zpelc(ji,jj,1) = MAX( rn2b(ji,jj,1), 0._wp ) * gdepw(ji,jj,1,Kmm) * e3w(ji,jj,1,Kmm) + END_2D + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpk ) + zpelc(ji,jj,jk) = zpelc(ji,jj,jk-1) + & + & MAX( rn2b(ji,jj,jk), 0._wp ) * gdepw(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) + END_3D + ! + ! !- compare LHS to RHS of Eq.47 + imlc(:,:) = mbkt(A2D(nn_hls)) + 1 ! Initialization to the number of w ocean point (=2 over land) + DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 ) + IF( zpelc(ji,jj,jk) > zWlc2(ji,jj) ) imlc(ji,jj) = jk + END_3D + ! ! finite LC depth + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zhlc(ji,jj) = gdepw(ji,jj,imlc(ji,jj),Kmm) + END_2D + ! + zcof = 0.016 / SQRT( zrhoa * zcdrag ) + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zus = SQRT( 2. * zWlc2(ji,jj) ) ! Stokes drift + zus3(ji,jj) = MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok + END_2D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !* TKE Langmuir circulation source term added to en + IF ( zus3(ji,jj) /= 0._wp ) THEN + IF ( gdepw(ji,jj,jk,Kmm) - zhlc(ji,jj) < 0 .AND. wmask(ji,jj,jk) /= 0. ) THEN + ! ! vertical velocity due to LC + zwlc = rn_lc * SIN( rpi * gdepw(ji,jj,jk,Kmm) / zhlc(ji,jj) ) + ! ! TKE Langmuir circulation source term + en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * zus3(ji,jj) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) + ENDIF + ENDIF + END_3D + ! + ENDIF + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Now Turbulent kinetic energy (output in en) + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Resolution of a tridiagonal linear system by a "methode de chasse" + ! ! computation from level 2 to jpkm1 (e(1) already computed and e(jpk)=0 ). + ! ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal + ! + IF( nn_pdl == 1 ) THEN !* Prandtl number = F( Ri ) + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + ! ! local Richardson number + IF (rn2b(ji,jj,jk) <= 0.0_wp) then + zri = 0.0_wp + ELSE + zri = rn2b(ji,jj,jk) * p_avm(ji,jj,jk) / ( p_sh2(ji,jj,jk) + rn_bshear ) + ENDIF + ! ! inverse of Prandtl number + apdlr(ji,jj,jk) = MAX( 0.1_wp, ri_cri / MAX( ri_cri , zri ) ) + END_3D + ENDIF + ! + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) !* Matrix and right hand side in en + zcof = zfact1 * tmask(ji,jj,jk) + ! ! A minimum of 2.e-5 m2/s is imposed on TKE vertical + ! ! eddy coefficient (ensure numerical stability) + zzd_up = zcof * MAX( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) , 2.e-5_wp ) & ! upper diagonal + & / ( e3t(ji,jj,jk ,Kmm) * e3w(ji,jj,jk ,Kmm) ) + zzd_lw = zcof * MAX( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) , 2.e-5_wp ) & ! lower diagonal + & / ( e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk ,Kmm) ) + ! + zd_up(ji,jj,jk) = zzd_up ! Matrix (zdiag, zd_up, zd_lw) + zd_lw(ji,jj,jk) = zzd_lw + zdiag(ji,jj,jk) = 1._wp - zzd_lw - zzd_up + zfact2 * dissl(ji,jj,jk) * wmask(ji,jj,jk) + ! + ! ! right hand side in en + en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * ( p_sh2(ji,jj,jk) & ! shear + & - p_avt(ji,jj,jk) * rn2(ji,jj,jk) & ! stratification + & + zfact3 * dissl(ji,jj,jk) * en(ji,jj,jk) & ! dissipation + & ) * wmask(ji,jj,jk) + END_3D + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Surface boundary condition on tke if + ! ! coupling with waves + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + IF ( cpl_phioc .and. ln_phioc ) THEN + SELECT CASE (nn_bc_surf) ! Boundary Condition using surface TKE flux from waves + + CASE ( 0 ) ! Dirichlet BC + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! en(1) = rn_ebb taum / rho0 (min value rn_emin0) + IF ( phioc(ji,jj) < 0 ) phioc(ji,jj) = 0._wp + en(ji,jj,1) = MAX( rn_emin0, .5 * ( 15.8 * phioc(ji,jj) / rho0 )**(2./3.) ) * tmask(ji,jj,1) + zdiag(ji,jj,1) = 1._wp/en(ji,jj,1) ! choose to keep coherence with former estimation of + END_2D + + CASE ( 1 ) ! Neumann BC + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + IF ( phioc(ji,jj) < 0 ) phioc(ji,jj) = 0._wp + en(ji,jj,2) = en(ji,jj,2) + ( rn_Dt * phioc(ji,jj) / rho0 ) /e3w(ji,jj,2,Kmm) + en(ji,jj,1) = en(ji,jj,2) + (2 * e3t(ji,jj,1,Kmm) * phioc(ji,jj)/rho0) / ( p_avm(ji,jj,1) + p_avm(ji,jj,2) ) + zdiag(ji,jj,2) = zdiag(ji,jj,2) + zd_lw(ji,jj,2) + zdiag(ji,jj,1) = 1._wp + zd_lw(ji,jj,2) = 0._wp + END_2D + + END SELECT + + ENDIF + ! + ! !* Matrix inversion from level 2 (tke prescribed at level 1) + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 + zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) + END_3D +!XC : commented to allow for neumann boundary condition +! DO_2D( 0, 0, 0, 0 ) +! zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1) ! Surface boudary conditions on tke +! END_2D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1) + END_3D + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk + en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) + END_2D + DO_3DS_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpk-2, 2, -1 ) + en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) + END_3D + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! set the minimum value of tke + en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk) + END_3D + ! + ! Kolmogorov energy of dissipation (W/kg) + ! ediss = Ce*sqrt(en)/L*en + ! dissl = sqrt(en)/L + IF( iom_use('ediss_k') ) THEN + ALLOCATE( ztmp(A2D(nn_hls),jpk) ) + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + ztmp(ji,jj,jk) = zfact3 * dissl(ji,jj,jk) * en(ji,jj,jk) * wmask(ji,jj,jk) + END_3D + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + ztmp(ji,jj,jpk) = 0._wp + END_2D + CALL iom_put( 'ediss_k', ztmp ) + DEALLOCATE( ztmp ) + ENDIF + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! TKE due to surface and internal wave breaking + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +!!gm BUG : in the exp remove the depth of ssh !!! +!!gm i.e. use gde3w in argument (gdepw(:,:,:,Kmm)) + ! + ! penetration is partly switched off below sea-ice if nn_eice/=0 + ! + IF( nn_etau == 1 ) THEN !* penetration below the mixed layer (rn_efr fraction) + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) ) & + & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) + END_3D + ELSEIF( nn_etau == 2 ) THEN !* act only at the base of the mixed layer (jk=nmln) (rn_efr fraction) + DO_2D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + jk = nmln(ji,jj) + en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) ) & + & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) + END_2D + ELSEIF( nn_etau == 3 ) THEN !* penetration belox the mixed layer (HF variability) + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + ztx2 = utau(ji-1,jj ) + utau(ji,jj) + zty2 = vtau(ji ,jj-1) + vtau(ji,jj) + ztau = 0.5_wp * SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1) ! module of the mean stress + zdif = taum(ji,jj) - ztau ! mean of modulus - modulus of the mean + zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add ) ! apply some modifications... + en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) ) & + & * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) + END_3D + ENDIF + ! + END SUBROUTINE tke_tke + + + SUBROUTINE tke_avn( Kbb, Kmm, p_avm, p_avt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tke_avn *** + !! + !! ** Purpose : Compute the vertical eddy viscosity and diffusivity + !! + !! ** Method : At this stage, en, the now TKE, is known (computed in + !! the tke_tke routine). First, the now mixing lenth is + !! computed from en and the strafification (N^2), then the mixings + !! coefficients are computed. + !! - Mixing length : a first evaluation of the mixing lengh + !! scales is: + !! mxl = sqrt(2*en) / N + !! where N is the brunt-vaisala frequency, with a minimum value set + !! to rmxl_min (rn_mxl0) in the interior (surface) ocean. + !! The mixing and dissipative length scale are bound as follow : + !! nn_mxl=0 : mxl bounded by the distance to surface and bottom. + !! zmxld = zmxlm = mxl + !! nn_mxl=1 : mxl bounded by the e3w and zmxld = zmxlm = mxl + !! nn_mxl=2 : mxl bounded such that the vertical derivative of mxl is + !! less than 1 (|d/dz(mxl)|<1) and zmxld = zmxlm = mxl + !! nn_mxl=3 : mxl is bounded from the surface to the bottom usings + !! |d/dz(xml)|<1 to obtain lup, and from the bottom to + !! the surface to obtain ldown. the resulting length + !! scales are: + !! zmxld = sqrt( lup * ldown ) + !! zmxlm = min ( lup , ldown ) + !! - Vertical eddy viscosity and diffusivity: + !! avm = max( avtb, rn_ediff * zmxlm * en^1/2 ) + !! avt = max( avmb, pdlr * avm ) + !! with pdlr=1 if nn_pdl=0, pdlr=1/pdl=F(Ri) otherwise. + !! + !! ** Action : - avt, avm : now vertical eddy diffusivity and viscosity (w-point) + !!---------------------------------------------------------------------- + USE zdf_oce , ONLY : en, avtb, avmb, avtb_2d ! ocean vertical physics + !! + INTEGER , INTENT(in ) :: Kbb, Kmm ! ocean time level indices + REAL(wp), DIMENSION(:,:,:), INTENT( out) :: p_avm, p_avt ! vertical eddy viscosity & diffusivity (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zrn2, zraug, zcoef, zav ! local scalars + REAL(wp) :: zdku, zdkv, zsqen ! - - + REAL(wp) :: zemxl, zemlm, zemlp, zmaxice ! - - + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zmxlm, zmxld ! 3D workspace + !!-------------------------------------------------------------------- + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Mixing length + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + ! !* Buoyancy length scale: l=sqrt(2*e/n**2) + ! + ! initialisation of interior minimum value (avoid a 2d loop with mikt) + zmxlm(:,:,:) = rmxl_min + zmxld(:,:,:) = rmxl_min + ! + IF(ln_sdw .AND. ln_mxhsw) THEN + zmxlm(:,:,1)= vkarmn * MAX ( 1.6 * hsw(:,:) , 0.02 ) ! surface mixing length = F(wave height) + ! from terray et al 1999 and mellor and blumberg 2004 it should be 0.85 and not 1.6 + zcoef = vkarmn * ( (rn_ediff*rn_ediss)**0.25 ) / rn_ediff + zmxlm(:,:,1)= zcoef * MAX ( 1.6 * hsw(:,:) , 0.02 ) ! surface mixing length = F(wave height) + ELSE + ! + IF( ln_mxl0 ) THEN ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rho0*g) + ! + zraug = vkarmn * 2.e5_wp / ( rho0 * grav ) +#if ! defined key_si3 && ! defined key_cice + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! No sea-ice + zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) + END_2D +#else + SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice + ! + CASE( 0 ) ! No scaling under sea-ice + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) + END_2D + ! + CASE( 1 ) ! scaling with constant sea-ice thickness + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & + & fr_i(ji,jj) * rn_mxlice ) * tmask(ji,jj,1) + END_2D + ! + CASE( 2 ) ! scaling with mean sea-ice thickness + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) +#if defined key_si3 + zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & + & fr_i(ji,jj) * hm_i(ji,jj) * 2._wp ) * tmask(ji,jj,1) +#elif defined key_cice + zmaxice = MAXVAL( h_i(ji,jj,:) ) + zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & + & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) +#endif + END_2D + ! + CASE( 3 ) ! scaling with max sea-ice thickness + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zmaxice = MAXVAL( h_i(ji,jj,:) ) + zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & + & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) + END_2D + ! + END SELECT +#endif + ! + DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) + zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) ) + END_2D + ! + ELSE + zmxlm(:,:,1) = rn_mxl0 + ENDIF + ENDIF + ! + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + zrn2 = MAX( rn2(ji,jj,jk), rsmall ) + zmxlm(ji,jj,jk) = MAX( rmxl_min, SQRT( 2._wp * en(ji,jj,jk) / zrn2 ) ) + END_3D + ! + ! !* Physical limits for the mixing length + ! + zmxld(:,:, 1 ) = zmxlm(:,:,1) ! surface set to the minimum value + zmxld(:,:,jpk) = rmxl_min ! last level set to the minimum value + ! + SELECT CASE ( nn_mxl ) + ! + !!gm Not sure of that coding for ISF.... + ! where wmask = 0 set zmxlm == e3w(:,:,:,Kmm) + CASE ( 0 ) ! bounded by the distance to surface and bottom + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + zemxl = MIN( gdepw(ji,jj,jk,Kmm) - gdepw(ji,jj,mikt(ji,jj),Kmm), zmxlm(ji,jj,jk), & + & gdepw(ji,jj,mbkt(ji,jj)+1,Kmm) - gdepw(ji,jj,jk,Kmm) ) + ! wmask prevent zmxlm = 0 if jk = mikt(ji,jj) + zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) & + & + MIN( zmxlm(ji,jj,jk) , e3w(ji,jj,jk,Kmm) ) * (1 - wmask(ji,jj,jk)) + zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) & + & + MIN( zmxlm(ji,jj,jk) , e3w(ji,jj,jk,Kmm) ) * (1 - wmask(ji,jj,jk)) + END_3D + ! + CASE ( 1 ) ! bounded by the vertical scale factor + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + zemxl = MIN( e3w(ji,jj,jk,Kmm), zmxlm(ji,jj,jk) ) + zmxlm(ji,jj,jk) = zemxl + zmxld(ji,jj,jk) = zemxl + END_3D + ! + CASE ( 2 ) ! |dk[xml]| bounded by e3t : + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! from the surface to the bottom : + zmxlm(ji,jj,jk) = & + & MIN( zmxlm(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) + END_3D + DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 ) ! from the bottom to the surface : + zemxl = MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) ) + zmxlm(ji,jj,jk) = zemxl + zmxld(ji,jj,jk) = zemxl + END_3D + ! + CASE ( 3 ) ! lup and ldown, |dk[xml]| bounded by e3t : + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! from the surface to the bottom : lup + zmxld(ji,jj,jk) = & + & MIN( zmxld(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) + END_3D + DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpkm1, 2, -1 ) ! from the bottom to the surface : ldown + zmxlm(ji,jj,jk) = & + & MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) ) + END_3D + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + zemlm = MIN ( zmxld(ji,jj,jk), zmxlm(ji,jj,jk) ) + zemlp = SQRT( zmxld(ji,jj,jk) * zmxlm(ji,jj,jk) ) + zmxlm(ji,jj,jk) = zemlm + zmxld(ji,jj,jk) = zemlp + END_3D + ! + END SELECT + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Vertical eddy viscosity and diffusivity (avm and avt) + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) !* vertical eddy viscosity & diffivity at w-points + zsqen = SQRT( en(ji,jj,jk) ) + zav = rn_ediff * zmxlm(ji,jj,jk) * zsqen + p_avm(ji,jj,jk) = MAX( zav, avmb(jk) ) * wmask(ji,jj,jk) + p_avt(ji,jj,jk) = MAX( zav, avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) + dissl(ji,jj,jk) = zsqen / zmxld(ji,jj,jk) + END_3D + ! + ! + IF( nn_pdl == 1 ) THEN !* Prandtl number case: update avt + DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) + p_avt(ji,jj,jk) = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) + END_3D + ENDIF + ! + IF(sn_cfctl%l_prtctl) THEN + CALL prt_ctl( tab3d_1=REAL(en ,dp) , clinfo1=' tke - e: ', tab3d_2=REAL(p_avt,dp), clinfo2=' t: ' ) + CALL prt_ctl( tab3d_1=REAL(p_avm,dp), clinfo1=' tke - m: ' ) + ENDIF + ! + END SUBROUTINE tke_avn + + + SUBROUTINE zdf_tke_init( Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_tke_init *** + !! + !! ** Purpose : Initialization of the vertical eddy diffivity and + !! viscosity when using a tke turbulent closure scheme + !! + !! ** Method : Read the namzdf_tke namelist and check the parameters + !! called at the first timestep (nit000) + !! + !! ** input : Namlist namzdf_tke + !! + !! ** Action : Increase by 1 the nstop flag is setting problem encounter + !!---------------------------------------------------------------------- + USE zdf_oce , ONLY : ln_zdfiwm ! Internal Wave Mixing flag + !! + INTEGER, INTENT(in) :: Kmm ! time level index + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ios + !! + NAMELIST/namzdf_tke/ rn_ediff, rn_ediss , rn_ebb , rn_emin , & + & rn_emin0, rn_bshear, nn_mxl , ln_mxl0 , & + & rn_mxl0 , nn_mxlice, rn_mxlice, & + & nn_pdl , ln_lc , rn_lc , & + & nn_etau , nn_htau , rn_efr , nn_eice , & + & nn_bc_surf, nn_bc_bot, ln_mxhsw + !!---------------------------------------------------------------------- + ! + READ ( numnam_ref, namzdf_tke, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tke in reference namelist' ) + + READ ( numnam_cfg, namzdf_tke, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namzdf_tke in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf_tke ) + ! + ri_cri = 2._wp / ( 2._wp + rn_ediss / rn_ediff ) ! resulting critical Richardson number + ! + IF(lwp) THEN !* Control print + WRITE(numout,*) + WRITE(numout,*) 'zdf_tke_init : tke turbulent closure scheme - initialisation' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namzdf_tke : set tke mixing parameters' + WRITE(numout,*) ' coef. to compute avt rn_ediff = ', rn_ediff + WRITE(numout,*) ' Kolmogoroff dissipation coef. rn_ediss = ', rn_ediss + WRITE(numout,*) ' tke surface input coef. rn_ebb = ', rn_ebb + WRITE(numout,*) ' minimum value of tke rn_emin = ', rn_emin + WRITE(numout,*) ' surface minimum value of tke rn_emin0 = ', rn_emin0 + WRITE(numout,*) ' prandl number flag nn_pdl = ', nn_pdl + WRITE(numout,*) ' background shear (>0) rn_bshear = ', rn_bshear + WRITE(numout,*) ' mixing length type nn_mxl = ', nn_mxl + WRITE(numout,*) ' surface mixing length = F(stress) or not ln_mxl0 = ', ln_mxl0 + WRITE(numout,*) ' surface mixing length minimum value rn_mxl0 = ', rn_mxl0 + IF( ln_mxl0 ) THEN + WRITE(numout,*) ' type of scaling under sea-ice nn_mxlice = ', nn_mxlice + IF( nn_mxlice == 1 ) & + WRITE(numout,*) ' ice thickness when scaling under sea-ice rn_mxlice = ', rn_mxlice + SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice + CASE( 0 ) ; WRITE(numout,*) ' ==>>> No scaling under sea-ice' + CASE( 1 ) ; WRITE(numout,*) ' ==>>> scaling with constant sea-ice thickness' + CASE( 2 ) ; WRITE(numout,*) ' ==>>> scaling with mean sea-ice thickness' + CASE( 3 ) ; WRITE(numout,*) ' ==>>> scaling with max sea-ice thickness' + CASE DEFAULT + CALL ctl_stop( 'zdf_tke_init: wrong value for nn_mxlice, should be 0,1,2,3 or 4') + END SELECT + ENDIF + WRITE(numout,*) ' Langmuir cells parametrization ln_lc = ', ln_lc + WRITE(numout,*) ' coef to compute vertical velocity of LC rn_lc = ', rn_lc + IF ( cpl_phioc .and. ln_phioc ) THEN + SELECT CASE( nn_bc_surf) ! Type of scaling under sea-ice + CASE( 0 ) ; WRITE(numout,*) ' nn_bc_surf=0 ==>>> DIRICHLET SBC using surface TKE flux from waves' + CASE( 1 ) ; WRITE(numout,*) ' nn_bc_surf=1 ==>>> NEUMANN SBC using surface TKE flux from waves' + END SELECT + ENDIF + WRITE(numout,*) ' test param. to add tke induced by wind nn_etau = ', nn_etau + WRITE(numout,*) ' type of tke penetration profile nn_htau = ', nn_htau + WRITE(numout,*) ' fraction of TKE that penetrates rn_efr = ', rn_efr + WRITE(numout,*) ' langmuir & surface wave breaking under ice nn_eice = ', nn_eice + SELECT CASE( nn_eice ) + CASE( 0 ) ; WRITE(numout,*) ' ==>>> no impact of ice cover on langmuir & surface wave breaking' + CASE( 1 ) ; WRITE(numout,*) ' ==>>> weigthed by 1-TANH( fr_i(:,:) * 10 )' + CASE( 2 ) ; WRITE(numout,*) ' ==>>> weighted by 1-fr_i(:,:)' + CASE( 3 ) ; WRITE(numout,*) ' ==>>> weighted by 1-MIN( 1, 4 * fr_i(:,:) )' + CASE DEFAULT + CALL ctl_stop( 'zdf_tke_init: wrong value for nn_eice, should be 0,1,2, or 3') + END SELECT + WRITE(numout,*) + WRITE(numout,*) ' ==>>> critical Richardson nb with your parameters ri_cri = ', ri_cri + WRITE(numout,*) + ENDIF + ! + IF( ln_zdfiwm ) THEN ! Internal wave-driven mixing + rn_emin = 1.e-10_wp ! specific values of rn_emin & rmxl_min are used + rmxl_min = 1.e-03_wp ! associated avt minimum = molecular salt diffusivity (10^-9 m2/s) + IF(lwp) WRITE(numout,*) ' ==>>> Internal wave-driven mixing case: force rn_emin = 1.e-10 and rmxl_min = 1.e-3' + ELSE ! standard case : associated avt minimum = molecular viscosity (10^-6 m2/s) + rmxl_min = 1.e-6_wp / ( rn_ediff * SQRT( rn_emin ) ) ! resulting minimum length to recover molecular viscosity + IF(lwp) WRITE(numout,*) ' ==>>> minimum mixing length with your parameters rmxl_min = ', rmxl_min + ENDIF + ! + ! ! allocate tke arrays + IF( zdf_tke_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_tke_init : unable to allocate arrays' ) + ! + ! !* Check of some namelist values + IF( nn_mxl < 0 .OR. nn_mxl > 3 ) CALL ctl_stop( 'bad flag: nn_mxl is 0, 1, 2 or 3' ) + IF( nn_pdl < 0 .OR. nn_pdl > 1 ) CALL ctl_stop( 'bad flag: nn_pdl is 0 or 1' ) + IF( nn_htau < 0 .OR. nn_htau > 1 ) CALL ctl_stop( 'bad flag: nn_htau is 0 or 1' ) + IF( nn_etau == 3 .AND. .NOT. ln_cpl ) CALL ctl_stop( 'nn_etau == 3 : HF taum only known in coupled mode' ) + ! + IF( ln_mxl0 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> use a surface mixing length = F(stress) : set rn_mxl0 = rmxl_min' + rn_mxl0 = rmxl_min + ENDIF + ! !* depth of penetration of surface tke + IF( nn_etau /= 0 ) THEN + SELECT CASE( nn_htau ) ! Choice of the depth of penetration + CASE( 0 ) ! constant depth penetration (here 10 meters) + htau(:,:) = 10._wp + CASE( 1 ) ! F(latitude) : 0.5m to 30m poleward of 40 degrees + htau(:,:) = MAX( 0.5_wp, MIN( 30._wp, 45._wp* ABS( SIN( rpi/180._wp * gphit(:,:) ) ) ) ) + END SELECT + ENDIF + ! !* read or initialize all required files + CALL tke_rst( nit000, 'READ' ) ! (en, avt_k, avm_k, dissl) + ! + END SUBROUTINE zdf_tke_init + + + SUBROUTINE tke_rst( kt, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE tke_rst *** + !! + !! ** Purpose : Read or write TKE file (en) in restart file + !! + !! ** Method : use of IOM library + !! if the restart does not contain TKE, en is either + !! set to rn_emin or recomputed + !!---------------------------------------------------------------------- + USE zdf_oce , ONLY : en, avt_k, avm_k ! ocean vertical physics + !! + INTEGER , INTENT(in) :: kt ! ocean time-step + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + ! + INTEGER :: jit, jk ! dummy loop indices + INTEGER :: id1, id2, id3, id4 ! local integers + !!---------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise + ! ! --------------- + IF( ln_rstart ) THEN !* Read the restart file + id1 = iom_varid( numror, 'en' , ldstop = .FALSE. ) + id2 = iom_varid( numror, 'avt_k', ldstop = .FALSE. ) + id3 = iom_varid( numror, 'avm_k', ldstop = .FALSE. ) + id4 = iom_varid( numror, 'dissl', ldstop = .FALSE. ) + ! + IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN ! fields exist + CALL iom_get( numror, jpdom_auto, 'en' , en ) + CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k ) + CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k ) + CALL iom_get( numror, jpdom_auto, 'dissl', dissl ) + ELSE ! start TKE from rest + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> previous run without TKE scheme, set en to background values' + en (:,:,:) = rn_emin * wmask(:,:,:) + dissl(:,:,:) = 1.e-12_wp + ! avt_k, avm_k already set to the background value in zdf_phy_init + ENDIF + ELSE !* Start from rest + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> start from rest: set en to the background value' + en (:,:,:) = rn_emin * wmask(:,:,:) + dissl(:,:,:) = 1.e-12_wp + ! avt_k, avm_k already set to the background value in zdf_phy_init + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! ------------------- + IF(lwp) WRITE(numout,*) '---- tke_rst ----' + CALL iom_rstput( kt, nitrst, numrow, 'en' , en ) + CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k ) + CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k ) + CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl ) + ! + ENDIF + ! + END SUBROUTINE tke_rst + + !!====================================================================== +END MODULE zdftke diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/do_loop_substitute.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/do_loop_substitute.h90 new file mode 100644 index 0000000..3fed3c5 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/do_loop_substitute.h90 @@ -0,0 +1,80 @@ +#if defined show_comments +! These comments are not intended to be retained during preprocessing; i.e. do not define "show_comments" +!!---------------------------------------------------------------------- +!! NEMO/OCE 4.x , NEMO Consortium (2020) +!! Software governed by the CeCILL license (see ./LICENSE) +!!---------------------------------------------------------------------- +! This header file contains preprocessor definitions and macros used in the do-loop substitutions introduced +! between version 4.0 and 4.2. The primary aim of these macros is to assist in future applications of tiling +! to improve performance. This is expected to be achieved by alternative versions of these macros in selected +! locations. The initial introduction of these macros simply replaced all identifiable nested 2D- and 3D-loops +! with single line statements (and adjusts indenting accordingly). Do loops were identifiable if they comformed +! to either: +! DO jk = .... +! DO jj = .... DO jj = ... +! DO ji = .... DO ji = ... +! . OR . +! . . +! END DO END DO +! END DO END DO +! END DO +! and white-space variants thereof. +! +! Additionally, only loops with recognised jj and ji loops limits were treated; these were: +! Lower limits of 1, 2 or fs_2 +! Upper limits of jpi, jpim1 or fs_jpim1 (for ji) or jpj, jpjm1 or fs_jpjm1 (for jj) +! +! The macro naming convention takes the form: DO_2D( L, R, B, T) where: +! L is the Left offset from the PE's inner domain; +! R is the Right offset from the PE's inner domain +! B is the Bottom offset from the PE's inner domain; +! T is the Top offset from the PE's inner domain; +! +! So, given an inner domain of 2,jpim1 and 2,jpjm1, a typical example would replace: +! +! DO jj = 2, jpj +! DO ji = 1, jpim1 +! . +! . +! END DO +! END DO +! +! with: +! +! DO_2D( 1, 0, 0, 1 ) +! . +! . +! END_2D +! +! similar conventions apply to the 3D loops macros. jk loop limits are retained through macro arguments +! and are not restricted. This includes the possibility of strides for which an extra set of DO_3DS +! macros are defined. +! +! In the following definitions the inner PE domain is defined by start indices of (Nis0, Njs0) and end +! indices of (Nie0, Nje0) where: +! +! Nis0 = 1 + nn_hls Njs0 = 1 + nn_hls +! Nie0 = jpi - nn_hls Nje0 = jpj - nn_hls +! +#endif + +#define DO_2D(L, R, B, T) DO jj = ntsj-(B), ntej+(T) ; DO ji = ntsi-(L), ntei+(R) +#define DO_2D_OVR(L, R, B, T) DO_2D(L-(L+R)*nthl, R-(R+L)*nthr, B-(B+T)*nthb, T-(T+B)*ntht) +#define A1Di(H) ntsi-(H):ntei+(H) +#define A1Dj(H) ntsj-(H):ntej+(H) +#define A2D(H) A1Di(H),A1Dj(H) +#define A1Di_T(T) (ntsi-nn_hls-1)*T+1: +#define A1Dj_T(T) (ntsj-nn_hls-1)*T+1: +#define A2D_T(T) A1Di_T(T),A1Dj_T(T) +#define JPK : +#define JPTS : +#define KJPT : + +#define DO_3D(L, R, B, T, ks, ke) DO jk = ks, ke ; DO_2D(L, R, B, T) +#define DO_3D_OVR(L, R, B, T, ks, ke) DO jk = ks, ke ; DO_2D_OVR(L, R, B, T) + +#define DO_3DS(L, R, B, T, ks, ke, ki) DO jk = ks, ke, ki ; DO_2D(L, R, B, T) +#define DO_3DS_OVR(L, R, B, T, ks, ke, ki) DO jk = ks, ke, ki ; DO_2D_OVR(L, R, B, T) + +#define END_2D END DO ; END DO +#define END_3D END DO ; END DO ; END DO \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/exampl.mod b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/exampl.mod new file mode 100644 index 0000000000000000000000000000000000000000..47785acd6a14a04f6083637e49f1266e0e0e82ec GIT binary patch literal 365 zcmV-z0h0b7iwFP!000001I3eFPr@)1hVT0;&Rx3;%ov|umaSmp){%A-xmu>o#0Wwr z5`Vt!K43utB$}9Z>3P$0`aWHACgV^>k_uR@7oW=vc3J-Mx_$@T?qPV&vviv+;3Z$L zs)Qu_N>`g@b~C=U5g``*#YA;rAswFh9KhN)(Z;xl$^b(f2${;zWnL^9#Nu9rGtuHA zVj_Yd^kSd2%szO`^-;ACwjL@T$uN$%U_kvDovVaBPJQn3s6=Vzno(=R*wLDFp$B~! z6xsISGCJ2n!v^FLZ3%UZTFZj95>4ETOob*VVY-0dwuQf*9gXlnC8wk7Aoi<`Z1CbB zn3rdpk_nU0tx#%x9;F9(vrF^#Z)uRRXwXPT{XI${&U5rj4(Go)2AX4=KK%^_513Fq z6xRbedZkLm0rL`dN2d%CHxw$O+V8>(WBrCEGRK^#LFa3J{t46MhZeWNIW&$9LkoQa Lv7Ts=rvv~1pxmpV literal 0 HcmV?d00001 diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/lib_cray.f90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/lib_cray.f90 new file mode 100644 index 0000000..2aa7972 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/lib_cray.f90 @@ -0,0 +1,34 @@ +! Cray subroutines or functions used by OCE model and possibly +! not found on other platforms. +! +! check their existence +! +! wheneq + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: lib_cray.f90 14227 2020-12-20 11:57:00Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +SUBROUTINE lib_cray + WRITE(*,*) 'lib_cray: You should not have seen this print! error?' +END SUBROUTINE lib_cray + +SUBROUTINE wheneq ( i, x, j, t, ind, nn ) + IMPLICIT NONE + + INTEGER , INTENT ( in ) :: i, j + INTEGER , INTENT ( out ) :: nn + REAL , INTENT ( in ), DIMENSION (1+(i-1)*j) :: x + REAL , INTENT ( in ) :: t + INTEGER , INTENT ( out ), DIMENSION (1+(i-1)*j) :: ind + INTEGER :: n, k + nn = 0 + DO n = 1, i + k = 1 + (n-1) * j + IF ( x ( k) == t ) THEN + nn = nn + 1 + ind (nn) = k + ENDIF + END DO + +END SUBROUTINE wheneq \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/lib_fortran.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/lib_fortran.F90 new file mode 100644 index 0000000..299a7c0 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/lib_fortran.F90 @@ -0,0 +1,651 @@ +MODULE lib_fortran + !!====================================================================== + !! *** MODULE lib_fortran *** + !! Fortran utilities: includes some low levels fortran functionality + !!====================================================================== + !! History : 3.2 ! 2010-05 (M. Dunphy, R. Benshila) Original code + !! 3.4 ! 2013-06 (C. Rousset) add glob_min, glob_max + !! + 3d dim. of input is fexible (jpk, jpl...) + !! 4.0 ! 2016-06 (T. Lovato) double precision global sum by default + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! glob_sum : generic interface for global masked summation over + !! the interior domain for 1 or 2 2D or 3D arrays + !! it works only for T points + !! SIGN : generic interface for SIGN to overwrite f95 behaviour + !! of intrinsinc sign function + !!---------------------------------------------------------------------- + USE par_oce ! Ocean parameter + USE dom_oce ! ocean domain + USE in_out_manager ! I/O manager + USE lib_mpp ! distributed memory computing + USE lbclnk ! ocean lateral boundary conditions + + IMPLICIT NONE + PRIVATE + + PUBLIC glob_sum ! used in many places (masked with tmask_i = ssmask * (excludes halo+duplicated points (NP folding)) ) + PUBLIC local_sum ! used in trcrad, local operation before glob_sum_delay + PUBLIC sum3x3 ! used in trcrad, do a sum over 3x3 boxes + PUBLIC DDPDD ! also used in closea module + PUBLIC glob_min, glob_max + PUBLIC glob_sum_vec + PUBLIC glob_min_vec, glob_max_vec +#if defined key_nosignedzero + PUBLIC SIGN +#endif + + INTERFACE glob_sum + MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d + END INTERFACE + INTERFACE local_sum + MODULE PROCEDURE local_sum_2d, local_sum_3d + END INTERFACE + INTERFACE sum3x3 + MODULE PROCEDURE sum3x3_2d, sum3x3_3d + END INTERFACE + INTERFACE glob_min + MODULE PROCEDURE glob_min_2d, glob_min_3d + END INTERFACE + INTERFACE glob_max + MODULE PROCEDURE glob_max_2d, glob_max_3d + END INTERFACE + INTERFACE glob_sum_vec + MODULE PROCEDURE glob_sum_vec_3d, glob_sum_vec_4d + END INTERFACE + INTERFACE glob_min_vec + MODULE PROCEDURE glob_min_vec_3d, glob_min_vec_4d + END INTERFACE + INTERFACE glob_max_vec + MODULE PROCEDURE glob_max_vec_3d, glob_max_vec_4d + END INTERFACE + +#if defined key_nosignedzero + INTERFACE SIGN + MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D, & + & SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A, & + & SIGN_ARRAY_1D_B, SIGN_ARRAY_2D_B, SIGN_ARRAY_3D_B + END INTERFACE +#endif + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: lib_fortran.F90 15376 2021-10-14 20:41:23Z clem $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +# define GLOBSUM_CODE +# define DIM_1d +# include "lib_fortran_generic.h90" +# undef DIM_1d +# define DIM_2d +# include "lib_fortran_generic.h90" +# undef DIM_2d +# define DIM_3d +# include "lib_fortran_generic.h90" +# undef DIM_3d +# undef GLOBSUM_CODE + +# define GLOBMINMAX_CODE +# define DIM_2d +# define OPERATION_GLOBMIN +# include "lib_fortran_generic.h90" +# undef OPERATION_GLOBMIN +# define OPERATION_GLOBMAX +# include "lib_fortran_generic.h90" +# undef OPERATION_GLOBMAX +# undef DIM_2d +# define DIM_3d +# define OPERATION_GLOBMIN +# include "lib_fortran_generic.h90" +# undef OPERATION_GLOBMIN +# define OPERATION_GLOBMAX +# include "lib_fortran_generic.h90" +# undef OPERATION_GLOBMAX +# undef DIM_3 +# undef GLOBMINMAX_CODE + +! ! FUNCTION local_sum ! + + FUNCTION local_sum_2d( ptab ) + !!---------------------------------------------------------------------- + REAL(dp), DIMENSION(:,:), INTENT(in ) :: ptab ! array on which operation is applied + COMPLEX(dp) :: local_sum_2d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(dp) :: ztmp + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: ipi, ipj ! dimensions + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = SIZE(ptab,2) ! 2nd dimension + ! + ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + + DO jj = 1, ipj + DO ji = 1, ipi + ztmp = ptab(ji,jj) * tmask_i(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) + END DO + END DO + ! + local_sum_2d = ctmp + + END FUNCTION local_sum_2d + + FUNCTION local_sum_3d( ptab ) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptab ! array on which operation is applied + COMPLEX(dp) :: local_sum_3d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(dp) :: ztmp + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ipi, ipj, ipk ! dimensions + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = SIZE(ptab,2) ! 2nd dimension + ipk = SIZE(ptab,3) ! 3rd dimension + ! + ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + + DO jk = 1, ipk + DO jj = 1, ipj + DO ji = 1, ipi + ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) + END DO + END DO + END DO + ! + local_sum_3d = ctmp + + END FUNCTION local_sum_3d + +! ! FUNCTION sum3x3 ! + + SUBROUTINE sum3x3_2d( p2d ) + !!----------------------------------------------------------------------- + !! *** routine sum3x3_2d *** + !! + !! ** Purpose : sum over 3x3 boxes + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION (:,:), INTENT(inout) :: p2d + ! + INTEGER :: ji, ji2, jj, jj2 ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF( SIZE(p2d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the first dimension is not equal to jpi' ) + IF( SIZE(p2d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the second dimension is not equal to jpj' ) + ! + ! work over the whole domain (guarantees all internal cells are set when nn_hls=2) + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & ! 1st bottom left corner always at (Nis0-1, Njs0-1) + & MOD(mjg(jj), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box + ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box + jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box + IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain + p2d(ji:ji2,jj:jj2) = SUM(p2d(ji:ji2,jj:jj2)) + ENDIF + ENDIF + END_2D + CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) + ! no need for 2nd exchange when nn_hls > 1 + IF( nn_hls == 1 ) THEN + IF( mpiRnei(nn_hls,jpwe) > -1 ) THEN ! 1st column was changed during the previous call to lbc_lnk + IF( MOD(mig( 1), 3) == 1 ) & ! 1st box start at i=1 -> column 1 to 3 correctly computed locally + p2d( 1,:) = p2d( 2,:) ! previous lbc_lnk corrupted column 1 -> put it back using column 2 + IF( MOD(mig( 1), 3) == 2 ) & ! 1st box start at i=3 -> column 1 and 2 correctly computed on west neighbourh + p2d( 2,:) = p2d( 1,:) ! previous lbc_lnk fix column 1 -> copy it to column 2 + ENDIF + IF( mpiRnei(nn_hls,jpea) > -1 ) THEN + IF( MOD(mig(jpi-2), 3) == 1 ) p2d( jpi,:) = p2d(jpi-1,:) + IF( MOD(mig(jpi-2), 3) == 0 ) p2d(jpi-1,:) = p2d( jpi,:) + ENDIF + IF( mpiRnei(nn_hls,jpso) > -1 ) THEN + IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2) + IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1) + ENDIF + IF( mpiRnei(nn_hls,jpno) > -1 ) THEN + IF( MOD(mjg(jpj-2), 3) == 1 ) p2d(:, jpj) = p2d(:,jpj-1) + IF( MOD(mjg(jpj-2), 3) == 0 ) p2d(:,jpj-1) = p2d(:, jpj) + ENDIF + CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) + ENDIF + + END SUBROUTINE sum3x3_2d + + SUBROUTINE sum3x3_3d( p3d ) + !!----------------------------------------------------------------------- + !! *** routine sum3x3_3d *** + !! + !! ** Purpose : sum over 3x3 boxes + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION (:,:,:), INTENT(inout) :: p3d + ! + INTEGER :: ji, ji2, jj, jj2, jn ! dummy loop indices + INTEGER :: ipn ! Third dimension size + !!---------------------------------------------------------------------- + ! + IF( SIZE(p3d,1) /= jpi ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the first dimension is not equal to jpi' ) + IF( SIZE(p3d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_3d, the second dimension is not equal to jpj' ) + ipn = SIZE(p3d,3) + ! + DO jn = 1, ipn + ! + ! work over the whole domain (guarantees all internal cells are set when nn_hls=2) + ! + DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) + IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & ! 1st bottom left corner always at (Nis0-1, Njs0-1) + & MOD(mjg(jj), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box + ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box + jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1 ! upper position of the box + IF( ji2 <= jpi .AND. jj2 <= jpj ) THEN ! the box is fully included in the local mpi domain + p3d(ji:ji2,jj:jj2,jn) = SUM(p3d(ji:ji2,jj:jj2,jn)) + ENDIF + ENDIF + END_2D + END DO + CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) + ! no need for 2nd exchange when nn_hls > 1 + IF( nn_hls == 1 ) THEN + IF( mpiRnei(nn_hls,jpwe) > -1 ) THEN ! 1st column was changed during the previous call to lbc_lnk + IF( MOD(mig( 1), 3) == 1 ) & ! 1st box start at i=1 -> column 1 to 3 correctly computed locally + p3d( 1,:,:) = p3d( 2,:,:) ! previous lbc_lnk corrupted column 1 -> put it back using column 2 + IF( MOD(mig( 1), 3) == 2 ) & ! 1st box start at i=3 -> column 1 and 2 correctly computed on west neighbourh + p3d( 2,:,:) = p3d( 1,:,:) ! previous lbc_lnk fix column 1 -> copy it to column 2 + ENDIF + IF( mpiRnei(nn_hls,jpea) > -1 ) THEN + IF( MOD(mig(jpi-2), 3) == 1 ) p3d( jpi,:,:) = p3d(jpi-1,:,:) + IF( MOD(mig(jpi-2), 3) == 0 ) p3d(jpi-1,:,:) = p3d( jpi,:,:) + ENDIF + IF( mpiRnei(nn_hls,jpso) > -1 ) THEN + IF( MOD(mjg( 1), 3) == 1 ) p3d(:, 1,:) = p3d(:, 2,:) + IF( MOD(mjg( 1), 3) == 2 ) p3d(:, 2,:) = p3d(:, 1,:) + ENDIF + IF( mpiRnei(nn_hls,jpno) > -1 ) THEN + IF( MOD(mjg(jpj-2), 3) == 1 ) p3d(:, jpj,:) = p3d(:,jpj-1,:) + IF( MOD(mjg(jpj-2), 3) == 0 ) p3d(:,jpj-1,:) = p3d(:, jpj,:) + ENDIF + CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) + ENDIF + + END SUBROUTINE sum3x3_3d + + + FUNCTION glob_sum_vec_3d( cdname, ptab ) RESULT( ptmp ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine + REAL(dp), DIMENSION(:,:,:), INTENT(in) :: ptab ! array on which operation is applied + REAL(dp), DIMENSION(SIZE(ptab,3)) :: ptmp + ! + COMPLEX(dp), DIMENSION(:), ALLOCATABLE :: ctmp + REAL(dp) :: ztmp + INTEGER :: ji , jj , jk ! dummy loop indices + INTEGER :: ipi, ipj, ipk ! dimensions + INTEGER :: iis, iie, ijs, ije ! loop start and end + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = SIZE(ptab,2) ! 2nd dimension + ipk = SIZE(ptab,3) ! 3rd dimension + ! + IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values) + iis = Nis0 ; iie = Nie0 + ijs = Njs0 ; ije = Nje0 + ELSE ! I think we are never in this case... + iis = 1 ; iie = jpi + ijs = 1 ; ije = jpj + ENDIF + ! + ALLOCATE( ctmp(ipk) ) + ! + DO jk = 1, ipk + ctmp(jk) = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + DO jj = ijs, ije + DO ji = iis, iie + ztmp = ptab(ji,jj,jk) * tmask_i(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp(jk) ) + END DO + END DO + END DO + CALL mpp_sum( cdname, ctmp(:) ) ! sum over the global domain + ! + ptmp = REAL( ctmp(:), dp ) + ! + DEALLOCATE( ctmp ) + ! + END FUNCTION glob_sum_vec_3d + + FUNCTION glob_sum_vec_4d( cdname, ptab ) RESULT( ptmp ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine + REAL(dp), DIMENSION(:,:,:,:), INTENT(in) :: ptab ! array on which operation is applied + REAL(dp), DIMENSION(SIZE(ptab,4)) :: ptmp + ! + COMPLEX(dp), DIMENSION(:), ALLOCATABLE :: ctmp + REAL(dp) :: ztmp + INTEGER :: ji , jj , jk , jl ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl ! dimensions + INTEGER :: iis, iie, ijs, ije ! loop start and end + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = SIZE(ptab,2) ! 2nd dimension + ipk = SIZE(ptab,3) ! 3rd dimension + ipl = SIZE(ptab,4) ! 4th dimension + ! + IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values) + iis = Nis0 ; iie = Nie0 + ijs = Njs0 ; ije = Nje0 + ELSE ! I think we are never in this case... + iis = 1 ; iie = jpi + ijs = 1 ; ije = jpj + ENDIF + ! + ALLOCATE( ctmp(ipl) ) + ! + DO jl = 1, ipl + ctmp(jl) = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + DO jk = 1, ipk + DO jj = ijs, ije + DO ji = iis, iie + ztmp = ptab(ji,jj,jk,jl) * tmask_i(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp(jl) ) + END DO + END DO + END DO + END DO + CALL mpp_sum( cdname, ctmp(:) ) ! sum over the global domain + ! + ptmp = REAL( ctmp(:), dp ) + ! + DEALLOCATE( ctmp ) + ! + END FUNCTION glob_sum_vec_4d + + FUNCTION glob_min_vec_3d( cdname, ptab ) RESULT( ptmp ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptab ! array on which operation is applied + REAL(dp), DIMENSION(SIZE(ptab,3)) :: ptmp + ! + INTEGER :: jk ! dummy loop indice & dimension + INTEGER :: ipk ! dimension + !!----------------------------------------------------------------------- + ! + ipk = SIZE(ptab,3) + DO jk = 1, ipk + ptmp(jk) = MINVAL( ptab(:,:,jk) * tmask_i(:,:) ) + ENDDO + ! + CALL mpp_min( cdname, ptmp (:) ) + ! + END FUNCTION glob_min_vec_3d + + FUNCTION glob_min_vec_4d( cdname, ptab ) RESULT( ptmp ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine + REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: ptab ! array on which operation is applied + REAL(dp), DIMENSION(SIZE(ptab,4)) :: ptmp + ! + INTEGER :: jk , jl ! dummy loop indice & dimension + INTEGER :: ipk, ipl ! dimension + !!----------------------------------------------------------------------- + ! + ipk = SIZE(ptab,3) + ipl = SIZE(ptab,4) + DO jl = 1, ipl + ptmp(jl) = MINVAL( ptab(:,:,1,jl) * tmask_i(:,:) ) + DO jk = 2, ipk + ptmp(jl) = MIN( ptmp(jl), MINVAL( ptab(:,:,jk,jl) * tmask_i(:,:) ) ) + ENDDO + ENDDO + ! + CALL mpp_min( cdname, ptmp (:) ) + ! + END FUNCTION glob_min_vec_4d + + FUNCTION glob_max_vec_3d( cdname, ptab ) RESULT( ptmp ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptab ! array on which operation is applied + REAL(dp), DIMENSION(SIZE(ptab,3)) :: ptmp + ! + INTEGER :: jk ! dummy loop indice & dimension + INTEGER :: ipk ! dimension + !!----------------------------------------------------------------------- + ! + ipk = SIZE(ptab,3) + DO jk = 1, ipk + ptmp(jk) = MAXVAL( ptab(:,:,jk) * tmask_i(:,:) ) + ENDDO + ! + CALL mpp_max( cdname, ptmp (:) ) + ! + END FUNCTION glob_max_vec_3d + + FUNCTION glob_max_vec_4d( cdname, ptab ) RESULT( ptmp ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname ! name of the calling subroutine + REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: ptab ! array on which operation is applied + REAL(dp), DIMENSION(SIZE(ptab,4)) :: ptmp + ! + INTEGER :: jk , jl ! dummy loop indice & dimension + INTEGER :: ipk, ipl ! dimension + !!----------------------------------------------------------------------- + ! + ipk = SIZE(ptab,3) + ipl = SIZE(ptab,4) + DO jl = 1, ipl + ptmp(jl) = MAXVAL( ptab(:,:,1,jl) * tmask_i(:,:) ) + DO jk = 2, ipk + ptmp(jl) = MAX( ptmp(jl), MAXVAL( ptab(:,:,jk,jl) * tmask_i(:,:) ) ) + ENDDO + ENDDO + ! + CALL mpp_max( cdname, ptmp (:) ) + ! + END FUNCTION glob_max_vec_4d + + SUBROUTINE DDPDD( ydda, yddb ) + !!---------------------------------------------------------------------- + !! *** ROUTINE DDPDD *** + !! + !! ** Purpose : Add a scalar element to a sum + !! + !! + !! ** Method : The code uses the compensated summation with doublet + !! (sum,error) emulated using complex numbers. ydda is the + !! scalar to add to the summ yddb + !! + !! ** Action : This does only work for MPI. + !! + !! References : Using Acurate Arithmetics to Improve Numerical + !! Reproducibility and Sability in Parallel Applications + !! Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001 + !!---------------------------------------------------------------------- + COMPLEX(dp), INTENT(in ) :: ydda + COMPLEX(dp), INTENT(inout) :: yddb + ! + REAL(dp) :: zerr, zt1, zt2 ! local work variables + !!----------------------------------------------------------------------- + ! + ! Compute ydda + yddb using Knuth's trick. + zt1 = REAL(ydda) + REAL(yddb) + zerr = zt1 - REAL(ydda) + zt2 = ( (REAL(yddb) - zerr) + (REAL(ydda) - (zt1 - zerr)) ) & + & + AIMAG(ydda) + AIMAG(yddb) + ! + ! The result is t1 + t2, after normalization. + yddb = CMPLX( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1), dp ) + ! + END SUBROUTINE DDPDD + +#if defined key_nosignedzero + !!---------------------------------------------------------------------- + !! 'key_nosignedzero' F90 SIGN + !!---------------------------------------------------------------------- + + FUNCTION SIGN_SCALAR( pa, pb ) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_SCALAR *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa,pb ! input + REAL(wp) :: SIGN_SCALAR ! result + !!----------------------------------------------------------------------- + IF ( pb >= 0.e0) THEN ; SIGN_SCALAR = ABS(pa) + ELSE ; SIGN_SCALAR =-ABS(pa) + ENDIF + END FUNCTION SIGN_SCALAR + + + FUNCTION SIGN_ARRAY_1D( pa, pb ) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_1D *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa,pb(:) ! input + REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1)) ! result + !!----------------------------------------------------------------------- + WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_1D = ABS(pa) + ELSEWHERE ; SIGN_ARRAY_1D =-ABS(pa) + END WHERE + END FUNCTION SIGN_ARRAY_1D + + + FUNCTION SIGN_ARRAY_2D(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_2D *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa,pb(:,:) ! input + REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2)) ! result + !!----------------------------------------------------------------------- + WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_2D = ABS(pa) + ELSEWHERE ; SIGN_ARRAY_2D =-ABS(pa) + END WHERE + END FUNCTION SIGN_ARRAY_2D + + FUNCTION SIGN_ARRAY_3D(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_3D *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa,pb(:,:,:) ! input + REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result + !!----------------------------------------------------------------------- + WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_3D = ABS(pa) + ELSEWHERE ; SIGN_ARRAY_3D =-ABS(pa) + END WHERE + END FUNCTION SIGN_ARRAY_3D + + + FUNCTION SIGN_ARRAY_1D_A(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_1D_A *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa(:),pb(:) ! input + REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1)) ! result + !!----------------------------------------------------------------------- + WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_1D_A = ABS(pa) + ELSEWHERE ; SIGN_ARRAY_1D_A =-ABS(pa) + END WHERE + END FUNCTION SIGN_ARRAY_1D_A + + + FUNCTION SIGN_ARRAY_2D_A(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_2D_A *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa(:,:),pb(:,:) ! input + REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2)) ! result + !!----------------------------------------------------------------------- + WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_2D_A = ABS(pa) + ELSEWHERE ; SIGN_ARRAY_2D_A =-ABS(pa) + END WHERE + END FUNCTION SIGN_ARRAY_2D_A + + + FUNCTION SIGN_ARRAY_3D_A(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_3D_A *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa(:,:,:),pb(:,:,:) ! input + REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result + !!----------------------------------------------------------------------- + WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_3D_A = ABS(pa) + ELSEWHERE ; SIGN_ARRAY_3D_A =-ABS(pa) + END WHERE + END FUNCTION SIGN_ARRAY_3D_A + + + FUNCTION SIGN_ARRAY_1D_B(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_1D_B *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa(:),pb ! input + REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1)) ! result + !!----------------------------------------------------------------------- + IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_1D_B = ABS(pa) + ELSE ; SIGN_ARRAY_1D_B =-ABS(pa) + ENDIF + END FUNCTION SIGN_ARRAY_1D_B + + + FUNCTION SIGN_ARRAY_2D_B(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_2D_B *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa(:,:),pb ! input + REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2)) ! result + !!----------------------------------------------------------------------- + IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_2D_B = ABS(pa) + ELSE ; SIGN_ARRAY_2D_B =-ABS(pa) + ENDIF + END FUNCTION SIGN_ARRAY_2D_B + + + FUNCTION SIGN_ARRAY_3D_B(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_3D_B *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa(:,:,:),pb ! input + REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3)) ! result + !!----------------------------------------------------------------------- + IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_3D_B = ABS(pa) + ELSE ; SIGN_ARRAY_3D_B =-ABS(pa) + ENDIF + END FUNCTION SIGN_ARRAY_3D_B +#endif + + !!====================================================================== +END MODULE lib_fortran diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/lib_fortran_generic.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/lib_fortran_generic.h90 new file mode 100644 index 0000000..77d4654 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/lib_fortran_generic.h90 @@ -0,0 +1,139 @@ +#if defined GLOBSUM_CODE +! ! FUNCTION FUNCTION_GLOBSUM ! +# if defined DIM_1d +# define XD 1d +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i) +# define ARRAY2_IN(i,j,k) ptab2(i) +# define J_SIZE(ptab) 1 +# define K_SIZE(ptab) 1 +# define MASK_ARRAY(i,j) 1. +# endif +# if defined DIM_2d +# define XD 2d +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i,j) +# define ARRAY2_IN(i,j,k) ptab2(i,j) +# define J_SIZE(ptab) SIZE(ptab,2) +# define K_SIZE(ptab) 1 +# define MASK_ARRAY(i,j) tmask_i(i,j) +# endif +# if defined DIM_3d +# define XD 3d +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i,j,k) +# define ARRAY2_IN(i,j,k) ptab2(i,j,k) +# define J_SIZE(ptab) SIZE(ptab,2) +# define K_SIZE(ptab) SIZE(ptab,3) +# define MASK_ARRAY(i,j) tmask_i(i,j) +# endif + + FUNCTION glob_sum_/**/XD/**/( cdname, ptab ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + ARRAY_TYPE(:,:,:) ! array on which operation is applied + REAL(wp) :: glob_sum_/**/XD + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(wp) :: ztmp + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ipi,ipj, ipk ! dimensions + INTEGER :: iis, iie, ijs, ije ! loop start and end + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = J_SIZE(ptab) ! 2nd dimension + ipk = K_SIZE(ptab) ! 3rd dimension + ! + IF( ipi == jpi .AND. ipj == jpj ) THEN ! do 2D loop only over the inner domain (-> avoid to use undefined values) + iis = Nis0 ; iie = Nie0 + ijs = Njs0 ; ije = Nje0 + ELSE + iis = 1 ; iie = jpi + ijs = 1 ; ije = jpj + ENDIF + ! + ctmp = CMPLX( 0.e0, 0.e0, dp ) ! warning ctmp is cumulated + DO jk = 1, ipk + DO jj = ijs, ije + DO ji = iis, iie + ztmp = ARRAY_IN(ji,jj,jk) * MASK_ARRAY(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) + END DO + END DO + END DO + CALL mpp_sum( cdname, ctmp ) ! sum over the global domain + glob_sum_/**/XD = REAL(ctmp,wp) + + END FUNCTION glob_sum_/**/XD + +#undef XD +#undef ARRAY_TYPE +#undef ARRAY2_TYPE +#undef ARRAY_IN +#undef ARRAY2_IN +#undef J_SIZE +#undef K_SIZE +#undef MASK_ARRAY +! +# endif +#if defined GLOBMINMAX_CODE +! ! FUNCTION FUNCTION_GLOBMINMAX ! +# if defined DIM_2d +# define XD 2d +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i,j) +# define ARRAY2_IN(i,j,k) ptab2(i,j) +# define K_SIZE(ptab) 1 +# endif +# if defined DIM_3d +# define XD 3d +# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define ARRAY_IN(i,j,k) ptab(i,j,k) +# define ARRAY2_IN(i,j,k) ptab2(i,j,k) +# define K_SIZE(ptab) SIZE(ptab,3) +# endif +# if defined OPERATION_GLOBMIN +# define OPER min +# endif +# if defined OPERATION_GLOBMAX +# define OPER max +# endif + + FUNCTION glob_/**/OPER/**/_/**/XD/**/( cdname, ptab ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + ARRAY_TYPE(:,:,:) ! array on which operation is applied + REAL(wp) :: glob_/**/OPER/**/_/**/XD + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(dp):: ctmp + REAL(wp) :: ztmp + INTEGER :: jk ! dummy loop indices + INTEGER :: ipk ! dimensions + !!----------------------------------------------------------------------- + ! + ipk = K_SIZE(ptab) ! 3rd dimension + ! + ztmp = OPER/**/val( ARRAY_IN(:,:,1)*tmask_i(:,:) ) + DO jk = 2, ipk + ztmp = OPER/**/(ztmp, OPER/**/val( ARRAY_IN(:,:,jk)*tmask_i(:,:) )) + ENDDO + + CALL mpp_/**/OPER/**/( cdname, ztmp) + + glob_/**/OPER/**/_/**/XD = ztmp + + END FUNCTION glob_/**/OPER/**/_/**/XD + +#undef XD +#undef ARRAY_TYPE +#undef ARRAY2_TYPE +#undef ARRAY_IN +#undef ARRAY2_IN +#undef K_SIZE +#undef OPER +# endif diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/module_example.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/module_example.F90 new file mode 100644 index 0000000..5635061 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/module_example.F90 @@ -0,0 +1,197 @@ +MODULE exampl + !!====================================================================== + !! *** MODULE exampl *** + !! Ocean physics: brief description of the purpose of the module + !! (please no more than 2 lines) + !!====================================================================== + !! History : 3.0 ! 2008-06 (Author Names) Original code + !! - ! 2008-08 (Author names) brief description of modifications + !! 3.3 ! 2010-11 (Author names) - - + !!---------------------------------------------------------------------- +#if defined key_example + !!---------------------------------------------------------------------- + !! 'key_example' : brief description of the key option + !!---------------------------------------------------------------------- + !! exa_mpl : list of module subroutine (caution, never use the + !! exa_mpl_init : name of the module for a routine) + !! exa_mpl_stp : Please try to use 3 letter block for routine names + !!---------------------------------------------------------------------- + USE par_kind + USE module_name1 ! brief description of the used module + USE module_name2 ! .... + + IMPLICIT NONE + PRIVATE + + PUBLIC exa_mpl ! routine called in xxx.F90 module + PUBLIC exa_mpl_init ! routine called in nemogcm.F90 module + + TYPE :: FLD_E !: Structure type definition + CHARACTER(lc) :: clname ! clname description (default length, lc, is 256, see par_kind.F90) + INTEGER :: nfreqh ! nfreqh description + END TYPE FLD_E + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: var1 !: var1 description. CAUTION always use !: to describe + ! ! a PUBLIC variable: simplify its search : + ! ! grep var1 *90 | grep '!:' + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: var2, var2 !: several variable on a same line OK, but + ! ! DO NOT use continuation lines in declaration + + ! !!* namelist nam_xxx * + LOGICAL :: ln_opt = .TRUE. ! give the default value of each namelist parameter + CHARACTER :: cn_tex = 'T' ! short description of the variable + INTEGER :: nn_opt = 1 ! please respect the DOCTOR norm for namelist variable + REAL(wp) :: rn_var = 2._wp ! (it becomes easy to identify them in the code) + TYPE(FLD) :: sn_ex ! structure + + INTEGER :: nint ! nint description (local permanent variable) + REAL(wp) :: var ! var - - + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: array ! array - - + + !! * Substitutions + ! for DO macro +# include "do_loop_substitute.h90" + !for other substitutions +# include "exampl_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: module_example.F90 14842 2021-05-11 13:17:26Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION exa_mpl_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION exa_mpl_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( array(jpi,jpj,jpk) , STAT= exa_mpl_alloc ) ! Module array + ! + CALL mpp_sum ( 'module_example', exa_mpl_alloc ) + IF( exa_mpl_alloc /= 0 ) CALL ctl_stop( 'STOP', 'exa_mpl_alloc: failed to allocate arrays' ) + ! + END FUNCTION exa_mpl_alloc + + + SUBROUTINE exa_mpl( kt, pvar1, pvar2, ptab ) + !!---------------------------------------------------------------------- + !! *** ROUTINE exa_mpl *** + !! + !! ** Purpose : Brief description of the routine + !! + !! ** Method : description of the methodoloy used to achieve the + !! objectives of the routine. Be as clear as possible! + !! + !! ** Action : - first action (share memory array/varible modified + !! in this routine + !! - second action ..... + !! - ..... + !! + !! References : Author et al., Short_name_review, Year + !! Give references if exist otherwise suppress these lines + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! short description + INTEGER , INTENT(inout) :: pvar1 ! - - + REAL(wp), INTENT( out) :: pvar2 ! - - + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: pvar2 ! - - + !! + INTEGER :: ji, jj, jk ! dummy loop arguments (DOCTOR : start with j, but not jp) + INTEGER :: itoto, itata ! temporary integers (DOCTOR : start with i + REAL(wp) :: zmlmin, zbbrho ! temporary scalars (DOCTOR : start with z) + REAL(wp) :: zfact1, zfact2 ! do not use continuation lines in declaration + REAL(wp), DIMENSION(A2D(nn_hls)) :: zwrk_2d ! 2D workspace + REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwrk_3d ! 3D workspace + !!-------------------------------------------------------------------- + ! + IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile + IF( kt == nit000 ) CALL exa_mpl_init ! Initialization (first time-step only) + + zmlmin = 1.e-8 ! Local constant initialization + zbbrho = .5 * ebb / rho0 + zfact1 = -.5 * rdt * efave + zfact2 = 1.5 * rdt * ediss + ENDIF + + SELECT CASE ( npdl ) ! short description of the action + ! + CASE ( 0 ) ! describe case 1 + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + avm(ji,jj,jk) = .... + END_3D + ! + CASE ( 1 ) ! describe case 2 + DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) + avm(ji,jj,jk) = .... + END_3D + ! + END SELECT + ! + ! WARNING! the lbc_lnk call could not be compatible with the tiling approach + ! please refer to the manual for how to adapt your code + CALL lbc_lnk( 'module_example', avm, 'T', 1. ) ! Lateral boundary conditions (unchanged sign) + ! + END SUBROUTINE exa_mpl + + + SUBROUTINE exa_mpl_init + !!---------------------------------------------------------------------- + !! *** ROUTINE exa_mpl_init *** + !! + !! ** Purpose : initialization of .... + !! + !! ** Method : blah blah blah ... + !! + !! ** input : Namlist namexa + !! + !! ** Action : ... + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk, jit ! dummy loop indices + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/namexa/ exa_v1, exa_v2, nexa_0, sn_ex + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namexa in reference namelist : Example + READ ( numnam_ref, namexa, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namexa in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist namexa in configuration namelist : Example + READ ( numnam_cfg, namexa, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namexa in configuration namelist' ) + ! Output namelist for control + WRITE ( numond, namexa ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'exa_mpl_init : example ' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namexa : set example parameters' + WRITE(numout,*) ' brief desciption exa_v1 = ', exa_v1 + WRITE(numout,*) ' brief desciption exa_v2 = ', exa_v2 + WRITE(numout,*) ' brief desciption nexa_0 = ', nexa_0 + WRITE(numout,*) ' brief desciption sn_ex%clname = ', sn_ex%clname + WRITE(numout,*) ' brief desciption sn_ex%nfreqh = ', sn_ex%nfreqh + ENDIF + ! + ! ! allocate exa_mpl arrays + IF( exa_mpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'exa_mpl_init : unable to allocate arrays' ) + ! ! Parameter control + IF( ln_tile ) CALL ctl_stop( 'exa_mpl_init: tiling is not supported in this module by default, see manual for how to adapt your code' ) + IF( ln_opt ) CALL ctl_stop( 'exa_mpl_init: this work and option xxx are incompatible' ) + IF( nn_opt == 2 ) CALL ctl_stop( 'STOP', 'exa_mpl_init: this work and option yyy may cause problems' ) + ! + END SUBROUTINE exa_mpl_init + +#else + !!---------------------------------------------------------------------- + !! Default option : NO example + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE exa_mpl( kt, pvar1, pvar2, ptab ) ! Empty routine + INTEGER :: kt + REAL:: pvar1, pvar2, ptab(:,:) + WRITE(*,*) 'exa_mpl: You should not have seen this print! error?', kt, pvar1, pvar2, ptab(1,1) + END SUBROUTINE exa_mpl +#endif + + !!====================================================================== +END MODULE exampl \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/nemo.f90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/nemo.f90 new file mode 100644 index 0000000..a28f804 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/nemo.f90 @@ -0,0 +1,21 @@ +PROGRAM nemo + !!====================================================================== + !! *** PROGRAM nemo *** + !! + !! ** Purpose : encapsulate nemo_gcm so that it can also be called + !! together with the linear tangent and adjoint models + !!====================================================================== + !! History : OPA ! 2001-02 (M. Imbard, A. Weaver) Original code + !! NEMO 1.0 ! 2003-10 (G. Madec) F90 + !!---------------------------------------------------------------------- + USE nemogcm ! NEMO system (nemo_gcm routine) + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: nemo.f90 10068 2018-08-28 14:09:04Z nicolasmartin $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + ! + CALL nemo_gcm ! NEMO direct code + ! + !!====================================================================== +END PROGRAM nemo \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/nemogcm.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/nemogcm.F90 new file mode 100644 index 0000000..fd7c0aa --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/nemogcm.F90 @@ -0,0 +1,632 @@ +MODULE nemogcm + !!====================================================================== + !! *** MODULE nemogcm *** + !! Ocean system : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice) + !!====================================================================== + !! History : OPA ! 1990-10 (C. Levy, G. Madec) Original code + !! 7.0 ! 1991-11 (M. Imbard, C. Levy, G. Madec) + !! 7.1 ! 1993-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar, + !! P. Delecluse, C. Perigaud, G. Caniaux, B. Colot, C. Maes) release 7.1 + !! - ! 1992-06 (L.Terray) coupling implementation + !! - ! 1993-11 (M.A. Filiberti) IGLOO sea-ice + !! 8.0 ! 1996-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar, + !! P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0 + !! 8.1 ! 1997-06 (M. Imbard, G. Madec) + !! 8.2 ! 1999-11 (M. Imbard, H. Goosse) sea-ice model + !! ! 1999-12 (V. Thierry, A-M. Treguier, M. Imbard, M-A. Foujols) OPEN-MP + !! ! 2000-07 (J-M Molines, M. Imbard) Open Boundary Conditions (CLIPPER) + !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and modules + !! - ! 2004-06 (R. Redler, NEC CCRLE, Germany) add OASIS[3/4] coupled interfaces + !! - ! 2004-08 (C. Talandier) New trends organization + !! - ! 2005-06 (C. Ethe) Add the 1D configuration possibility + !! - ! 2005-11 (V. Garnier) Surface pressure gradient organization + !! - ! 2006-03 (L. Debreu, C. Mazauric) Agrif implementation + !! - ! 2006-04 (G. Madec, R. Benshila) Step reorganization + !! - ! 2007-07 (J. Chanut, A. Sellar) Unstructured open boundaries (BDY) + !! 3.2 ! 2009-08 (S. Masson) open/write in the listing file in mpp + !! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface + !! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + !! 3.3.1! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation + !! - ! 2011-11 (C. Harris) decomposition changes for running with CICE + !! 3.6 ! 2012-05 (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening + !! - ! 2014-12 (G. Madec) remove KPP scheme and cross-land advection (cla) + !! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! nemo_gcm : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice + !! nemo_init : initialization of the NEMO system + !! nemo_ctl : initialisation of the contol print + !! nemo_closefile: close remaining open files + !! nemo_alloc : dynamical allocation + !!---------------------------------------------------------------------- + USE step_oce ! module used in the ocean time stepping module (step.F90) + ! + USE phycst ! physical constant (par_cst routine) + USE domain ! domain initialization (dom_init & dom_cfg routines) + USE wet_dry ! Wetting and drying setting (wad_init routine) + USE usrdef_nam ! user defined configuration namelist + USE tide_mod, ONLY : tide_init ! tidal components initialization (tide_init routine) + USE bdyini , ONLY : bdy_init ! open boundary cond. setting (bdy_init routine) + USE istate ! initial state setting (istate_init routine) + USE trdini ! dyn/tra trends initialization (trd_init routine) + USE icbini ! handle bergs, initialisation + USE icbstp , ONLY : icb_end ! handle bergs, close iceberg files + USE cpl_oasis3 ! OASIS3 coupling + USE dyndmp ! Momentum damping (C1D only) + USE step_diu ! diurnal bulk SST timestepping (called from here if run offline) + USE crsini ! initialise grid coarsening utility + USE dia25h , ONLY : dia_25h_init ! 25h mean output (initialisation) + USE c1d ! 1D configuration +#if defined key_top + USE trcini ! passive tracer initialisation +#endif +#if defined key_nemocice_decomp + USE ice_domain_size, only: nx_global, ny_global +#endif +#if defined key_qco || defined key_linssh + USE stpmlf ! NEMO time-stepping (stp_MLF routine) +#else + USE step ! NEMO time-stepping (stp routine) +#endif + ! + USE lib_mpp ! distributed memory computing + USE mppini ! shared/distributed memory setting (mpp_init routine) + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) + USE halo_mng ! halo manager + + IMPLICIT NONE + PRIVATE + + PUBLIC nemo_gcm ! called by model.F90 + PUBLIC nemo_init ! needed by AGRIF + PUBLIC nemo_alloc ! needed by TAM + + CHARACTER(lc) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing + +#if ! defined key_mpi_off + ! need MPI_Wtime + INCLUDE 'mpif.h' +#endif + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: nemogcm.F90 15267 2021-09-17 09:04:34Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE nemo_gcm + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_gcm *** + !! + !! ** Purpose : NEMO solves the primitive equations on an orthogonal + !! curvilinear mesh on the sphere. + !! + !! ** Method : - model general initialization + !! - launch the time-stepping (stp routine) + !! - finalize the run by closing files and communications + !! + !! References : Madec, Delecluse, Imbard, and Levy, 1997: internal report, IPSL. + !! Madec, 2008, internal report, IPSL. + !!---------------------------------------------------------------------- + INTEGER :: istp ! time step index + REAL(wp):: zstptiming ! elapsed time for 1 time step + !!---------------------------------------------------------------------- + ! +#if defined key_agrif + CALL Agrif_Init_Grids() ! AGRIF: set the meshes +#endif + ! !-----------------------! + CALL nemo_init !== Initialisations ==! + ! !-----------------------! +#if defined key_agrif + Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices + CALL Agrif_Declare_Var ! " " " " " DYN/TRA +# if defined key_top + CALL Agrif_Declare_Var_top ! " " " " " TOP +# endif +#endif + ! check that all process are still there... If some process have an error, + ! they will never enter in step and other processes will wait until the end of the cpu time! + CALL mpp_max( 'nemogcm', nstop ) + + IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA + + ! !-----------------------! + ! !== time stepping ==! + ! !-----------------------! + ! + ! !== set the model time-step ==! + ! + istp = nit000 + ! +# if defined key_agrif + ! !== AGRIF time-stepping ==! + CALL Agrif_Regrid() + ! + ! Recursive update from highest nested level to lowest: + Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices + CALL Agrif_step_child_adj(Agrif_Update_All) + CALL Agrif_step_child_adj(Agrif_Check_parent_bat) + ! + DO WHILE( istp <= nitend .AND. nstop == 0 ) + ! +# if defined key_qco || defined key_linssh + CALL stp_MLF +# else + CALL stp +# endif + istp = istp + 1 + END DO + ! +# else + ! + IF( .NOT.ln_diurnal_only ) THEN !== Standard time-stepping ==! + ! + DO WHILE( istp <= nitend .AND. nstop == 0 ) + ! + ncom_stp = istp + IF( ln_timing ) THEN + zstptiming = MPI_Wtime() + IF ( istp == ( nit000 + 1 ) ) elapsed_time = zstptiming + IF ( istp == nitend ) elapsed_time = zstptiming - elapsed_time + ENDIF + ! +# if defined key_qco || defined key_linssh + CALL stp_MLF( istp ) +# else + CALL stp ( istp ) +# endif + istp = istp + 1 + ! + IF( lwp .AND. ln_timing ) WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming + ! + END DO + ! + ELSE !== diurnal SST time-steeping only ==! + ! + DO WHILE( istp <= nitend .AND. nstop == 0 ) + CALL stp_diurnal( istp ) ! time step only the diurnal SST + istp = istp + 1 + END DO + ! + ENDIF + ! +# endif + ! + IF( ln_diaobs ) CALL dia_obs_wri + ! + IF( ln_icebergs ) CALL icb_end( nitend ) + + ! !------------------------! + ! !== finalize the run ==! + ! !------------------------! + IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA + ! + IF( nstop /= 0 .AND. lwp ) THEN ! error print + WRITE(ctmp1,*) ' ==>>> nemo_gcm: a total of ', nstop, ' errors have been found' + IF( ngrdstop > 0 ) THEN + WRITE(ctmp9,'(i2)') ngrdstop + WRITE(ctmp2,*) ' E R R O R detected in Agrif grid '//TRIM(ctmp9) + WRITE(ctmp3,*) ' Look for "E R R O R" messages in all existing '//TRIM(ctmp9)//'_ocean_output* files' + CALL ctl_stop( ' ', ctmp1, ' ', ctmp2, ' ', ctmp3 ) + ELSE + WRITE(ctmp2,*) ' Look for "E R R O R" messages in all existing ocean_output* files' + CALL ctl_stop( ' ', ctmp1, ' ', ctmp2 ) + ENDIF + ENDIF + ! + IF( ln_timing ) CALL timing_finalize + ! + CALL nemo_closefile + ! +#if defined key_xios + CALL xios_finalize ! end mpp communications with xios + IF( lk_oasis ) CALL cpl_finalize ! end coupling and mpp communications with OASIS +#else + IF ( lk_oasis ) THEN ; CALL cpl_finalize ! end coupling and mpp communications with OASIS + ELSEIF( lk_mpp ) THEN ; CALL mppstop ! end mpp communications + ENDIF +#endif + ! + IF(lwm) THEN + IF( nstop == 0 ) THEN ; STOP 0 + ELSE ; STOP 123 + ENDIF + ENDIF + ! + END SUBROUTINE nemo_gcm + + + SUBROUTINE nemo_init + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_init *** + !! + !! ** Purpose : initialization of the NEMO GCM + !!---------------------------------------------------------------------- + INTEGER :: ios, ilocal_comm ! local integers + !! + NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, nn_isplt, nn_jsplt , nn_ictls, & + & nn_ictle, nn_jctls , nn_jctle + NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr + !!---------------------------------------------------------------------- + ! + cxios_context = 'nemo' + ! + ! !-------------------------------------------------! + ! ! set communicator & select the local rank ! + ! ! must be done as soon as possible to get narea ! + ! !-------------------------------------------------! + ! +#if defined key_xios + IF( Agrif_Root() ) THEN + IF( lk_oasis ) THEN + CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis + CALL xios_initialize( "not used" , local_comm =ilocal_comm ) ! send nemo communicator to xios + ELSE + CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm ) ! nemo local communicator given by xios + ENDIF + ENDIF + CALL mpp_start( ilocal_comm ) +#else + IF( lk_oasis ) THEN + IF( Agrif_Root() ) THEN + CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis + ENDIF + CALL mpp_start( ilocal_comm ) + ELSE + CALL mpp_start( ) + ENDIF +#endif + ! + narea = mpprank + 1 ! mpprank: the rank of proc (0 --> mppsize -1 ) + lwm = (narea == 1) ! control of output namelists + ! + ! !---------------------------------------------------------------! + ! ! Open output files, reference and configuration namelist files ! + ! !---------------------------------------------------------------! + ! + ! open ocean.output as soon as possible to get all output prints (including errors messages) + IF( lwm ) CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) + ! open reference and configuration namelist files + CALL load_nml( numnam_ref, 'namelist_ref', -1, lwm ) + CALL load_nml( numnam_cfg, 'namelist_cfg', -1, lwm ) + IF( lwm ) CALL ctl_opn( numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) + ! open /dev/null file to be able to supress output write easily + IF( Agrif_Root() ) THEN + CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) +#ifdef key_agrif + ELSE + numnul = Agrif_Parent(numnul) +#endif + ENDIF + ! !--------------------! + ! ! Open listing units ! -> need sn_cfctl from namctl to define lwp + ! !--------------------! + ! + READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist' ) + READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist' ) + ! + ! finalize the definition of namctl variables + IF( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax .OR. MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) & + & CALL nemo_set_cfctl( sn_cfctl, .FALSE. ) + ! + lwp = (narea == 1) .OR. sn_cfctl%l_oceout ! control of all listing output print + ! + IF(lwp) THEN ! open listing units + ! + IF( .NOT. lwm ) & ! alreay opened for narea == 1 + & CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) + ! + WRITE(numout,*) + WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC' + WRITE(numout,*) ' NEMO team' + WRITE(numout,*) ' Ocean General Circulation Model' + WRITE(numout,*) ' NEMO version 4.0 (2020) ' + WRITE(numout,*) + WRITE(numout,*) " ._ ._ ._ ._ ._ " + WRITE(numout,*) " _.-._)`\_.-._)`\_.-._)`\_.-._)`\_.-._)`\_ " + WRITE(numout,*) + WRITE(numout,*) " o _, _, " + WRITE(numout,*) " o .' ( .-' / " + WRITE(numout,*) " o _/..._'. .' / " + WRITE(numout,*) " ( o .-'` ` '-./ _.' " + WRITE(numout,*) " ) ( o) ;= <_ ( " + WRITE(numout,*) " ( '-.,\\__ __.-;`\ '. ) " + WRITE(numout,*) " ) ) \) |`\ \) '. \ ( ( " + WRITE(numout,*) " ( ( \_/ '-._\ ) ) " + WRITE(numout,*) " ) ) jgs ` ( ( " + WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " + WRITE(numout,*) + ! + WRITE(numout,cform_aaa) ! Flag AAAAAAA + ! + ! ! Control print of the working precision + WRITE(numout,*) + IF( wp == dp ) THEN ; WRITE(numout,*) "par_kind : wp = Working precision = dp = double-precision" + ELSE ; WRITE(numout,*) "par_kind : wp = Working precision = sp = single-precision" + ENDIF + WRITE(numout,*) "~~~~~~~~ ****************" + WRITE(numout,*) + ! + ENDIF + ! + IF(lwm) WRITE( numond, namctl ) + ! + ! !------------------------------------! + ! ! Set global domain size parameters ! + ! !------------------------------------! + ! + READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 ) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist' ) + READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) +904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist' ) + ! + IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file + CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) + ELSE ! user-defined namelist + CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) + ENDIF + ! + IF(lwm) WRITE( numond, namcfg ) + ! + ! !-----------------------------------------! + ! ! mpp parameters and domain decomposition ! + ! !-----------------------------------------! + CALL mpp_init + +#if defined key_loop_fusion + IF( nn_hls == 1 ) THEN + CALL ctl_stop( 'STOP', 'nemogcm : Loop fusion can be used only with extra-halo' ) + ENDIF +#endif + + CALL halo_mng_init() + ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays + CALL nemo_alloc() + + ! Initialise time level indices + Nbb = 1 ; Nnn = 2 ; Naa = 3 ; Nrhs = Naa +#if defined key_agrif + Kbb_a = Nbb ; Kmm_a = Nnn ; Krhs_a = Nrhs ! agrif_oce module copies of time level indices +#endif + ! !-------------------------------! + ! ! NEMO general initialization ! + ! !-------------------------------! + + CALL nemo_ctl ! Control prints of namctl and namcfg + ! + ! ! General initialization + IF( ln_timing ) CALL timing_init ! timing + IF( ln_timing ) CALL timing_start( 'nemo_init') + ! + CALL phy_cst ! Physical constants + CALL eos_init ! Equation of state + CALL wad_init ! Wetting and drying options + +#if defined key_agrif + CALL Agrif_Declare_Var_ini ! " " " " " DOM +#endif + CALL dom_init( Nbb, Nnn, Naa ) ! Domain + IF( ln_crs ) CALL crs_init( Nnn ) ! coarsened grid: domain initialization + IF( sn_cfctl%l_prtctl ) & + & CALL prt_ctl_init ! Print control + + CALL diurnal_sst_bulk_init ! diurnal sst + IF( ln_diurnal ) CALL diurnal_sst_coolskin_init ! cool skin + ! + IF( ln_diurnal_only ) THEN ! diurnal only: a subset of the initialisation routines + CALL istate_init( Nbb, Nnn, Naa ) ! ocean initial state (Dynamics and tracers) + CALL sbc_init( Nbb, Nnn, Naa ) ! Forcings : surface module + CALL tra_qsr_init ! penetrative solar radiation qsr + IF( ln_diaobs ) THEN ! Observation & model comparison + CALL dia_obs_init( Nnn ) ! Initialize observational data + CALL dia_obs( nit000 - 1, Nnn ) ! Observation operator for restart + ENDIF + IF( lk_asminc ) CALL asm_inc_init( Nbb, Nnn, Nrhs ) ! Assimilation increments + ! + RETURN ! end of initialization + ENDIF + ! + + CALL istate_init( Nbb, Nnn, Naa ) ! ocean initial state (Dynamics and tracers) + + ! ! external forcing + CALL tide_init ! tidal harmonics + CALL sbc_init( Nbb, Nnn, Naa ) ! surface boundary conditions (including sea-ice) + CALL bdy_init ! Open boundaries initialisation + + ! ! Ocean physics + CALL zdf_phy_init( Nnn ) ! Vertical physics + + ! ! Lateral physics + CALL ldf_tra_init ! Lateral ocean tracer physics + CALL ldf_eiv_init ! eddy induced velocity param. must be done after ldf_tra_init + CALL ldf_dyn_init ! Lateral ocean momentum physics + + ! ! Active tracers + IF( ln_traqsr ) CALL tra_qsr_init ! penetrative solar radiation qsr + CALL tra_bbc_init ! bottom heat flux + CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme + CALL tra_dmp_init ! internal tracer damping + CALL tra_adv_init ! horizontal & vertical advection + CALL tra_ldf_init ! lateral mixing + + ! ! Dynamics + IF( ln_c1d ) CALL dyn_dmp_init ! internal momentum damping + CALL dyn_adv_init ! advection (vector or flux form) + CALL dyn_vor_init ! vorticity term including Coriolis + CALL dyn_ldf_init ! lateral mixing + CALL dyn_hpg_init( Nnn ) ! horizontal gradient of Hydrostatic pressure + CALL dyn_spg_init ! surface pressure gradient + + ! ! Icebergs + CALL icb_init( rn_Dt, nit000) ! initialise icebergs instance + + ! ice shelf + CALL isf_init( Nbb, Nnn, Naa ) +#if defined key_top + ! ! Passive tracers + CALL trc_init( Nbb, Nnn, Naa ) +#endif + IF( l_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing + + ! ! Misc. options + CALL sto_par_init ! Stochastic parametrization + IF( ln_sto_eos ) CALL sto_pts_init ! RRandom T/S fluctuations + + ! ! Diagnostics + CALL flo_init( Nnn ) ! drifting Floats + IF( ln_diacfl ) CALL dia_cfl_init ! Initialise CFL diagnostics + CALL dia_dct_init ! Sections tranports + CALL dia_hsb_init( Nnn ) ! heat content, salt content and volume budgets + CALL trd_init( Nnn ) ! Mixed-layer/Vorticity/Integral constraints trends + CALL dia_obs_init( Nnn ) ! Initialize observational data + CALL dia_25h_init( Nbb ) ! 25h mean outputs + CALL dia_detide_init ! Weights computation for daily detiding of model diagnostics + IF( ln_diaobs ) CALL dia_obs( nit000-1, Nnn ) ! Observation operator for restart + CALL dia_mlr_init ! Initialisation of IOM context management for multiple-linear-regression analysis + + ! ! Assimilation increments + IF( lk_asminc ) CALL asm_inc_init( Nbb, Nnn, Nrhs ) ! Initialize assimilation increments + ! + IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA + ! + IF( ln_timing ) CALL timing_stop( 'nemo_init') + ! + END SUBROUTINE nemo_init + + + SUBROUTINE nemo_ctl + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_ctl *** + !! + !! ** Purpose : control print setting + !! + !! ** Method : - print namctl and namcfg information and check some consistencies + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'nemo_ctl: Control prints' + WRITE(numout,*) '~~~~~~~~' + WRITE(numout,*) ' Namelist namctl' + WRITE(numout,*) ' sn_cfctl%l_runstat = ', sn_cfctl%l_runstat + WRITE(numout,*) ' sn_cfctl%l_trcstat = ', sn_cfctl%l_trcstat + WRITE(numout,*) ' sn_cfctl%l_oceout = ', sn_cfctl%l_oceout + WRITE(numout,*) ' sn_cfctl%l_layout = ', sn_cfctl%l_layout + WRITE(numout,*) ' sn_cfctl%l_prtctl = ', sn_cfctl%l_prtctl + WRITE(numout,*) ' sn_cfctl%l_prttrc = ', sn_cfctl%l_prttrc + WRITE(numout,*) ' sn_cfctl%l_oasout = ', sn_cfctl%l_oasout + WRITE(numout,*) ' sn_cfctl%procmin = ', sn_cfctl%procmin + WRITE(numout,*) ' sn_cfctl%procmax = ', sn_cfctl%procmax + WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr + WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr + WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing + WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl + ENDIF + ! + IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' Namelist namcfg' + WRITE(numout,*) ' read domain configuration file ln_read_cfg = ', ln_read_cfg + WRITE(numout,*) ' filename to be read cn_domcfg = ', TRIM(cn_domcfg) + WRITE(numout,*) ' keep closed seas in the domain (if exist) ln_closea = ', ln_closea + WRITE(numout,*) ' create a configuration definition file ln_write_cfg = ', ln_write_cfg + WRITE(numout,*) ' filename to be written cn_domcfg_out = ', TRIM(cn_domcfg_out) + WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr + ENDIF + ! + IF( 1._wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows f2003 standard.', & + & 'Compile with key_nosignedzero enabled:', & + & '--> add -Dkey_nosignedzero to the definition of %CPP in your arch file' ) + ! +#if defined key_agrif + IF( ln_timing ) CALL ctl_stop( 'AGRIF not implemented with ln_timing = true') +#endif + ! + END SUBROUTINE nemo_ctl + + + SUBROUTINE nemo_closefile + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_closefile *** + !! + !! ** Purpose : Close the files + !!---------------------------------------------------------------------- + ! + IF( lk_mpp ) CALL mppsync + ! + CALL iom_close ! close all input/output files managed by iom_* + ! + IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file + IF( numrun /= -1 ) CLOSE( numrun ) ! run statistics file + IF( lwm.AND.numond /= -1 ) CLOSE( numond ) ! oce output namelist + IF( lwm.AND.numoni /= -1 ) CLOSE( numoni ) ! ice output namelist + IF( numevo_ice /= -1 ) CLOSE( numevo_ice ) ! ice variables (temp. evolution) + IF( numout /= 6 ) CLOSE( numout ) ! standard model output file + IF( numdct_vol /= -1 ) CLOSE( numdct_vol ) ! volume transports + IF( numdct_heat /= -1 ) CLOSE( numdct_heat ) ! heat transports + IF( numdct_salt /= -1 ) CLOSE( numdct_salt ) ! salt transports + ! + numout = 6 ! redefine numout in case it is used after this point... + ! + END SUBROUTINE nemo_closefile + + + SUBROUTINE nemo_alloc + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_alloc *** + !! + !! ** Purpose : Allocate all the dynamic arrays of the OCE modules + !! + !! ** Method : + !!---------------------------------------------------------------------- + USE diawri , ONLY : dia_wri_alloc + USE dom_oce , ONLY : dom_oce_alloc + USE trc_oce , ONLY : trc_oce_alloc + USE bdy_oce , ONLY : bdy_oce_alloc + ! + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! + ierr = oce_alloc () ! ocean + ierr = ierr + dia_wri_alloc() + ierr = ierr + dom_oce_alloc() ! ocean domain + ierr = ierr + zdf_oce_alloc() ! ocean vertical physics + ierr = ierr + trc_oce_alloc() ! shared TRC / TRA arrays + ierr = ierr + bdy_oce_alloc() ! bdy masks (incl. initialization) + ! + CALL mpp_sum( 'nemogcm', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' ) + ! + END SUBROUTINE nemo_alloc + + + SUBROUTINE nemo_set_cfctl(sn_cfctl, setto ) + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_set_cfctl *** + !! + !! ** Purpose : Set elements of the output control structure to setto. + !! + !! ** Method : Note this routine can be used to switch on/off some + !! types of output for selected areas. + !!---------------------------------------------------------------------- + TYPE(sn_ctl), INTENT(inout) :: sn_cfctl + LOGICAL , INTENT(in ) :: setto + !!---------------------------------------------------------------------- + sn_cfctl%l_runstat = setto + sn_cfctl%l_trcstat = setto + sn_cfctl%l_oceout = setto + sn_cfctl%l_layout = setto + sn_cfctl%l_prtctl = setto + sn_cfctl%l_prttrc = setto + sn_cfctl%l_oasout = setto + END SUBROUTINE nemo_set_cfctl + + !!====================================================================== +END MODULE nemogcm \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/oce.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/oce.F90 new file mode 100644 index 0000000..ec5c05a --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/oce.F90 @@ -0,0 +1,149 @@ +MODULE oce + !!====================================================================== + !! *** MODULE oce *** + !! Ocean : dynamics and active tracers defined in memory + !!====================================================================== + !! History : 1.0 ! 2002-11 (G. Madec) F90: Free form and module + !! 3.1 ! 2009-02 (G. Madec, M. Leclair) pure z* coordinate + !! 3.3 ! 2010-09 (C. Ethe) TRA-TRC merge: add ts, gtsu, gtsv 4D arrays + !! 3.7 ! 2014-01 (G. Madec) suppression of curl and before hdiv from in-core memory + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename prognostic variables in preparation for new time scheme + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC oce_alloc ! routine called by nemo_init in nemogcm.F90 + PUBLIC oce_SWE_alloc ! routine called by nemo_init in SWE/nemogcm.F90 (Shallow Water Eq. case) + + !! dynamics and tracer fields + !! -------------------------- + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: uu , vv !: horizontal velocities [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ww !: vertical velocity [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wi !: vertical vel. (adaptive-implicit) [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdiv !: horizontal divergence [s-1] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) :: ts !: 4D T-S fields [Celsius,psu] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: rab_b, rab_n !: thermal/haline expansion coef. [Celsius-1,psu-1] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rn2b , rn2 !: brunt-vaisala frequency**2 [s-2] + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rhd !: in situ density anomalie rhd=(rho-rho0)/rho0 [no units] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rhop !: potential volumic mass [kg/m3] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: Cu_adv !: vertical Courant number (adaptive-implicit) + + !! free surface + !! ------------ + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uu_b, vv_b!: SSH [m] and barotropic velocities [m/s] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ssh!: SSH [m] and barotropic velocities [m/s] + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssh_frc !: Forcing term in external mode for SSH [m/s] + + !! Arrays at barotropic time step: ! befbefore! before ! now ! after ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubb_e , ub_e , un_e , ua_e !: u-external velocity + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vbb_e , vb_e , vn_e , va_e !: v-external velocity + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshbb_e, sshb_e!: external ssh + REAL(dp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshn_e, ssha_e!: external ssh + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_e !: external u-depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_e !: external v-depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hur_e !: inverse of u-depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hvr_e !: inverse of v-depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub2_b , vb2_b !: Half step fluxes (ln_bt_fw=T) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_bf , vn_bf !: Asselin filtered half step fluxes (ln_bt_fw=T) +#if defined key_agrif + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub2_i_b, vb2_i_b !: Half step time integrated fluxes +#endif + + !! interpolated gradient (only used in zps case) + !! --------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtsu, gtsv !: horizontal gradient of T, S bottom u-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: gru , grv !: horizontal gradient of rd at bottom u-point + + !! (ISF) interpolated gradient (only used for ice shelf case) + !! --------------------- + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gtui, gtvi !: horizontal gradient of T, S and rd at top u-point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: grui, grvi !: horizontal gradient of T, S and rd at top v-point + !! (ISF) ice load + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: riceload + + !! Energy budget of the leads (open water embedded in sea ice) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fraqsr_1lev !: fraction of solar net radiation absorbed in the first ocean level [-] + INTEGER, PUBLIC, DIMENSION(2) :: noce_array !: unused array but seems to be needed to prevent agrif from creating an empty module + + !! Shallow Water Eq. case (SWE) + LOGICAL, PUBLIC :: lk_SWE = .FALSE. !: shallow water flag =T in SWE configurations only + + !! Stand-Alone Surface module (SAS) + LOGICAL, PUBLIC :: l_SAS = .FALSE. !: SAS flag =T in SAS configurations only + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: oce.F90 15556 2021-11-29 15:23:06Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION oce_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION oce_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(6) + !!---------------------------------------------------------------------- + ! + ierr(:) = 0 + ALLOCATE( uu (jpi,jpj,jpk,jpt) , vv (jpi,jpj,jpk,jpt) , & + & ww (jpi,jpj,jpk) , hdiv(jpi,jpj,jpk) , & + & ts (jpi,jpj,jpk,jpts,jpt) , & + & rab_b(jpi,jpj,jpk,jpts) , rab_n(jpi,jpj,jpk,jpts) , & + & rn2b (jpi,jpj,jpk) , rn2 (jpi,jpj,jpk) , & + & rhd (jpi,jpj,jpk) , rhop (jpi,jpj,jpk) , STAT=ierr(1) ) + ! + ALLOCATE( ssh (jpi,jpj,jpt) , uu_b(jpi,jpj,jpt) , vv_b(jpi,jpj,jpt) , & + & ssh_frc(jpi,jpj) , & + & gtsu(jpi,jpj,jpts) , gtsv(jpi,jpj,jpts) , & + & gru (jpi,jpj) , grv (jpi,jpj) , & + & gtui(jpi,jpj,jpts) , gtvi(jpi,jpj,jpts) , & + & grui(jpi,jpj) , grvi(jpi,jpj) , & + & riceload(jpi,jpj) , STAT=ierr(2) ) + ! + ALLOCATE( fraqsr_1lev(jpi,jpj) , STAT=ierr(3) ) + ! + ALLOCATE( ssha_e(jpi,jpj), sshn_e(jpi,jpj), sshb_e(jpi,jpj), sshbb_e(jpi,jpj), & + & ua_e(jpi,jpj), un_e(jpi,jpj), ub_e(jpi,jpj), ubb_e(jpi,jpj), & + & va_e(jpi,jpj), vn_e(jpi,jpj), vb_e(jpi,jpj), vbb_e(jpi,jpj), & + & hu_e(jpi,jpj), hur_e(jpi,jpj), hv_e(jpi,jpj), hvr_e(jpi,jpj), STAT=ierr(4) ) + ! + ALLOCATE( ub2_b(jpi,jpj), vb2_b(jpi,jpj), un_bf(jpi,jpj), vn_bf(jpi,jpj) , STAT=ierr(5) ) +#if defined key_agrif + ALLOCATE( ub2_i_b(jpi,jpj), vb2_i_b(jpi,jpj) , STAT=ierr(6) ) +#endif + ! + oce_alloc = MAXVAL( ierr ) + IF( oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'oce_alloc: failed to allocate arrays' ) + ! + END FUNCTION oce_alloc + + + INTEGER FUNCTION oce_SWE_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION oce_SWE_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(2) + !!---------------------------------------------------------------------- + ! + lk_SWE = .TRUE. ! =T SWE case + ! + ierr(:) = 0 + ALLOCATE( uu(jpi,jpj,jpk,jpt) , vv (jpi,jpj,jpk,jpt) , & + & ww(jpi,jpj,jpk) , hdiv(jpi,jpj,jpk) , ssh(jpi,jpj,jpt) , STAT=ierr(1) ) + ! + ALLOCATE( ts(jpi,jpj,jpk,jpts,jpt) , fraqsr_1lev(jpi,jpj) , & + & uu_b(jpi,jpj,jpt) , vv_b(jpi,jpj,jpt) , rn2(jpi,jpj,jpk) , STAT=ierr(2) ) + ! + oce_SWE_alloc = MAXVAL( ierr ) + IF( oce_SWE_alloc /= 0 ) CALL ctl_stop( 'STOP', 'oce_SWE_alloc: failed to allocate arrays' ) + ! + END FUNCTION oce_SWE_alloc + + !!====================================================================== +END MODULE oce \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/par_kind.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/par_kind.F90 new file mode 100644 index 0000000..9226b96 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/par_kind.F90 @@ -0,0 +1,42 @@ +MODULE par_kind + !!====================================================================== + !! *** MODULE par_kind *** + !! Ocean : define the kind of real for the whole model + !!====================================================================== + !! History : 1.0 ! 2002-06 (G. Madec) Original code + !! 3.3 ! 2010-12 (G. Madec) add a standard length of character strings + !!---------------------------------------------------------------------- + + IMPLICIT NONE + PRIVATE + + ! Number model from which the SELECTED_*_KIND are requested: + ! 4 byte REAL 8 byte REAL + ! CRAY: - precision = 13 + ! exponent = 2465 + ! IEEE: precision = 6 precision = 15 + ! exponent = 37 exponent = 307 + + ! !!** Floating point ** + INTEGER, PUBLIC, PARAMETER :: sp = SELECTED_REAL_KIND( 6, 37) !: single precision (real 4) + INTEGER, PUBLIC, PARAMETER :: dp = SELECTED_REAL_KIND(12,307) !: double precision (real 8) +# if defined key_single + INTEGER, PUBLIC, PARAMETER :: wp = sp !: working precision +# else + INTEGER, PUBLIC, PARAMETER :: wp = dp !: working precision +# endif + + ! !!** Integer ** + INTEGER, PUBLIC, PARAMETER :: i4 = SELECTED_INT_KIND( 9) !: single precision (integer 4) + INTEGER, PUBLIC, PARAMETER :: i8 = SELECTED_INT_KIND(14) !: double precision (integer 8) + + ! !!** Integer ** + INTEGER, PUBLIC, PARAMETER :: lc = 256 !: Lenght of Character strings + INTEGER, PUBLIC, PARAMETER :: lca = 400 !: Lenght of Character arrays + + !!---------------------------------------------------------------------- + !! NEMO 3.3 , NEMO Consortium (2018) + !! $Id: par_kind.F90 14433 2021-02-11 08:06:49Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +END MODULE par_kind diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/par_oce.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/par_oce.F90 new file mode 100644 index 0000000..cd7821f --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/par_oce.F90 @@ -0,0 +1,107 @@ +MODULE par_oce + !!====================================================================== + !! *** par_oce *** + !! Ocean : set the ocean parameters + !!====================================================================== + !! History : OPA ! 1991 (Imbard, Levy, Madec) Original code + !! NEMO 1.0 ! 2004-01 (G. Madec, J.-M. Molines) Free form and module + !! 3.3 ! 2010-09 (C. Ethe) TRA-TRC merge: add jpts, jp_tem & jp_sal + !!---------------------------------------------------------------------- + USE par_kind ! kind parameters + + IMPLICIT NONE + PUBLIC + + !!---------------------------------------------------------------------- + !! namcfg namelist parameters + !!---------------------------------------------------------------------- + LOGICAL :: ln_read_cfg !: (=T) read the domain configuration file or (=F) not + CHARACTER(lc) :: cn_domcfg !: filename the configuration file to be read + LOGICAL :: ln_write_cfg !: (=T) create the domain configuration file + CHARACTER(lc) :: cn_domcfg_out !: filename the configuration file to be read + ! + LOGICAL :: ln_use_jattr !: input file read offset + ! ! Use file global attribute: open_ocean_jstart to determine start j-row + ! ! when reading input from those netcdf files that have the + ! ! attribute defined. This is designed to enable input files associated + ! ! with the extended grids used in the under ice shelf configurations to + ! ! be used without redundant rows when the ice shelves are not in use. + LOGICAL :: ln_closea !: (=T) special treatment of closed sea + ! + + !!--------------------------------------------------------------------- + !! Domain Matrix size + !!--------------------------------------------------------------------- + ! configuration name & resolution (required only in ORCA family case) + CHARACTER(lc) :: cn_cfg !: name of the configuration + INTEGER :: nn_cfg !: resolution of the configuration + + ! time dimension + INTEGER, PUBLIC, PARAMETER :: jpt = 3 !: time dimension + + ! global domain size !!! * total computational domain * + INTEGER :: jpiglo !: 1st dimension of global domain --> i-direction + INTEGER :: jpjglo !: 2nd - - --> j-direction + INTEGER :: jpkglo !: 3nd - - --> k levels + + ! global domain size for AGRIF !!! * total AGRIF computational domain * + INTEGER, PUBLIC :: nbug_in_agrif_conv_do_not_remove_or_modify = 1 - 1 + INTEGER, PUBLIC, PARAMETER :: nbghostcells = 4 !: number of ghost cells: default value + INTEGER, PUBLIC :: nbghostcells_x_w !: number of ghost cells in i-direction at west + INTEGER, PUBLIC :: nbghostcells_x_e !: number of ghost cells in i-direction at east + INTEGER, PUBLIC :: nbghostcells_y_s !: number of ghost cells in j-direction at south + INTEGER, PUBLIC :: nbghostcells_y_n !: number of ghost cells in j-direction at north + INTEGER, PUBLIC :: nbcellsx !: number of cells in i-direction + INTEGER, PUBLIC :: nbcellsy !: number of cells in j-direction + + ! local domain size !!! * local computational domain * + INTEGER, PUBLIC :: jpi ! !: first dimension + INTEGER, PUBLIC :: jpj ! !: second dimension + INTEGER, PUBLIC :: jpk ! = jpkglo !: third dimension + INTEGER, PUBLIC :: jpkm1 ! = jpk-1 !: - - - + INTEGER, PUBLIC :: jpij ! = jpi*jpj !: jpi x jpj + INTEGER, PUBLIC :: jpimax! = ( Ni0glo + jpni-1 ) / jpni + 2*nn_hls !: maximum jpi + INTEGER, PUBLIC :: jpjmax! = ( Nj0glo + jpnj-1 ) / jpnj + 2*nn_hls !: maximum jpj + + ! Domain tiling + INTEGER, PUBLIC :: nijtile !: number of tiles in total + INTEGER, PUBLIC :: ntile !: current tile number + INTEGER, PUBLIC :: ntsi !: start of internal part of tile domain + INTEGER, PUBLIC :: ntsj ! + INTEGER, PUBLIC :: ntei !: end of internal part of tile domain + INTEGER, PUBLIC :: ntej ! + INTEGER, PUBLIC :: nthl, nthr !: Modifier on DO loop macro bound offset (left, right) + INTEGER, PUBLIC :: nthb, ntht !: " " (bottom, top) + + !!--------------------------------------------------------------------- + !! Active tracer parameters + !!--------------------------------------------------------------------- + INTEGER, PUBLIC, PARAMETER :: jpts = 2 !: Number of active tracers (=2, i.e. T & S ) + INTEGER, PUBLIC, PARAMETER :: jp_tem = 1 !: indice for temperature + INTEGER, PUBLIC, PARAMETER :: jp_sal = 2 !: indice for salinity + + !!---------------------------------------------------------------------- + !! Domain decomposition + !!---------------------------------------------------------------------- + !! if we dont use massively parallel computer (parameters jpni=jpnj=1) so jpiglo=jpi and jpjglo=jpj + INTEGER, PUBLIC :: jpni !: number of processors following i + INTEGER, PUBLIC :: jpnj !: number of processors following j + INTEGER, PUBLIC :: jpnij !: nb of local domain = nb of processors ( <= jpni x jpnj ) + INTEGER, PUBLIC, PARAMETER :: jpr2di = 0 !: number of columns for extra outer halo + INTEGER, PUBLIC, PARAMETER :: jpr2dj = 0 !: number of rows for extra outer halo + + ! halo with and starting/inding DO-loop indices + INTEGER, PUBLIC :: nn_hls !: halo width (applies to both rows and columns) + INTEGER, PUBLIC :: Nis0 !: start I-index without halo + INTEGER, PUBLIC :: Nie0 !: end I-index without halo + INTEGER, PUBLIC :: Njs0 !: start J-index without halo + INTEGER, PUBLIC :: Nje0 !: end J-index without halo + INTEGER, PUBLIC :: Ni_0, Nj_0 !: local domain size without halo + INTEGER, PUBLIC :: Ni0glo, Nj0glo !: global domain size without halo + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: par_oce.F90 15119 2021-07-13 14:43:22Z jchanut $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE par_oce \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/single_precision_substitute.h90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/single_precision_substitute.h90 new file mode 100644 index 0000000..02e78ec --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/single_precision_substitute.h90 @@ -0,0 +1,8 @@ +#if defined key_single +# define CASTSP(x) REAL(x,sp) +# define CASTDP(x) REAL(x,dp) +#else +# define CASTSP(x) x +# define CASTDP(x) x +#endif + diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/step.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/step.F90 new file mode 100644 index 0000000..85b9229 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/step.F90 @@ -0,0 +1,452 @@ +MODULE step + !!====================================================================== + !! *** MODULE step *** + !! Time-stepping : manager of the ocean, tracer and ice time stepping + !!====================================================================== + !! History : OPA ! 1991-03 (G. Madec) Original code + !! - ! 1991-11 (G. Madec) + !! - ! 1992-06 (M. Imbard) add a first output record + !! - ! 1996-04 (G. Madec) introduction of dynspg + !! - ! 1996-04 (M.A. Foujols) introduction of passive tracer + !! 8.0 ! 1997-06 (G. Madec) new architecture of call + !! 8.2 ! 1997-06 (G. Madec, M. Imbard, G. Roullet) free surface + !! - ! 1999-02 (G. Madec, N. Grima) hpg implicit + !! - ! 2000-07 (J-M Molines, M. Imbard) Open Bondary Conditions + !! NEMO 1.0 ! 2002-06 (G. Madec) free form, suppress macro-tasking + !! - ! 2004-08 (C. Talandier) New trends organization + !! - ! 2005-01 (C. Ethe) Add the KPP closure scheme + !! - ! 2005-11 (G. Madec) Reorganisation of tra and dyn calls + !! - ! 2006-01 (L. Debreu, C. Mazauric) Agrif implementation + !! - ! 2006-07 (S. Masson) restart using iom + !! 3.2 ! 2009-02 (G. Madec, R. Benshila) reintroduicing z*-coordinate + !! - ! 2009-06 (S. Masson, G. Madec) TKE restart compatible with key_cpl + !! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface + !! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + merge TRC-TRA + !! 3.4 ! 2011-04 (G. Madec, C. Ethe) Merge of dtatem and dtasal + !! 3.6 ! 2012-07 (J. Simeon, G. Madec. C. Ethe) Online coarsening of outputs + !! 3.6 ! 2014-04 (F. Roquet, G. Madec) New equations of state + !! 3.6 ! 2014-10 (E. Clementi, P. Oddo) Add Qiao vertical mixing in case of waves + !! 3.7 ! 2014-10 (G. Madec) LDF simplication + !! - ! 2014-12 (G. Madec) remove KPP scheme + !! - ! 2015-11 (J. Chanut) free surface simplification (remove filtered free surface) + !! 4.0 ! 2017-05 (G. Madec) introduction of the vertical physics manager (zdfphy) + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rewrite in preparation for new timestepping scheme + !!---------------------------------------------------------------------- + +#if defined key_qco || defined key_linssh + !!---------------------------------------------------------------------- + !! 'key_qco' EMPTY MODULE Quasi-Eulerian vertical coordinate + !! OR + !! 'key_linssh EMPTY MODULE Fixed in time vertical coordinate + !!---------------------------------------------------------------------- +#else + !!---------------------------------------------------------------------- + !! stp : OCE system time-stepping + !!---------------------------------------------------------------------- + USE step_oce ! time stepping definition modules + + IMPLICIT NONE + PRIVATE + + PUBLIC stp ! called by nemogcm.F90 + + ! !** time level indices **! + INTEGER, PUBLIC :: Nbb, Nnn, Naa, Nrhs !: used by nemo_init + + !! * Substitutions +# include "do_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: step.F90 15398 2021-10-19 08:49:42Z timgraham $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +#if defined key_agrif + RECURSIVE SUBROUTINE stp( ) + INTEGER :: kstp ! ocean time-step index +#else + SUBROUTINE stp( kstp ) + INTEGER, INTENT(in) :: kstp ! ocean time-step index +#endif + !!---------------------------------------------------------------------- + !! *** ROUTINE stp *** + !! + !! ** Purpose : - Time stepping of OCE (momentum and active tracer eqs.) + !! - Time stepping of SI3 (dynamic and thermodynamic eqs.) + !! - Time stepping of TRC (passive tracer eqs.) + !! + !! ** Method : -1- Update forcings and data + !! -2- Update ocean physics + !! -3- Compute the t and s trends + !! -4- Update t and s + !! -5- Compute the momentum trends + !! -6- Update the horizontal velocity + !! -7- Compute the diagnostics variables (rd,N2, hdiv,w) + !! -8- Outputs and diagnostics + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk, jtile ! dummy loop indice + !! --------------------------------------------------------------------- +#if defined key_agrif + IF( nstop > 0 ) RETURN ! avoid to go further if an error was detected during previous time step (child grid) + kstp = nit000 + Agrif_Nb_Step() + Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices + IF( lk_agrif_debug ) THEN + IF( Agrif_Root() .and. lwp) WRITE(*,*) '---' + IF(lwp) WRITE(*,*) 'Grid Number', Agrif_Fixed(),' time step ', kstp, 'int tstep', Agrif_NbStepint() + ENDIF + IF( kstp == nit000 + 1 ) lk_agrif_fstep = .FALSE. +# if defined key_xios + IF( Agrif_Nbstepint() == 0 ) CALL iom_swap( cxios_context ) +# endif +#endif + ! + IF( ln_timing ) CALL timing_start('stp') + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! model timestep + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + IF( l_1st_euler ) THEN ! start or restart with Euler 1st time-step + rDt = rn_Dt + r1_Dt = 1._wp / rDt + ENDIF + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! update I/O and calendar + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + IF( kstp == nit000 ) THEN ! initialize IOM context (must be done after nemo_init for AGRIF+XIOS+OASIS) + CALL iom_init( cxios_context, ld_closedef=.FALSE. ) ! for model grid (including possible AGRIF zoom) + IF( lk_diamlr ) CALL dia_mlr_iom_init ! with additional setup for multiple-linear-regression analysis + CALL iom_init_closedef + IF( ln_crs ) CALL iom_init( TRIM(cxios_context)//"_crs" ) ! for coarse grid + ENDIF + IF( kstp == nitrst .AND. lwxios ) THEN + CALL iom_swap( cw_ocerst_cxt ) + CALL iom_init_closedef( cw_ocerst_cxt ) + CALL iom_setkt( kstp - nit000 + 1, cw_ocerst_cxt ) +#if defined key_top + CALL iom_swap( cw_toprst_cxt ) + CALL iom_init_closedef( cw_toprst_cxt ) + CALL iom_setkt( kstp - nit000 + 1, cw_toprst_cxt ) +#endif + ENDIF + IF( kstp + nn_fsbc - 1 == nitrst .AND. lwxios ) THEN +#if defined key_si3 + CALL iom_swap( cw_icerst_cxt ) + CALL iom_init_closedef( cw_icerst_cxt ) + CALL iom_setkt( kstp - nit000 + 1, cw_icerst_cxt ) +#endif + IF( ln_abl ) THEN + CALL iom_swap( cw_ablrst_cxt ) + CALL iom_init_closedef( cw_ablrst_cxt ) + CALL iom_setkt( kstp - nit000 + 1, cw_ablrst_cxt ) + ENDIF + ENDIF + IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init) + CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell IOM we are at time step kstp + IF( ln_crs ) CALL iom_setkt( kstp - nit000 + 1, TRIM(cxios_context)//"_crs" ) ! tell IOM we are at time step kstp + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Update external forcing (tides, open boundaries, ice shelf interaction and surface boundary condition (including sea-ice) + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_tide ) CALL tide_update( kstp ) ! update tide potential + IF( ln_apr_dyn ) CALL sbc_apr ( kstp ) ! atmospheric pressure (NB: call before bdy_dta which needs ssh_ib) + IF( ln_bdy ) CALL bdy_dta ( kstp, Nnn ) ! update dynamic & tracer data at open boundaries + IF( ln_isf ) CALL isf_stp ( kstp, Nnn ) + CALL sbc ( kstp, Nbb, Nnn ) ! Sea Boundary Condition (including sea-ice) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Update stochastic parameters and random T/S fluctuations + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF( ln_sto_eos ) CALL sto_par( kstp ) ! Stochastic parameters + IF( ln_sto_eos ) CALL sto_pts( ts(:,:,:,:,Nnn) ) ! Random T/S fluctuations + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Ocean physics update + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! THERMODYNAMICS + CALL eos_rab( ts(:,:,:,:,Nbb), rab_b, Nnn ) ! before local thermal/haline expension ratio at T-points + CALL eos_rab( ts(:,:,:,:,Nnn), rab_n, Nnn ) ! now local thermal/haline expension ratio at T-points + CALL bn2 ( ts(:,:,:,:,Nbb), rab_b, rn2b, Nnn ) ! before Brunt-Vaisala frequency + CALL bn2 ( ts(:,:,:,:,Nnn), rab_n, rn2, Nnn ) ! now Brunt-Vaisala frequency + + ! VERTICAL PHYSICS + ! lbc_lnk needed for zdf_sh2 when using nn_hls = 2, moved here to allow tiling in zdf_phy + IF( nn_hls == 2 .AND. l_zdfsh2 ) CALL lbc_lnk( 'stp', avm_k, 'W', 1.0_wp ) + + IF( ln_tile ) CALL dom_tile_start ! [tiling] ZDF tiling loop + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + + CALL zdf_phy( kstp, Nbb, Nnn, Nrhs ) ! vertical physics update (top/bot drag, avt, avs, avm + MLD) + END DO + IF( ln_tile ) CALL dom_tile_stop + + ! LATERAL PHYSICS + ! + IF( ln_zps .OR. l_ldfslp ) CALL eos( ts(:,:,:,:,Nbb), rhd, gdept_0(:,:,:) ) ! before in situ density + + IF( ln_zps .AND. .NOT. ln_isfcav) & + & CALL zps_hde ( kstp, Nnn, jpts, ts(:,:,:,:,Nbb), gtsu, gtsv, & ! Partial steps: before horizontal gradient + & rhd, gru , grv ) ! of t, s, rd at the last ocean level + + IF( ln_zps .AND. ln_isfcav) & + & CALL zps_hde_isf( kstp, Nnn, jpts, ts(:,:,:,:,Nbb), gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF) + & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the first ocean level + + IF( l_ldfslp ) THEN ! slope of lateral mixing + IF( ln_traldf_triad ) THEN + CALL ldf_slp_triad( kstp, Nbb, Nnn ) ! before slope for triad operator + ELSE + CALL ldf_slp ( kstp, rhd, rn2b, Nbb, Nnn ) ! before slope for standard operator + ENDIF + ENDIF + ! ! eddy diffusivity coeff. + IF( l_ldftra_time .OR. l_ldfeiv_time ) CALL ldf_tra( kstp, Nbb, Nnn ) ! and/or eiv coeff. + IF( l_ldfdyn_time ) CALL ldf_dyn( kstp, Nbb ) ! eddy viscosity coeff. + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Ocean dynamics : hdiv, ssh, e3, u, v, w + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + CALL ssh_nxt ( kstp, Nbb, Nnn, ssh, Naa ) ! after ssh (includes call to div_hor) + IF( .NOT.ln_linssh ) & + & CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn, Naa ) ! after vertical scale factors + CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! now cross-level velocity + IF( ln_zad_Aimp ) CALL wAimp ( kstp, Nnn ) ! Adaptive-implicit vertical advection partitioning + CALL eos ( ts(:,:,:,:,Nnn), rhd, rhop, gdept(:,:,:,Nnn) ) ! now in situ density for hpg computation + + + uu(:,:,:,Nrhs) = 0._wp ! set dynamics trends to zero + vv(:,:,:,Nrhs) = 0._wp + + IF( ln_tile ) CALL dom_tile_start ! [tiling] DYN tiling loop (1) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + + IF( lk_asminc .AND. ln_asmiau .AND. ln_dyninc ) & + & CALL dyn_asm_inc ( kstp, Nbb, Nnn, uu, vv, Nrhs ) ! apply dynamics assimilation increment + IF( ln_bkgwri ) CALL asm_bkg_wri( kstp, Nnn ) ! output background fields + IF( ln_bdy ) CALL bdy_dyn3d_dmp ( kstp, Nbb, uu, vv, Nrhs ) ! bdy damping trends +#if defined key_agrif + END DO + IF( ln_tile ) CALL dom_tile_stop + + IF(.NOT. Agrif_Root()) & + & CALL Agrif_Sponge_dyn ! momentum sponge + + IF( ln_tile ) CALL dom_tile_start ! [tiling] DYN tiling loop (1, continued) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) +#endif + CALL dyn_adv( kstp, Nbb, Nnn , uu, vv, Nrhs ) ! advection (VF or FF) ==> RHS + CALL dyn_vor( kstp, Nnn , uu, vv, Nrhs ) ! vorticity ==> RHS + CALL dyn_ldf( kstp, Nbb, Nnn , uu, vv, Nrhs ) ! lateral mixing + IF( ln_zdfosm ) CALL dyn_osm( kstp, Nnn , uu, vv, Nrhs ) ! OSMOSIS non-local velocity fluxes ==> RHS + CALL dyn_hpg( kstp, Nnn , uu, vv, Nrhs ) ! horizontal gradient of Hydrostatic pressure + END DO + IF( ln_tile ) CALL dom_tile_stop + + CALL dyn_spg( kstp, Nbb, Nnn, Nrhs, uu, vv, ssh, uu_b, vv_b, Naa ) ! surface pressure gradient + + ! With split-explicit free surface, since now transports have been updated and ssh(:,:,Nrhs) as well + IF( ln_dynspg_ts ) THEN ! vertical scale factors and vertical velocity need to be updated + IF( ln_tile ) CALL dom_tile_start ! [tiling] DYN tiling loop (2- div_hor only) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + + CALL div_hor ( kstp, Nbb, Nnn ) ! Horizontal divergence (2nd call in time-split case) + END DO + IF( ln_tile ) CALL dom_tile_stop + + IF(.NOT. ln_linssh) CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn, Naa, kcall=2 ) ! after vertical scale factors (update depth average component) + ENDIF + + IF( ln_tile ) CALL dom_tile_start ! [tiling] DYN tiling loop (3- dyn_zdf only) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + + CALL dyn_zdf ( kstp, Nbb, Nnn, Nrhs, uu, vv, Naa ) ! vertical diffusion + END DO + IF( ln_tile ) CALL dom_tile_stop + + IF( ln_dynspg_ts ) THEN ! vertical scale factors and vertical velocity need to be updated + CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! Nnn cross-level velocity + IF( ln_zad_Aimp ) CALL wAimp ( kstp, Nnn ) ! Adaptive-implicit vertical advection partitioning + ENDIF + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! cool skin + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF ( ln_diurnal ) CALL diurnal_layers( kstp ) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! diagnostics and outputs + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_floats ) CALL flo_stp ( kstp, Nbb, Nnn ) ! drifting Floats + IF( ln_diacfl ) CALL dia_cfl ( kstp, Nnn ) ! Courant number diagnostics + CALL dia_hth ( kstp, Nnn ) ! Thermocline depth (20 degres isotherm depth) + IF( ln_diadct ) CALL dia_dct ( kstp, Nnn ) ! Transports + CALL dia_ar5 ( kstp, Nnn ) ! ar5 diag + CALL dia_ptr ( kstp, Nnn ) ! Poleward adv/ldf TRansports diagnostics + CALL dia_wri ( kstp, Nnn ) ! ocean model: outputs + IF( ln_crs ) CALL crs_fld ( kstp, Nnn ) ! ocean model: online field coarsening & output + IF( lk_diadetide ) CALL dia_detide( kstp ) ! Weights computation for daily detiding of model diagnostics + IF( lk_diamlr ) CALL dia_mlr ! Update time used in multiple-linear-regression analysis + +#if defined key_top + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Passive Tracer Model + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL trc_stp ( kstp, Nbb, Nnn, Nrhs, Naa ) ! time-stepping +#endif + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Active tracers + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ts(:,:,:,:,Nrhs) = 0._wp ! set tracer trends to zero + + IF( ln_tile ) CALL dom_tile_start ! [tiling] TRA tiling loop (1) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + + IF( lk_asminc .AND. ln_asmiau .AND. & + & ln_trainc ) CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs ) ! apply tracer assimilation increment + CALL tra_sbc ( kstp, Nnn, ts, Nrhs ) ! surface boundary condition + IF( ln_traqsr ) CALL tra_qsr ( kstp, Nnn, ts, Nrhs ) ! penetrative solar radiation qsr + IF( ln_isf ) CALL tra_isf ( kstp, Nnn, ts, Nrhs ) ! ice shelf heat flux + IF( ln_trabbc ) CALL tra_bbc ( kstp, Nnn, ts, Nrhs ) ! bottom heat flux + IF( ln_trabbl ) CALL tra_bbl ( kstp, Nbb, Nnn, ts, Nrhs ) ! advective (and/or diffusive) bottom boundary layer scheme + IF( ln_tradmp ) CALL tra_dmp ( kstp, Nbb, Nnn, ts, Nrhs ) ! internal damping trends + IF( ln_bdy ) CALL bdy_tra_dmp( kstp, Nbb, ts, Nrhs ) ! bdy damping trends + END DO + IF( ln_tile ) CALL dom_tile_stop + +#if defined key_agrif + IF(.NOT. Agrif_Root() ) THEN + CALL Agrif_Sponge_tra ! tracers sponge + ENDIF +#endif + + ! TEMP: [tiling] Separate loop over tile domains (due to tra_adv workarounds for tiling) + IF( ln_tile ) CALL dom_tile_start ! [tiling] TRA tiling loop (2) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + + CALL tra_adv ( kstp, Nbb, Nnn, ts, Nrhs ) ! hor. + vert. advection ==> RHS + IF( ln_zdfmfc ) CALL tra_mfc ( kstp, Nbb, ts, Nrhs ) ! Mass Flux Convection + IF( ln_zdfosm ) THEN + CALL tra_osm ( kstp, Nnn, ts, Nrhs ) ! OSMOSIS non-local tracer fluxes ==> RHS + IF( lrst_oce ) CALL osm_rst ( kstp, Nnn, 'WRITE' ) ! write OSMOSIS outputs + ww (so must do here) to restarts + ENDIF + CALL tra_ldf ( kstp, Nbb, Nnn, ts, Nrhs ) ! lateral mixing + + CALL tra_zdf ( kstp, Nbb, Nnn, Nrhs, ts, Naa ) ! vertical mixing and after tracer fields + IF( ln_zdfnpc ) CALL tra_npc ( kstp, Nnn, Nrhs, ts, Naa ) ! update after fields by non-penetrative convection + END DO + IF( ln_tile ) CALL dom_tile_stop + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Set boundary conditions, time filter and swap time levels + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +!!jc1: For agrif, it would be much better to finalize tracers/momentum here (e.g. bdy conditions) and move the swap +!! (and time filtering) after Agrif update. Then restart would be done after and would contain updated fields. +!! If so: +!! (i) no need to call agrif update at initialization time +!! (ii) no need to update "before" fields +!! +!! Apart from creating new tra_swp/dyn_swp routines, this however: +!! (i) makes boundary conditions at initialization time computed from updated fields which is not the case between +!! two restarts => restartability issue. One can circumvent this, maybe, by assuming "interface separation", +!! e.g. a shift of the feedback interface inside child domain. +!! (ii) requires that all restart outputs of updated variables by agrif (e.g. passive tracers/tke/barotropic arrays) are done at the same +!! place. +!! +!!jc2: dynnxt must be the latest call. e3t(:,:,:,Nbb) are indeed updated in that routine + CALL tra_atf ( kstp, Nbb, Nnn, Naa, ts ) ! time filtering of "now" tracer arrays + CALL dyn_atf ( kstp, Nbb, Nnn, Naa, uu, vv, e3t, e3u, e3v ) ! time filtering of "now" velocities and scale factors + CALL ssh_atf ( kstp, Nbb, Nnn, Naa, ssh ) ! time filtering of "now" sea surface height + ! + ! Swap time levels + Nrhs = Nbb + Nbb = Nnn + Nnn = Naa + Naa = Nrhs + ! + IF(.NOT.ln_linssh) CALL dom_vvl_sf_update( kstp, Nbb, Nnn, Naa ) ! recompute vertical scale factors + ! + IF( ln_diahsb ) CALL dia_hsb ( kstp, Nbb, Nnn ) ! - ML - global conservation diagnostics + +!!gm : This does not only concern the dynamics ==>>> add a new title +!!gm2: why ouput restart before AGRIF update? +!! +!!jc: That would be better, but see comment above +!! + IF( lrst_oce ) CALL rst_write ( kstp, Nbb, Nnn ) ! write output ocean restart file + IF( ln_sto_eos ) CALL sto_rst_write( kstp ) ! write restart file for stochastic parameters + +#if defined key_agrif + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! AGRIF recursive integration + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices + CALL Agrif_Integrate_ChildGrids( stp ) ! allows to finish all the Child Grids before updating + +#endif + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Control + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL stp_ctl ( kstp, Nnn ) + +#if defined key_agrif + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! AGRIF update + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( Agrif_NbStepint() == 0 .AND. nstop == 0 ) & + & CALL Agrif_update_all( ) ! Update all components + +#endif + IF( ln_diaobs .AND. nstop == 0 ) & + & CALL dia_obs( kstp, Nnn ) ! obs-minus-model (assimilation) diags (after dynamics update) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! File manipulation at the end of the first time step + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( kstp == nit000 ) THEN ! 1st time step only + CALL iom_close( numror ) ! close input ocean restart file + IF( lrxios ) CALL iom_context_finalize( cr_ocerst_cxt ) + IF(lwm) CALL FLUSH ( numond ) ! flush output namelist oce + IF(lwm .AND. numoni /= -1 ) CALL FLUSH ( numoni ) ! flush output namelist ice (if exist) + ENDIF + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Coupled mode + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( lk_oasis .AND. nstop == 0 ) CALL sbc_cpl_snd( kstp, Nbb, Nnn ) ! coupled mode : field exchanges + ! +#if defined key_xios + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Finalize contextes if end of simulation or error detected + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( kstp == nitend .OR. nstop > 0 ) THEN + CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF + IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! + ENDIF +#endif + ! + IF( l_1st_euler ) THEN ! recover Leap-frog timestep + rDt = 2._wp * rn_Dt + r1_Dt = 1._wp / rDt + l_1st_euler = .FALSE. + ENDIF + ! + IF( ln_timing ) CALL timing_stop('stp') + ! + END SUBROUTINE stp + ! +#endif + !!====================================================================== +END MODULE step \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/step_oce.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/step_oce.F90 new file mode 100644 index 0000000..55ddf07 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/step_oce.F90 @@ -0,0 +1,123 @@ +MODULE step_oce + !!====================================================================== + !! *** MODULE step_oce *** + !! Ocean time-stepping : module used in both initialisation phase and time stepping + !! (i.e. nemo_init and stp or stp_MLF routines) + !!====================================================================== + !! History : 3.3 ! 2010-08 (C. Ethe) Original code - reorganisation of the initial phase + !! 3.7 ! 2014-01 (G. Madec) LDF simplication + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE domtile + + USE daymod ! calendar (day routine) + + USE sbc_oce ! surface boundary condition: ocean + USE sbcmod ! surface boundary condition (sbc routine) + USE sbcrnf ! surface boundary condition: runoff variables + USE sbccpl ! surface boundary condition: coupled formulation (call send at end of step) + USE sbcapr ! surface boundary condition: atmospheric pressure + USE sbcwave ! Wave intialisation + USE tide_mod ! tides + + USE bdy_oce , ONLY : ln_bdy + USE bdydta ! open boundary condition data (bdy_dta routine) + USE bdytra ! bdy cond. for tracers (bdy_tra routine) + USE bdydyn3d ! bdy cond. for baroclinic vel. (bdy_dyn3d routine) + + USE isf_oce ! ice shelf boundary condition + USE isfstp ! ice shelf boundary condition (isf_stp routine) + + USE sshwzv ! vertical velocity and ssh (ssh_nxt routine) + ! (ssh_swp routine) + ! (wzv routine) + USE domvvl ! variable vertical scale factors (dom_vvl_sf_nxt routine) + ! (dom_vvl_sf_swp routine) + + USE divhor ! horizontal divergence (div_hor routine) + USE dynadv ! advection (dyn_adv routine) + USE dynvor ! vorticity term (dyn_vor routine) + USE dynhpg ! hydrostatic pressure grad. (dyn_hpg routine) + USE dynldf ! lateral momentum diffusion (dyn_ldf routine) + USE dynzdf ! vertical diffusion (dyn_zdf routine) + USE dynspg ! surface pressure gradient (dyn_spg routine) + USE dynatf ! time-filtering (dyn_atf routine) + USE dyndmp ! current damping (dyn_dmp routine) + + USE traqsr ! solar radiation penetration (tra_qsr routine) + USE traisf ! ice shelf (tra_isf routine) + USE trasbc ! surface boundary condition (tra_sbc routine) + USE trabbc ! bottom boundary condition (tra_bbc routine) + USE trabbl ! bottom boundary layer (tra_bbl routine) + USE tradmp ! internal damping (tra_dmp routine) + USE traadv ! advection scheme control (tra_adv_ctl routine) + USE traldf ! lateral mixing (tra_ldf routine) + USE trazdf ! vertical mixing (tra_zdf routine) + USE traatf ! time filtering (tra_atf routine) + USE tranpc ! non-penetrative convection (tra_npc routine) + + USE eosbn2 ! equation of state (eos_bn2 routine) + + USE stopar ! Stochastic parametrization (sto_par routine) + USE stopts + + USE ldfslp ! iso-neutral slopes (ldf_slp routine) + USE ldfdyn ! lateral eddy viscosity coef. (ldf_dyn routine) + USE ldftra ! lateral eddy diffusive coef. (ldf_tra routine) + + USE zdf_oce ! ocean vertical physics variables + USE zdfphy ! vertical physics manager (zdf_phy_init routine) + USE zdfdrg , ONLY : ln_drgimp ! implicit top/bottom friction + USE zdfosm , ONLY : osm_rst, dyn_osm, tra_osm ! OSMOSIS routines used in step.F90 + USE zdfmfc ! Mass FLux Convection routine used in step.F90 + + USE diu_layers ! diurnal SST bulk and coolskin routines + USE sbc_oce ! surface fluxes + + USE zpshde ! partial step: hor. derivative (zps_hde routine) + + USE diawri ! Standard run outputs (dia_wri routine) + USE diaptr ! poleward transports (dia_ptr routine) + USE diadct ! sections transports (dia_dct routine) + USE diaar5 ! AR5 diagnosics (dia_ar5 routine) + USE diahth ! thermocline depth (dia_hth routine) + USE diahsb ! heat, salt and volume budgets (dia_hsb routine) + USE diacfl ! CFL diagnostics (dia_cfl routine) + USE diaobs ! Observation operator (dia_obs routine) + USE diadetide ! Weights computation for daily detiding of model diagnostics + USE diamlr ! IOM context management for multiple-linear-regression analysis + USE flo_oce ! floats variables + USE floats ! floats computation (flo_stp routine) + + USE crsfld ! Standard output on coarse grid (crs_fld routine) + + USE asminc ! assimilation increments (tra_asm_inc routine) + ! (dyn_asm_inc routine) + USE asmbkg ! writing out state trajectory + USE stpctl ! time stepping control (stp_ctl routine) + USE restart ! ocean restart (rst_wri routine) + USE prtctl ! Print control (prt_ctl routine) + + USE in_out_manager ! I/O manager + USE iom ! + USE lbclnk + USE timing ! Timing + +#if defined key_xios + USE xios ! I/O server +#endif +#if defined key_agrif + USE agrif_oce_sponge ! Momemtum and tracers sponges + USE agrif_all_update ! Main update driver + USE agrif_oce_update +#endif +#if defined key_top + USE trcstp, ONLY : trc_stp ! passive tracer time-stepping (trc_stp routine) +#endif + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: step_oce.F90 15023 2021-06-18 14:35:25Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE step_oce \ No newline at end of file diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/stpctl.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/stpctl.F90 new file mode 100644 index 0000000..285547c --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/stpctl.F90 @@ -0,0 +1,331 @@ +MODULE stpctl + !!====================================================================== + !! *** MODULE stpctl *** + !! Ocean run control : gross check of the ocean time stepping + !!====================================================================== + !! History : OPA ! 1991-03 (G. Madec) Original code + !! 6.0 ! 1992-06 (M. Imbard) + !! 8.0 ! 1997-06 (A.M. Treguier) + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! 2.0 ! 2009-07 (G. Madec) Add statistic for time-spliting + !! 3.7 ! 2016-09 (G. Madec) Remove solver + !! 4.0 ! 2017-04 (G. Madec) regroup global communications + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! stp_ctl : Control the run + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain variables + USE zdf_oce , ONLY : ln_zad_Aimp ! ocean vertical physics variables + USE wet_dry, ONLY : ll_wd, ssh_ref ! reference depth for negative bathy + ! + USE diawri ! Standard run outputs (dia_wri_state routine) + USE in_out_manager ! I/O manager + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing + USE eosbn2, ONLY: ln_SEOS, rn_b0 + ! + USE netcdf ! NetCDF library + IMPLICIT NONE + PRIVATE + + PUBLIC stp_ctl ! routine called by step.F90 + + INTEGER, PARAMETER :: jpvar = 8 + INTEGER :: nrunid ! netcdf file id + INTEGER, DIMENSION(jpvar) :: nvarid ! netcdf variable id + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: stpctl.F90 15023 2021-06-18 14:35:25Z gsamson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +# include "single_precision_substitute.h90" +# include "single_precision_substitute.h90" +CONTAINS + + SUBROUTINE stp_ctl( kt, Kmm ) + !!---------------------------------------------------------------------- + !! *** ROUTINE stp_ctl *** + !! + !! ** Purpose : Control the run + !! + !! ** Method : - Save the time step in numstp + !! - Stop the run IF problem encountered by setting nstop > 0 + !! Problems checked: |ssh| maximum larger than 10 m + !! |U| maximum larger than 10 m/s + !! negative sea surface salinity + !! + !! ** Actions : "time.step" file = last ocean time-step + !! "run.stat" file = run statistics + !! nstop indicator sheared among all local domain + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time-step index + INTEGER, INTENT(in ) :: Kmm ! ocean time level index + !! + INTEGER, PARAMETER :: jptst = 4 + INTEGER :: ji ! dummy loop indices + INTEGER :: idtime, istatus + INTEGER , DIMENSION(jptst) :: iareasum, iareamin, iareamax + INTEGER , DIMENSION(3,jptst) :: iloc ! min/max loc indices + REAL(dp) :: zzz, zminsal, zmaxsal ! local real + REAL(dp), DIMENSION(jpvar+1) :: zmax + REAL(dp), DIMENSION(jptst) :: zmaxlocal + LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns, ll_0oce + LOGICAL, DIMENSION(jpi,jpj,jpk) :: llmsk + CHARACTER(len=20) :: clname + !!---------------------------------------------------------------------- + IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid + ! + ll_wrtstp = ( MOD( kt-nit000, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) + ll_colruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. jpnij > 1 + ll_wrtruns = sn_cfctl%l_runstat .AND. ll_wrtstp .AND. lwm + ! + IF( kt == nit000 ) THEN + ! + IF( lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'stp_ctl : time-stepping control' + WRITE(numout,*) '~~~~~~~' + ENDIF + ! ! open time.step ascii file, done only by 1st subdomain + IF( lwm ) CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) + ! + IF( ll_wrtruns ) THEN + ! ! open run.stat ascii file, done only by 1st subdomain + CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) + ! ! open run.stat.nc netcdf file, done only by 1st subdomain + clname = 'run.stat.nc' + IF( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) + istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, nrunid ) + istatus = NF90_DEF_DIM( nrunid, 'time', NF90_UNLIMITED, idtime ) + istatus = NF90_DEF_VAR( nrunid, 'abs_ssh_max', NF90_DOUBLE, (/ idtime /), nvarid(1) ) + istatus = NF90_DEF_VAR( nrunid, 'abs_u_max', NF90_DOUBLE, (/ idtime /), nvarid(2) ) + istatus = NF90_DEF_VAR( nrunid, 's_min', NF90_DOUBLE, (/ idtime /), nvarid(3) ) + istatus = NF90_DEF_VAR( nrunid, 's_max', NF90_DOUBLE, (/ idtime /), nvarid(4) ) + istatus = NF90_DEF_VAR( nrunid, 't_min', NF90_DOUBLE, (/ idtime /), nvarid(5) ) + istatus = NF90_DEF_VAR( nrunid, 't_max', NF90_DOUBLE, (/ idtime /), nvarid(6) ) + IF( ln_zad_Aimp ) THEN + istatus = NF90_DEF_VAR( nrunid, 'Cf_max', NF90_DOUBLE, (/ idtime /), nvarid(7) ) + istatus = NF90_DEF_VAR( nrunid,'abs_wi_max',NF90_DOUBLE, (/ idtime /), nvarid(8) ) + ENDIF + istatus = NF90_ENDDEF(nrunid) + ENDIF + ! + ENDIF + ! + ! !== write current time step ==! + ! !== done only by 1st subdomain at writting timestep ==! + IF( lwm .AND. ll_wrtstp ) THEN + WRITE ( numstp, '(1x, i8)' ) kt + REWIND( numstp ) + ENDIF + ! !== test of local extrema ==! + ! !== done by all processes at every time step ==! + ! + llmsk( 1:nn_hls,:,:) = .FALSE. ! exclude halos from the checked region + llmsk(Nie0+1: jpi,:,:) = .FALSE. + llmsk(:, 1:nn_hls,:) = .FALSE. + llmsk(:,Nje0+1: jpj,:) = .FALSE. + ! + llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0) == 1._wp ! define only the inner domain + ! + ll_0oce = .NOT. ANY( llmsk(:,:,1) ) ! no ocean point in the inner domain? + ! + IF( ll_wd ) THEN + zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) + ssh_ref ), mask = llmsk(:,:,1) ) ! ssh max + ELSE + zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) ), mask = llmsk(:,:,1) ) ! ssh max + ENDIF + llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + zmax(2) = MAXVAL( ABS( uu(:,:,:,Kmm) ), mask = llmsk ) ! velocity max (zonal only) + llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + zmax(3) = MAXVAL( -ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! minus salinity max + zmax(4) = MAXVAL( ts(:,:,:,jp_sal,Kmm), mask = llmsk ) ! salinity max + IF( ll_colruns .OR. jpnij == 1 ) THEN ! following variables are used only in the netcdf file + zmax(5) = MAXVAL( -ts(:,:,:,jp_tem,Kmm), mask = llmsk ) ! minus temperature max + zmax(6) = MAXVAL( ts(:,:,:,jp_tem,Kmm), mask = llmsk ) ! temperature max + IF( ln_zad_Aimp ) THEN + zmax(7) = MAXVAL( Cu_adv(:,:,:) , mask = llmsk ) ! partitioning coeff. max + llmsk(:,:,:) = wmask(:,:,:) == 1._wp + zmax(8) = MAXVAL( ABS( wi(:,:,:) ) , mask = llmsk ) ! implicit vertical vel. max + ELSE + zmax(7:8) = 0._wp + ENDIF + ELSE + zmax(5:8) = 0._wp + ENDIF + zmax(jpvar+1) = REAL( nstop, wp ) ! stop indicator + ! + ! !== get global extrema ==! + ! !== done by all processes if writting run.stat ==! + IF( ll_colruns ) THEN + zmaxlocal(:) = zmax(1:jptst) + CALL mpp_max( "stpctl", zmax ) ! max over the global domain: ok even of ll_0oce = .true. + nstop = NINT( zmax(jpvar+1) ) ! update nstop indicator (now sheared among all local domains) + ELSE + ! if no ocean point: MAXVAL returns -HUGE => we must overwrite this value to avoid error handling bellow. + IF( ll_0oce ) zmax(1:jptst) = (/ 0._wp, 0._wp, -1._wp, 1._wp /) ! default "valid" values... + ENDIF + ! + zmax(3) = -zmax(3) ! move back from max(-zz) to min(zz) : easier to manage! + zmax(5) = -zmax(5) ! move back from max(-zz) to min(zz) : easier to manage! + IF( ll_colruns ) zmaxlocal(3) = -zmaxlocal(3) ! move back from max(-zz) to min(zz) : easier to manage! + ! + ! !== write "run.stat" files ==! + ! !== done only by 1st subdomain at writting timestep ==! + IF( ll_wrtruns ) THEN + WRITE(numrun,9500) kt, zmax(1:jptst) + IF( jpnij == 1 ) CALL FLUSH(numrun) + DO ji = 1, jpvar - 2 * COUNT( .NOT. (/ln_zad_Aimp/) ) + istatus = NF90_PUT_VAR( nrunid, nvarid(ji), (/zmax(ji)/), (/kt/), (/1/) ) + END DO + IF( kt == nitend ) istatus = NF90_CLOSE(nrunid) + END IF + ! !== error handling ==! + ! !== done by all processes at every time step ==! + ! + IF ( ln_SEOS.AND.(rn_b0==0._wp) ) THEN ! Discard checks on salinity + zmaxsal = HUGE(1._wp) ! if not used in eos + zminsal = -HUGE(1._wp) + ELSE + zmaxsal = 100._wp + zminsal = 0._wp + ENDIF + ! + IF( zmax(1) > 20._wp .OR. & ! too large sea surface height ( > 20 m ) + & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s) + & zmax(3) <= zminsal .OR. & ! negative or zero sea surface salinity + & zmax(4) >= zmaxsal .OR. & ! too large sea surface salinity ( > 100 ) + & zmax(4) < zminsal .OR. & ! too large sea surface salinity (keep this line for sea-ice) + & ISNAN( SUM(zmax(1:jptst)) ) .OR. & ! NaN encounter in the tests + & ABS( SUM(zmax(1:jptst)) ) > HUGE(1._wp) ) THEN ! Infinity encounter in the tests + ! + iloc(:,:) = 0 + IF( ll_colruns ) THEN ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc + ! first: close the netcdf file, so we can read it + IF( lwm .AND. kt /= nitend ) istatus = NF90_CLOSE(nrunid) + ! get global loc on the min/max + llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain + CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:, Kmm)), llmsk(:,:,1), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F + llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL mpp_maxloc( 'stpctl', CASTDP(ABS( uu(:,:,:, Kmm))), llmsk(:,:,:), zzz, iloc(1:3,2) ) + llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + CALL mpp_minloc( 'stpctl', ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,3) ) + CALL mpp_maxloc( 'stpctl', CASTDP(ts(:,:,:,jp_sal,Kmm)) , llmsk(:,:,:), zzz, iloc(1:3,4) ) + ! find which subdomain has the max. + iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 + DO ji = 1, jptst + IF( zmaxlocal(ji) == zmax(ji) ) THEN + iareamin(ji) = narea ; iareamax(ji) = narea ; iareasum(ji) = 1 + ENDIF + END DO + CALL mpp_min( "stpctl", iareamin ) ! min over the global domain + CALL mpp_max( "stpctl", iareamax ) ! max over the global domain + CALL mpp_sum( "stpctl", iareasum ) ! sum over the global domain + ELSE ! find local min and max locations: + ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc + llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp ! define only the inner domain + iloc(1:2,1) = MAXLOC( ABS( ssh(:,:, Kmm)), mask = llmsk(:,:,1) ) + llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + iloc(1:3,2) = MAXLOC( ABS( uu(:,:,:, Kmm)), mask = llmsk(:,:,:) ) + llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain + iloc(1:3,3) = MINLOC( ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) + iloc(1:3,4) = MAXLOC( ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) + DO ji = 1, jptst ! local domain indices ==> global domain indices, excluding halos + iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /) + END DO + iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information + ENDIF + ! + WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m or |U| > 10 m/s or S <= 0 or S >= 100 or NaN encounter in the tests' + CALL wrt_line( ctmp2, kt, '|ssh| max', REAL(zmax(1),wp), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) + CALL wrt_line( ctmp3, kt, '|U| max', REAL(zmax(2),wp), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) + CALL wrt_line( ctmp4, kt, 'Sal min', REAL(zmax(3),wp), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) ) + CALL wrt_line( ctmp5, kt, 'Sal max', REAL(zmax(4),wp), iloc(:,4), iareasum(4), iareamin(4), iareamax(4) ) + IF( Agrif_Root() ) THEN + WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files' + ELSE + WRITE(ctmp6,*) ' ===> output of last computed fields in '//TRIM(Agrif_CFixed())//'_output.abort* files' + ENDIF + ! + CALL dia_wri_state( Kmm, 'output.abort' ) ! create an output.abort file + ! + IF( ll_colruns .OR. jpnij == 1 ) THEN ! all processes synchronized -> use lwp to print in opened ocean.output files + IF(lwp) THEN ; CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) + ELSE ; nstop = MAX(1, nstop) ! make sure nstop > 0 (automatically done when calling ctl_stop) + ENDIF + ELSE ! only mpi subdomains with errors are here -> STOP now + CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) + ENDIF + ! + ENDIF + ! + IF( nstop > 0 ) THEN ! an error was detected and we did not abort yet... + ngrdstop = Agrif_Fixed() ! store which grid got this error + IF( .NOT. ll_colruns .AND. jpnij > 1 ) CALL ctl_stop( 'STOP' ) ! we must abort here to avoid MPI deadlock + ENDIF + ! +9500 FORMAT(' it :', i8, ' |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16) + ! + END SUBROUTINE stp_ctl + + + SUBROUTINE wrt_line( cdline, kt, cdprefix, pval, kloc, ksum, kmin, kmax ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wrt_line *** + !! + !! ** Purpose : write information line + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT( out) :: cdline + CHARACTER(len=*), INTENT(in ) :: cdprefix + REAL(wp), INTENT(in ) :: pval + INTEGER, DIMENSION(3), INTENT(in ) :: kloc + INTEGER, INTENT(in ) :: kt, ksum, kmin, kmax + ! + CHARACTER(len=80) :: clsuff + CHARACTER(len=9 ) :: clkt, clsum, clmin, clmax + CHARACTER(len=9 ) :: cli, clj, clk + CHARACTER(len=1 ) :: clfmt + CHARACTER(len=4 ) :: cl4 ! needed to be able to compile with Agrif, I don't know why + INTEGER :: ifmtk + !!---------------------------------------------------------------------- + WRITE(clkt , '(i9)') kt + + WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij ,wp))) + 1 ! how many digits to we need to write ? (we decide max = 9) + !!! WRITE(clsum, '(i'//clfmt//')') ksum ! this is creating a compilation error with AGRIF + cl4 = '(i'//clfmt//')' ; WRITE(clsum, cl4) ksum + WRITE(clfmt, '(i1)') INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1 ! how many digits to we need to write ? (we decide max = 9) + cl4 = '(i'//clfmt//')' ; WRITE(clmin, cl4) kmin-1 + WRITE(clmax, cl4) kmax-1 + ! + WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,wp))) + 1 ! how many digits to we need to write jpiglo? (we decide max = 9) + cl4 = '(i'//clfmt//')' ; WRITE(cli, cl4) kloc(1) ! this is ok with AGRIF + WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpjglo,wp))) + 1 ! how many digits to we need to write jpjglo? (we decide max = 9) + cl4 = '(i'//clfmt//')' ; WRITE(clj, cl4) kloc(2) ! this is ok with AGRIF + ! + IF( ksum == 1 ) THEN ; WRITE(clsuff,9100) TRIM(clmin) + ELSE ; WRITE(clsuff,9200) TRIM(clsum), TRIM(clmin), TRIM(clmax) + ENDIF + IF(kloc(3) == 0) THEN + ifmtk = INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9) + clk = REPEAT(' ', ifmtk) ! create the equivalent in blank string + WRITE(cdline,9300) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), clk(1:ifmtk), TRIM(clsuff) + ELSE + WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,wp))) + 1 ! how many digits to we need to write jpk? (we decide max = 9) + !!! WRITE(clk, '(i'//clfmt//')') kloc(3) ! this is creating a compilation error with AGRIF + cl4 = '(i'//clfmt//')' ; WRITE(clk, cl4) kloc(3) ! this is ok with AGRIF + WRITE(cdline,9400) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), TRIM(clk), TRIM(clsuff) + ENDIF + ! +9100 FORMAT('MPI rank ', a) +9200 FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a) +9300 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j ', a, ' ', a, ' ', a, ' ', a) +9400 FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a) + ! + END SUBROUTINE wrt_line + + + !!====================================================================== +END MODULE stpctl diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/stpmlf.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/stpmlf.F90 new file mode 100644 index 0000000..1b4ffb7 --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/stpmlf.F90 @@ -0,0 +1,576 @@ +MODULE stpmlf + !!====================================================================== + !! *** MODULE stpMLF *** + !! Time-stepping : manager of the ocean, tracer and ice time stepping + !! using Modified Leap Frog for OCE + !!====================================================================== + !! History : OPA ! 1991-03 (G. Madec) Original code + !! - ! 1991-11 (G. Madec) + !! - ! 1992-06 (M. Imbard) add a first output record + !! - ! 1996-04 (G. Madec) introduction of dynspg + !! - ! 1996-04 (M.A. Foujols) introduction of passive tracer + !! 8.0 ! 1997-06 (G. Madec) new architecture of call + !! 8.2 ! 1997-06 (G. Madec, M. Imbard, G. Roullet) free surface + !! - ! 1999-02 (G. Madec, N. Grima) hpg implicit + !! - ! 2000-07 (J-M Molines, M. Imbard) Open Bondary Conditions + !! NEMO 1.0 ! 2002-06 (G. Madec) free form, suppress macro-tasking + !! - ! 2004-08 (C. Talandier) New trends organization + !! - ! 2005-01 (C. Ethe) Add the KPP closure scheme + !! - ! 2005-11 (G. Madec) Reorganisation of tra and dyn calls + !! - ! 2006-01 (L. Debreu, C. Mazauric) Agrif implementation + !! - ! 2006-07 (S. Masson) restart using iom + !! 3.2 ! 2009-02 (G. Madec, R. Benshila) reintroduicing z*-coordinate + !! - ! 2009-06 (S. Masson, G. Madec) TKE restart compatible with key_cpl + !! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface + !! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + merge TRC-TRA + !! 3.4 ! 2011-04 (G. Madec, C. Ethe) Merge of dtatem and dtasal + !! 3.6 ! 2012-07 (J. Simeon, G. Madec. C. Ethe) Online coarsening of outputs + !! 3.6 ! 2014-04 (F. Roquet, G. Madec) New equations of state + !! 3.6 ! 2014-10 (E. Clementi, P. Oddo) Add Qiao vertical mixing in case of waves + !! 3.7 ! 2014-10 (G. Madec) LDF simplication + !! - ! 2014-12 (G. Madec) remove KPP scheme + !! - ! 2015-11 (J. Chanut) free surface simplification (remove filtered free surface) + !! 4.0 ! 2017-05 (G. Madec) introduction of the vertical physics manager (zdfphy) + !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rewrite in preparation for new timestepping scheme + !! 4.x ! 2020-08 (S. Techene, G. Madec) quasi eulerian coordinate time stepping + !!---------------------------------------------------------------------- +#if defined key_qco || defined key_linssh + !!---------------------------------------------------------------------- + !! 'key_qco' Quasi-Eulerian vertical coordinate + !! OR + !! 'key_linssh Fixed in time vertical coordinate + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + !! stp_MLF : NEMO modified Leap Frog time-stepping with qco or linssh + !!---------------------------------------------------------------------- + USE step_oce ! time stepping definition modules + ! + USE domqco ! quasi-eulerian coordinate + USE traatf_qco ! time filtering (tra_atf_qco routine) + USE dynatf_qco ! time filtering (dyn_atf_qco routine) + + IMPLICIT NONE + PRIVATE + + PUBLIC stp_MLF ! called by nemogcm.F90 + + ! !** time level indices **! + INTEGER, PUBLIC :: Nbb, Nnn, Naa, Nrhs !: used by nemo_init + + !! * Substitutions +# include "do_loop_substitute.h90" +# include "domzgr_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: step.F90 12377 2020-02-12 14:39:06Z acc $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +#if defined key_agrif + RECURSIVE SUBROUTINE stp_MLF( ) + INTEGER :: kstp ! ocean time-step index + +#else + SUBROUTINE stp_MLF( kstp ) + INTEGER, INTENT(in) :: kstp ! ocean time-step index +#endif + !!---------------------------------------------------------------------- + !! *** ROUTINE stp_MLF *** + !! + !! ** Purpose : - Time stepping of OCE (momentum and active tracer eqs.) + !! - Time stepping of SI3 (dynamic and thermodynamic eqs.) + !! - Time stepping of TRC (passive tracer eqs.) + !! + !! ** Method : -1- Update forcings and data + !! -2- Update ocean physics + !! -3- Compute the t and s trends + !! -4- Update t and s + !! -5- Compute the momentum trends + !! -6- Update the horizontal velocity + !! -7- Compute the diagnostics variables (rd,N2, hdiv,w) + !! -8- Outputs and diagnostics + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk, jtile ! dummy loop indice + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zgdept + !! --------------------------------------------------------------------- +#if defined key_agrif + IF( nstop > 0 ) RETURN ! avoid to go further if an error was detected during previous time step (child grid) + kstp = nit000 + Agrif_Nb_Step() + Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices + IF( lk_agrif_debug ) THEN + IF( Agrif_Root() .and. lwp) WRITE(*,*) '---' + IF(lwp) WRITE(*,*) 'Grid Number', Agrif_Fixed(),' time step ', kstp, 'int tstep', Agrif_NbStepint() + ENDIF + IF( kstp == nit000 + 1 ) lk_agrif_fstep = .FALSE. +# if defined key_xios + IF( Agrif_Nbstepint() == 0 ) CALL iom_swap( cxios_context ) +# endif +#endif + ! + IF( ln_timing ) CALL timing_start('stp_MLF') + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! model timestep + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + IF( l_1st_euler ) THEN ! start or restart with Euler 1st time-step + rDt = rn_Dt + r1_Dt = 1._wp / rDt + ENDIF + ! + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! update I/O and calendar + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + IF( kstp == nit000 ) THEN ! initialize IOM context (must be done after nemo_init for AGRIF+XIOS+OASIS) + CALL iom_init( cxios_context, ld_closedef=.FALSE. ) ! for model grid (including possible AGRIF zoom) + IF( lk_diamlr ) CALL dia_mlr_iom_init ! with additional setup for multiple-linear-regression analysis + CALL iom_init_closedef + IF( ln_crs ) CALL iom_init( TRIM(cxios_context)//"_crs" ) ! for coarse grid + ENDIF + IF( kstp == nitrst .AND. lwxios ) THEN + CALL iom_swap( cw_ocerst_cxt ) + CALL iom_init_closedef( cw_ocerst_cxt ) + CALL iom_setkt( kstp - nit000 + 1, cw_ocerst_cxt ) +#if defined key_top + CALL iom_swap( cw_toprst_cxt ) + CALL iom_init_closedef( cw_toprst_cxt ) + CALL iom_setkt( kstp - nit000 + 1, cw_toprst_cxt ) +#endif + ENDIF + IF( kstp + nn_fsbc - 1 == nitrst .AND. lwxios ) THEN +#if defined key_si3 + CALL iom_swap( cw_icerst_cxt ) + CALL iom_init_closedef( cw_icerst_cxt ) + CALL iom_setkt( kstp - nit000 + 1, cw_icerst_cxt ) +#endif + IF( ln_abl ) THEN + CALL iom_swap( cw_ablrst_cxt ) + CALL iom_init_closedef( cw_ablrst_cxt ) + CALL iom_setkt( kstp - nit000 + 1, cw_ablrst_cxt ) + ENDIF + ENDIF + IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init) + CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell IOM we are at time step kstp + IF( ln_crs ) CALL iom_setkt( kstp - nit000 + 1, TRIM(cxios_context)//"_crs" ) ! tell IOM we are at time step kstp + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Update external forcing (tides, open boundaries, ice shelf interaction and surface boundary condition (including sea-ice) + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_tide ) CALL tide_update( kstp ) ! update tide potential + IF( ln_apr_dyn ) CALL sbc_apr ( kstp ) ! atmospheric pressure (NB: call before bdy_dta which needs ssh_ib) + IF( ln_bdy ) CALL bdy_dta ( kstp, Nnn ) ! update dynamic & tracer data at open boundaries + IF( ln_isf ) CALL isf_stp ( kstp, Nnn ) + CALL sbc ( kstp, Nbb, Nnn ) ! Sea Boundary Condition (including sea-ice) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Update stochastic parameters and random T/S fluctuations + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF( ln_sto_eos ) CALL sto_par( kstp ) ! Stochastic parameters + IF( ln_sto_eos ) CALL sto_pts( ts(:,:,:,:,Nnn) ) ! Random T/S fluctuations + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Ocean physics update + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! THERMODYNAMICS + CALL eos_rab( ts(:,:,:,:,Nbb), rab_b, Nnn ) ! before local thermal/haline expension ratio at T-points + CALL eos_rab( ts(:,:,:,:,Nnn), rab_n, Nnn ) ! now local thermal/haline expension ratio at T-points + CALL bn2 ( ts(:,:,:,:,Nbb), rab_b, rn2b, Nnn ) ! before Brunt-Vaisala frequency + CALL bn2 ( ts(:,:,:,:,Nnn), rab_n, rn2, Nnn ) ! now Brunt-Vaisala frequency + + ! VERTICAL PHYSICS + IF( ln_tile ) CALL dom_tile_start ! [tiling] ZDF tiling loop + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + CALL zdf_phy( kstp, Nbb, Nnn, Nrhs ) ! vertical physics update (top/bot drag, avt, avs, avm + MLD) + END DO + IF( ln_tile ) CALL dom_tile_stop + + ! LATERAL PHYSICS + ! + IF( ln_zps .OR. l_ldfslp ) CALL eos( ts(:,:,:,:,Nbb), rhd, gdept_0(:,:,:) ) ! before in situ density + + IF( ln_zps .AND. .NOT. ln_isfcav) & + & CALL zps_hde ( kstp, Nnn, jpts, ts(:,:,:,:,Nbb), gtsu, gtsv, & ! Partial steps: before horizontal gradient + & rhd, gru , grv ) ! of t, s, rd at the last ocean level + + IF( ln_zps .AND. ln_isfcav) & + & CALL zps_hde_isf( kstp, Nnn, jpts, ts(:,:,:,:,Nbb), gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF) + & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the first ocean level + + IF( l_ldfslp ) THEN ! slope of lateral mixing + IF( ln_traldf_triad ) THEN + CALL ldf_slp_triad( kstp, Nbb, Nnn ) ! before slope for triad operator + ELSE + CALL ldf_slp ( kstp, rhd, rn2b, Nbb, Nnn ) ! before slope for standard operator + ENDIF + ENDIF + ! ! eddy diffusivity coeff. + IF( l_ldftra_time .OR. l_ldfeiv_time ) CALL ldf_tra( kstp, Nbb, Nnn ) ! and/or eiv coeff. + IF( l_ldfdyn_time ) CALL ldf_dyn( kstp, Nbb ) ! eddy viscosity coeff. + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Ocean dynamics : hdiv, ssh, e3, u, v, w + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + CALL ssh_nxt ( kstp, Nbb, Nnn, ssh, Naa ) ! after ssh (includes call to div_hor) + IF( .NOT.lk_linssh ) THEN + CALL dom_qco_r3c( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa) ) ! "after" ssh/h_0 ratio at t,u,v pts + IF( ln_dynspg_exp ) & + & CALL dom_qco_r3c( ssh(:,:,Nnn), r3t(:,:,Nnn), r3u(:,:,Nnn), r3v(:,:,Nnn), r3f(:,:) ) ! spg_exp : needed only for "now" ssh/h_0 ratio at f point + ENDIF + CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! Nnn cross-level velocity + IF( ln_zad_Aimp ) CALL wAimp ( kstp, Nnn ) ! Adaptive-implicit vertical advection partitioning + ALLOCATE( zgdept(jpi,jpj,jpk) ) + DO jk = 1, jpk + zgdept(:,:,jk) = gdept(:,:,jk,Nnn) + END DO + CALL eos ( ts(:,:,:,:,Nnn), rhd, rhop, zgdept ) ! now in situ density for hpg computation + DEALLOCATE( zgdept ) + + uu(:,:,:,Nrhs) = 0._wp ! set dynamics trends to zero + vv(:,:,:,Nrhs) = 0._wp + + IF( ln_dyndmp .AND. ln_c1d ) CALL dyn_dmp( kstp, Nbb, Nnn, uu(:,:,:,Nrhs), vv(:,:,:,Nrhs), Nrhs ) ! internal damping trends- momentum + + IF( ln_tile ) CALL dom_tile_start ! [tiling] DYN tiling loop (1) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + + IF( lk_asminc .AND. ln_asmiau .AND. ln_dyninc ) & + & CALL dyn_asm_inc ( kstp, Nbb, Nnn, uu, vv, Nrhs ) ! apply dynamics assimilation increment + IF( ln_bkgwri ) CALL asm_bkg_wri( kstp, Nnn ) ! output background fields + IF( ln_bdy ) CALL bdy_dyn3d_dmp ( kstp, Nbb, uu, vv, Nrhs ) ! bdy damping trends +#if defined key_agrif + END DO + IF( ln_tile ) CALL dom_tile_stop + + IF(.NOT. Agrif_Root()) & + & CALL Agrif_Sponge_dyn ! momentum sponge + + IF( ln_tile ) CALL dom_tile_start ! [tiling] DYN tiling loop (1, continued) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) +#endif + CALL dyn_adv( kstp, Nbb, Nnn , uu, vv, Nrhs ) ! advection (VF or FF) ==> RHS + CALL dyn_vor( kstp, Nnn , uu, vv, Nrhs ) ! vorticity ==> RHS + CALL dyn_ldf( kstp, Nbb, Nnn , uu, vv, Nrhs ) ! lateral mixing + IF( ln_zdfosm ) CALL dyn_osm( kstp, Nnn , uu, vv, Nrhs ) ! OSMOSIS non-local velocity fluxes ==> RHS + CALL dyn_hpg( kstp, Nnn , uu, vv, Nrhs ) ! horizontal gradient of Hydrostatic pressure + END DO + IF( ln_tile ) CALL dom_tile_stop + + CALL dyn_spg( kstp, Nbb, Nnn, Nrhs, uu, vv, ssh, uu_b, vv_b, Naa ) ! surface pressure gradient + + IF( ln_tile ) CALL dom_tile_start ! [tiling] DYN tiling loop (2) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + + IF( ln_dynspg_ts ) THEN ! With split-explicit free surface, since now transports have been updated and ssh(:,:,Nrhs) + ! as well as vertical scale factors and vertical velocity need to be updated + CALL div_hor ( kstp, Nbb, Nnn ) ! Horizontal divergence (2nd call in time-split case) + IF(.NOT.lk_linssh) CALL dom_qco_r3c( ssh(:,:,Naa), r3t(:,:,Naa), r3u(:,:,Naa), r3v(:,:,Naa), r3f(:,:) ) ! update ssh/h_0 ratio at t,u,v,f pts + ENDIF + CALL dyn_zdf ( kstp, Nbb, Nnn, Nrhs, uu, vv, Naa ) ! vertical diffusion + END DO + IF( ln_tile ) CALL dom_tile_stop + + IF( ln_dynspg_ts ) THEN ! vertical scale factors and vertical velocity need to be updated + CALL wzv ( kstp, Nbb, Nnn, Naa, ww ) ! Nnn cross-level velocity + IF( ln_zad_Aimp ) CALL wAimp ( kstp, Nnn ) ! Adaptive-implicit vertical advection partitioning + ENDIF + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! cool skin + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF ( ln_diurnal ) CALL diurnal_layers( kstp ) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! diagnostics and outputs + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_floats ) CALL flo_stp ( kstp, Nbb, Nnn ) ! drifting Floats + IF( ln_diacfl ) CALL dia_cfl ( kstp, Nnn ) ! Courant number diagnostics + CALL dia_hth ( kstp, Nnn ) ! Thermocline depth (20 degres isotherm depth) + IF( ln_diadct ) CALL dia_dct ( kstp, Nnn ) ! Transports + CALL dia_ar5 ( kstp, Nnn ) ! ar5 diag + CALL dia_ptr ( kstp, Nnn ) ! Poleward adv/ldf TRansports diagnostics + CALL dia_wri ( kstp, Nnn ) ! ocean model: outputs + IF( ln_crs ) CALL crs_fld ( kstp, Nnn ) ! ocean model: online field coarsening & output + IF( lk_diadetide ) CALL dia_detide( kstp ) ! Weights computation for daily detiding of model diagnostics + IF( lk_diamlr ) CALL dia_mlr ! Update time used in multiple-linear-regression analysis + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Now ssh filtering + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL ssh_atf ( kstp, Nbb, Nnn, Naa, ssh ) ! time filtering of "now" sea surface height + IF(.NOT.lk_linssh) CALL dom_qco_r3c( ssh(:,:,Nnn), r3t_f, r3u_f, r3v_f ) ! "now" ssh/h_0 ratio from filtrered ssh +#if defined key_top + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Passive Tracer Model + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL trc_stp ( kstp, Nbb, Nnn, Nrhs, Naa ) ! time-stepping +#endif + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Active tracers + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ts(:,:,:,:,Nrhs) = 0._wp ! set tracer trends to zero + + IF( ln_tile ) CALL dom_tile_start ! [tiling] TRA tiling loop (1) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + + IF( lk_asminc .AND. ln_asmiau .AND. & + & ln_trainc ) CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs ) ! apply tracer assimilation increment + CALL tra_sbc ( kstp, Nnn, ts, Nrhs ) ! surface boundary condition + IF( ln_traqsr ) CALL tra_qsr ( kstp, Nnn, ts, Nrhs ) ! penetrative solar radiation qsr + IF( ln_isf ) CALL tra_isf ( kstp, Nnn, ts, Nrhs ) ! ice shelf heat flux + IF( ln_trabbc ) CALL tra_bbc ( kstp, Nnn, ts, Nrhs ) ! bottom heat flux + IF( ln_trabbl ) CALL tra_bbl ( kstp, Nbb, Nnn, ts, Nrhs ) ! advective (and/or diffusive) bottom boundary layer scheme + IF( ln_tradmp ) CALL tra_dmp ( kstp, Nbb, Nnn, ts, Nrhs ) ! internal damping trends + IF( ln_bdy ) CALL bdy_tra_dmp( kstp, Nbb, ts, Nrhs ) ! bdy damping trends + END DO + IF( ln_tile ) CALL dom_tile_stop + +#if defined key_agrif + IF(.NOT. Agrif_Root() ) THEN + CALL Agrif_Sponge_tra ! tracers sponge + ENDIF +#endif + + ! TEMP: [tiling] Separate loop over tile domains (due to tra_adv workarounds for tiling) + IF( ln_tile ) CALL dom_tile_start ! [tiling] TRA tiling loop (2) + DO jtile = 1, nijtile + IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) + + CALL tra_adv ( kstp, Nbb, Nnn, ts, Nrhs ) ! hor. + vert. advection ==> RHS + IF( ln_zdfmfc ) CALL tra_mfc ( kstp, Nbb, ts, Nrhs ) ! Mass Flux Convection + IF( ln_zdfosm ) THEN + CALL tra_osm ( kstp, Nnn, ts, Nrhs ) ! OSMOSIS non-local tracer fluxes ==> RHS + IF( lrst_oce ) CALL osm_rst ( kstp, Nnn, 'WRITE' ) ! write OSMOSIS outputs + ww (so must do here) to restarts + ENDIF + CALL tra_ldf ( kstp, Nbb, Nnn, ts, Nrhs ) ! lateral mixing + + CALL tra_zdf ( kstp, Nbb, Nnn, Nrhs, ts, Naa ) ! vertical mixing and after tracer fields + IF( ln_zdfnpc ) CALL tra_npc ( kstp, Nnn, Nrhs, ts, Naa ) ! update after fields by non-penetrative convection + END DO + IF( ln_tile ) CALL dom_tile_stop + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Set boundary conditions, time filter and swap time levels + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +!!jc1: For agrif, it would be much better to finalize tracers/momentum here (e.g. bdy conditions) and move the swap +!! (and time filtering) after Agrif update. Then restart would be done after and would contain updated fields. +!! If so: +!! (i) no need to call agrif update at initialization time +!! (ii) no need to update "before" fields +!! +!! Apart from creating new tra_swp/dyn_swp routines, this however: +!! (i) makes boundary conditions at initialization time computed from updated fields which is not the case between +!! two restarts => restartability issue. One can circumvent this, maybe, by assuming "interface separation", +!! e.g. a shift of the feedback interface inside child domain. +!! (ii) requires that all restart outputs of updated variables by agrif (e.g. passive tracers/tke/barotropic arrays) are done at the same +!! place. +!! + IF( ln_dynspg_ts ) CALL mlf_baro_corr ( Nnn, Naa, uu, vv ) ! barotrope adjustment + CALL finalize_lbc ( kstp, Nbb , Naa, uu, vv, ts ) ! boundary conditions + CALL tra_atf_qco ( kstp, Nbb, Nnn, Naa , ts ) ! time filtering of "now" tracer arrays + CALL dyn_atf_qco ( kstp, Nbb, Nnn, Naa, uu, vv ) ! time filtering of "now" velocities + IF(.NOT.lk_linssh) THEN + r3t(:,:,Nnn) = r3t_f(:,:) ! update now ssh/h_0 with time filtered values + r3u(:,:,Nnn) = r3u_f(:,:) + r3v(:,:,Nnn) = r3v_f(:,:) + ENDIF + ! + ! Swap time levels + Nrhs = Nbb + Nbb = Nnn + Nnn = Naa + Naa = Nrhs + ! + ! + IF( ln_diahsb ) CALL dia_hsb ( kstp, Nbb, Nnn ) ! - ML - global conservation diagnostics + +!!gm : This does not only concern the dynamics ==>>> add a new title +!!gm2: why ouput restart before AGRIF update? +!! +!!jc: That would be better, but see comment above +!! + IF( lrst_oce ) CALL rst_write ( kstp, Nbb, Nnn ) ! write output ocean restart file + IF( ln_sto_eos ) CALL sto_rst_write( kstp ) ! write restart file for stochastic parameters + +#if defined key_agrif + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! AGRIF recursive integration + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices + CALL Agrif_Integrate_ChildGrids( stp_MLF ) ! allows to finish all the Child Grids before updating + +#endif + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Control + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL stp_ctl ( kstp, Nnn ) + +#if defined key_agrif + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! AGRIF update + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( Agrif_NbStepint() == 0 .AND. nstop == 0 ) & + & CALL Agrif_update_all( ) ! Update all components + +#endif + IF( ln_diaobs .AND. nstop == 0 ) & + & CALL dia_obs( kstp, Nnn ) ! obs-minus-model (assimilation) diags (after dynamics update) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! File manipulation at the end of the first time step + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( kstp == nit000 ) THEN ! 1st time step only + CALL iom_close( numror ) ! close input ocean restart file + IF( lrxios ) CALL iom_context_finalize( cr_ocerst_cxt ) + IF(lwm) CALL FLUSH ( numond ) ! flush output namelist oce + IF(lwm .AND. numoni /= -1 ) CALL FLUSH ( numoni ) ! flush output namelist ice (if exist) + ENDIF + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Coupled mode + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( lk_oasis .AND. nstop == 0 ) CALL sbc_cpl_snd( kstp, Nbb, Nnn ) ! coupled mode : field exchanges + ! +#if defined key_xios + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Finalize contextes if end of simulation or error detected + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( kstp == nitend .OR. nstop > 0 ) THEN + CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF + IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! + ENDIF +#endif + ! + IF( l_1st_euler ) THEN ! recover Leap-frog timestep + rDt = 2._wp * rn_Dt + r1_Dt = 1._wp / rDt + l_1st_euler = .FALSE. + ENDIF + ! + IF( ln_timing ) CALL timing_stop('stp_MLF') + ! + END SUBROUTINE stp_MLF + + SUBROUTINE mlf_baro_corr( Kmm, Kaa, puu, pvv ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mlf_baro_corr *** + !! + !! ** Purpose : Finalize after horizontal velocity. + !! + !! ** Method : * Ensure after velocities transport matches time splitting + !! estimate (ln_dynspg_ts=T) + !! + !! ** Action : puu(Kmm),pvv(Kmm) updated now horizontal velocity (ln_bt_fw=F) + !! puu(Kaa),pvv(Kaa) after horizontal velocity + !!---------------------------------------------------------------------- + USE dynspg_ts, ONLY : un_adv, vn_adv ! updated Kmm barotropic transport + !! + INTEGER , INTENT(in ) :: Kmm, Kaa ! before and after time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) :: puu, pvv ! velocities + ! + INTEGER :: ji,jj, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: zue, zve + !!---------------------------------------------------------------------- + + ! Ensure below that barotropic velocities match time splitting estimate + ! Compute actual transport and replace it with ts estimate at "after" time step + DO_2D( 0, 0, 0, 0 ) + zue(ji,jj) = e3u(ji,jj,1,Kaa) * puu(ji,jj,1,Kaa) * umask(ji,jj,1) + zve(ji,jj) = e3v(ji,jj,1,Kaa) * pvv(ji,jj,1,Kaa) * vmask(ji,jj,1) + END_2D + DO jk = 2, jpkm1 + DO_2D( 0, 0, 0, 0 ) + zue(ji,jj) = zue(ji,jj) + e3u(ji,jj,jk,Kaa) * puu(ji,jj,jk,Kaa) * umask(ji,jj,jk) + zve(ji,jj) = zve(ji,jj) + e3v(ji,jj,jk,Kaa) * pvv(ji,jj,jk,Kaa) * vmask(ji,jj,jk) + END_2D + END DO + DO jk = 1, jpkm1 + DO_2D( 0, 0, 0, 0 ) + puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kaa) - zue(ji,jj) * r1_hu(ji,jj,Kaa) + uu_b(ji,jj,Kaa) ) * umask(ji,jj,jk) + pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - zve(ji,jj) * r1_hv(ji,jj,Kaa) + vv_b(ji,jj,Kaa) ) * vmask(ji,jj,jk) + END_2D + END DO + ! + IF( .NOT.ln_bt_fw ) THEN + ! Remove advective velocity from "now velocities" + ! prior to asselin filtering + ! In the forward case, this is done below after asselin filtering + ! so that asselin contribution is removed at the same time + DO jk = 1, jpkm1 + puu(:,:,jk,Kmm) = ( puu(:,:,jk,Kmm) - un_adv(:,:)*r1_hu(:,:,Kmm) + uu_b(:,:,Kmm) )*umask(:,:,jk) + pvv(:,:,jk,Kmm) = ( pvv(:,:,jk,Kmm) - vn_adv(:,:)*r1_hv(:,:,Kmm) + vv_b(:,:,Kmm) )*vmask(:,:,jk) + END DO + ENDIF + ! + END SUBROUTINE mlf_baro_corr + + + SUBROUTINE finalize_lbc( kt, Kbb, Kaa, puu, pvv, pts ) + !!---------------------------------------------------------------------- + !! *** ROUTINE finalize_lbc *** + !! + !! ** Purpose : Apply the boundary condition on the after velocity + !! + !! ** Method : * Apply lateral boundary conditions on after velocity + !! at the local domain boundaries through lbc_lnk call, + !! at the one-way open boundaries (ln_bdy=T), + !! at the AGRIF zoom boundaries (lk_agrif=T) + !! + !! ** Action : puu(Kaa),pvv(Kaa) after horizontal velocity and tracers + !!---------------------------------------------------------------------- +#if defined key_agrif + USE agrif_oce_interp +#endif + USE bdydyn ! ocean open boundary conditions (define bdy_dyn) + !! + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: Kbb, Kaa ! before and after time level indices + REAL(dp), DIMENSION(jpi,jpj,jpk,jpt) , INTENT(inout) :: puu, pvv ! velocities to be time filtered + REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers + !!---------------------------------------------------------------------- + ! + ! Update after tracer and velocity on domain lateral boundaries + ! +# if defined key_agrif + CALL Agrif_tra !* AGRIF zoom boundaries + CALL Agrif_dyn( kt ) +# endif + ! ! local domain boundaries (T-point, unchanged sign) + CALL lbc_lnk( 'finalize_lbc', puu(:,:,:, Kaa), 'U', -1., pvv(:,:,: ,Kaa), 'V', -1. & + & , pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. ) + ! + ! lbc_lnk needed for zdf_sh2 when using nn_hls = 2, moved here to allow tiling in zdf_phy + IF( nn_hls == 2 .AND. l_zdfsh2 ) CALL lbc_lnk( 'stp', avm_k, 'W', 1.0_wp ) + + ! dom_qco_r3c defines over [nn_hls, nn_hls-1, nn_hls, nn_hls-1] + IF( nn_hls == 2 .AND. .NOT. lk_linssh ) THEN + CALL lbc_lnk( 'finalize_lbc', r3u(:,:,Kaa), 'U', 1._wp, r3v(:,:,Kaa), 'V', 1._wp, & + & r3u_f(:,:), 'U', 1._wp, r3v_f(:,:), 'V', 1._wp ) + ENDIF + ! !* BDY open boundaries + IF( ln_bdy ) THEN + CALL bdy_tra( kt, Kbb, pts, Kaa ) + IF( ln_dynspg_exp ) CALL bdy_dyn( kt, Kbb, puu, pvv, Kaa ) + IF( ln_dynspg_ts ) CALL bdy_dyn( kt, Kbb, puu, pvv, Kaa, dyn3d_only=.true. ) + ENDIF + ! + END SUBROUTINE finalize_lbc + +#else + !!---------------------------------------------------------------------- + !! default option EMPTY MODULE qco not activated + !!---------------------------------------------------------------------- +#endif + + !!====================================================================== +END MODULE stpmlf diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/timing.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/timing.F90 new file mode 100644 index 0000000..4c1becf --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/timing.F90 @@ -0,0 +1,877 @@ +MODULE timing + !!======================================================================== + !! *** MODULE timing *** + !!======================================================================== + !! History : 4.0 ! 2001-05 (R. Benshila) + !!------------------------------------------------------------------------ + + !!------------------------------------------------------------------------ + !! timming_init : initialize timing process + !! timing_start : start Timer + !! timing_stop : stop Timer + !! timing_reset : end timing variable creation + !! timing_finalize : compute stats and write output in calling w*_info + !! timing_ini_var : create timing variables + !! timing_listing : print instumented subroutines in ocean.output + !! wcurrent_info : compute and print detailed stats on the current CPU + !! wave_info : compute and print averaged statson all processors + !! wmpi_info : compute and write global stats + !! supress : suppress an element of the timing linked list + !! insert : insert an element of the timing linked list + !!------------------------------------------------------------------------ + USE in_out_manager ! I/O manager + USE dom_oce ! ocean domain + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + PUBLIC timing_init, timing_finalize ! called in nemogcm module + PUBLIC timing_reset ! called in step module + PUBLIC timing_start, timing_stop ! called in each routine to time + +#if ! defined key_mpi_off + INCLUDE 'mpif.h' +#endif + + ! Variables for fine grain timing + TYPE timer + CHARACTER(LEN=20) :: cname + CHARACTER(LEN=20) :: surname + INTEGER :: rank + REAL(dp) :: t_cpu, t_clock, tsum_cpu, tsum_clock, tmax_cpu, tmax_clock, tmin_cpu, tmin_clock, tsub_cpu, tsub_clock + INTEGER :: ncount, ncount_max, ncount_rate + INTEGER :: niter + LOGICAL :: l_tdone + TYPE(timer), POINTER :: next => NULL() + TYPE(timer), POINTER :: prev => NULL() + TYPE(timer), POINTER :: parent_section => NULL() + END TYPE timer + + TYPE alltimer + CHARACTER(LEN=20), DIMENSION(:), POINTER :: cname => NULL() + REAL(dp), DIMENSION(:), POINTER :: tsum_cpu => NULL() + REAL(dp), DIMENSION(:), POINTER :: tsum_clock => NULL() + INTEGER, DIMENSION(:), POINTER :: niter => NULL() + TYPE(alltimer), POINTER :: next => NULL() + TYPE(alltimer), POINTER :: prev => NULL() + END TYPE alltimer + + TYPE(timer), POINTER :: s_timer_root => NULL() + TYPE(timer), POINTER :: s_timer => NULL() + TYPE(timer), POINTER :: s_timer_old => NULL() + + TYPE(timer), POINTER :: s_wrk => NULL() + REAL(dp) :: t_overclock, t_overcpu + LOGICAL :: l_initdone = .FALSE. + INTEGER :: nsize + + ! Variables for coarse grain timing + REAL(dp) :: tot_etime, tot_ctime + REAL(kind=dp), DIMENSION(2) :: t_elaps, t_cpu + REAL(dp), ALLOCATABLE, DIMENSION(:) :: all_etime, all_ctime + INTEGER :: nfinal_count, ncount, ncount_rate, ncount_max + INTEGER, DIMENSION(8) :: nvalues + CHARACTER(LEN=8), DIMENSION(2) :: cdate + CHARACTER(LEN=10), DIMENSION(2) :: ctime + CHARACTER(LEN=5) :: czone + + ! From of ouput file (1/proc or one global) !RB to put in nammpp or namctl + LOGICAL :: ln_onefile = .TRUE. + LOGICAL :: lwriter + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: timing.F90 14834 2021-05-11 09:24:44Z hadcv $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE timing_start(cdinfo) + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_start *** + !! ** Purpose : collect execution time + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdinfo + ! + IF(ASSOCIATED(s_timer) ) s_timer_old => s_timer + ! + ! Create timing structure at first call of the routine + CALL timing_ini_var(cdinfo) + ! write(*,*) 'after inivar ', s_timer%cname + + ! ici timing_ini_var a soit retrouve s_timer et fait return soit ajoute un maillon + ! maintenant on regarde si le call d'avant corrsspond a un parent ou si il est ferme + IF( .NOT. s_timer_old%l_tdone ) THEN + s_timer%parent_section => s_timer_old + ELSE + s_timer%parent_section => NULL() + ENDIF + + s_timer%l_tdone = .FALSE. + IF( .NOT. l_istiled .OR. ntile == 1 ) s_timer%niter = s_timer%niter + 1 ! All tiles count as one iteration + s_timer%t_cpu = 0. + s_timer%t_clock = 0. + + ! CPU time collection + CALL CPU_TIME( s_timer%t_cpu ) + ! clock time collection +#if ! defined key_mpi_off + s_timer%t_clock= MPI_Wtime() +#else + CALL SYSTEM_CLOCK(COUNT_RATE=s_timer%ncount_rate, COUNT_MAX=s_timer%ncount_max) + CALL SYSTEM_CLOCK(COUNT = s_timer%ncount) +#endif +! write(*,*) 'end of start ', s_timer%cname + + ! + END SUBROUTINE timing_start + + + SUBROUTINE timing_stop(cdinfo, csection) + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_stop *** + !! ** Purpose : finalize timing and output + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdinfo + CHARACTER(len=*), INTENT(in), OPTIONAL :: csection + ! + INTEGER :: ifinal_count, iperiods + REAL(dp) :: zcpu_end, zmpitime,zcpu_raw,zclock_raw + ! + s_wrk => NULL() + + ! clock time collection +#if ! defined key_mpi_off + zmpitime = MPI_Wtime() +#else + CALL SYSTEM_CLOCK(COUNT = ifinal_count) +#endif + ! CPU time collection + CALL CPU_TIME( zcpu_end ) + +!!$ IF(associated(s_timer%parent_section))then +!!$ write(*,*) s_timer%cname,' <-- ', s_timer%parent_section%cname +!!$ ENDIF + + ! No need to search ... : s_timer has the last value defined in start + ! s_timer => s_timer_root + ! DO WHILE( TRIM(s_timer%cname) /= TRIM(cdinfo) ) + ! IF( ASSOCIATED(s_timer%next) ) s_timer => s_timer%next + ! END DO + + ! CPU time correction + zcpu_raw = zcpu_end - s_timer%t_cpu - t_overcpu ! total time including child + s_timer%t_cpu = zcpu_raw - s_timer%tsub_cpu + ! IF(s_timer%cname==trim('lbc_lnk_2d')) write(*,*) s_timer%tsub_cpu,zcpu_end + + ! clock time correction +#if ! defined key_mpi_off + zclock_raw = zmpitime - s_timer%t_clock - t_overclock ! total time including child + s_timer%t_clock = zclock_raw - t_overclock - s_timer%tsub_clock +#else + iperiods = ifinal_count - s_timer%ncount + IF( ifinal_count < s_timer%ncount ) & + iperiods = iperiods + s_timer%ncount_max + zclock_raw = REAL(iperiods) / s_timer%ncount_rate !- t_overclock + s_timer%t_clock = zclock_raw - s_timer%tsub_clock +#endif + ! IF(s_timer%cname==trim('lbc_lnk_2d')) write(*,*) zclock_raw , s_timer%tsub_clock + + ! Correction of parent section + IF( .NOT. PRESENT(csection) ) THEN + IF ( ASSOCIATED(s_timer%parent_section ) ) THEN + s_timer%parent_section%tsub_cpu = zcpu_raw + s_timer%parent_section%tsub_cpu + s_timer%parent_section%tsub_clock = zclock_raw + s_timer%parent_section%tsub_clock + ENDIF + ENDIF + + ! time diagnostics + s_timer%tsum_clock = s_timer%tsum_clock + s_timer%t_clock + s_timer%tsum_cpu = s_timer%tsum_cpu + s_timer%t_cpu +!RB to use to get min/max during a time integration +! IF( .NOT. l_initdone ) THEN +! s_timer%tmin_clock = s_timer%t_clock +! s_timer%tmin_cpu = s_timer%t_cpu +! ELSE +! s_timer%tmin_clock = MIN( s_timer%tmin_clock, s_timer%t_clock ) +! s_timer%tmin_cpu = MIN( s_timer%tmin_cpu , s_timer%t_cpu ) +! ENDIF +! s_timer%tmax_clock = MAX( s_timer%tmax_clock, s_timer%t_clock ) +! s_timer%tmax_cpu = MAX( s_timer%tmax_cpu , s_timer%t_cpu ) + ! + s_timer%tsub_clock = 0. + s_timer%tsub_cpu = 0. + s_timer%l_tdone = .TRUE. + ! + ! + ! we come back + IF ( ASSOCIATED(s_timer%parent_section ) ) s_timer => s_timer%parent_section + +! write(*,*) 'end of stop ', s_timer%cname + + END SUBROUTINE timing_stop + + + SUBROUTINE timing_init( clname ) + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_init *** + !! ** Purpose : open timing output file + !!---------------------------------------------------------------------- + INTEGER :: iperiods, istart_count, ifinal_count + REAL(dp) :: zdum + LOGICAL :: ll_f + CHARACTER(len=*), INTENT(in), OPTIONAL :: clname + CHARACTER(len=20) :: cln + + IF( PRESENT(clname) ) THEN ; cln = clname + ELSE ; cln = 'timing.output' + ENDIF + + IF( ln_onefile ) THEN + IF( lwp) CALL ctl_opn( numtime, cln, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.TRUE., narea ) + lwriter = lwp + ELSE + CALL ctl_opn( numtime, cln, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.FALSE., narea ) + lwriter = .TRUE. + ENDIF + + IF( lwriter) THEN + WRITE(numtime,*) + WRITE(numtime,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC - INGV' + WRITE(numtime,*) ' NEMO team' + WRITE(numtime,*) ' Ocean General Circulation Model' + WRITE(numtime,*) ' version 4.0 (2019) ' + WRITE(numtime,*) + WRITE(numtime,*) ' Timing Informations ' + WRITE(numtime,*) + WRITE(numtime,*) + ENDIF + + ! Compute clock function overhead +#if ! defined key_mpi_off + t_overclock = MPI_WTIME() + t_overclock = MPI_WTIME() - t_overclock +#else + CALL SYSTEM_CLOCK(COUNT_RATE=ncount_rate, COUNT_MAX=ncount_max) + CALL SYSTEM_CLOCK(COUNT = istart_count) + CALL SYSTEM_CLOCK(COUNT = ifinal_count) + iperiods = ifinal_count - istart_count + IF( ifinal_count < istart_count ) & + iperiods = iperiods + ncount_max + t_overclock = REAL(iperiods) / ncount_rate +#endif + + ! Compute cpu_time function overhead + CALL CPU_TIME(zdum) + CALL CPU_TIME(t_overcpu) + + ! End overhead omputation + t_overcpu = t_overcpu - zdum + t_overclock = t_overcpu + t_overclock + + ! Timing on date and time + CALL DATE_AND_TIME(cdate(1),ctime(1),czone,nvalues) + + CALL CPU_TIME(t_cpu(1)) +#if ! defined key_mpi_off + ! Start elapsed and CPU time counters + t_elaps(1) = MPI_WTIME() +#else + CALL SYSTEM_CLOCK(COUNT_RATE=ncount_rate, COUNT_MAX=ncount_max) + CALL SYSTEM_CLOCK(COUNT = ncount) +#endif + ! + END SUBROUTINE timing_init + + + SUBROUTINE timing_finalize + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_finalize *** + !! ** Purpose : compute average time + !! write timing output file + !!---------------------------------------------------------------------- + TYPE(timer), POINTER :: s_temp + INTEGER :: idum, iperiods, icode + INTEGER :: ji + LOGICAL :: ll_ord, ll_averep + CHARACTER(len=120) :: clfmt + REAL(dp), DIMENSION(:), ALLOCATABLE :: timing_glob + REAL(dp) :: zsypd ! simulated years per day (Balaji 2017) + REAL(dp) :: zperc, ztot + + ll_averep = .TRUE. + + ! total CPU and elapse + CALL CPU_TIME(t_cpu(2)) + t_cpu(2) = t_cpu(2) - t_cpu(1) - t_overcpu +#if ! defined key_mpi_off + t_elaps(2) = MPI_WTIME() - t_elaps(1) - t_overclock +#else + CALL SYSTEM_CLOCK(COUNT = nfinal_count) + iperiods = nfinal_count - ncount + IF( nfinal_count < ncount ) & + iperiods = iperiods + ncount_max + t_elaps(2) = REAL(iperiods) / ncount_rate - t_overclock +#endif + + ! End of timings on date & time + CALL DATE_AND_TIME(cdate(2),ctime(2),czone,nvalues) + + ! Compute the numer of routines + nsize = 0 + s_timer => s_timer_root + DO WHILE( ASSOCIATED(s_timer) ) + nsize = nsize + 1 + s_timer => s_timer%next + END DO + idum = nsize + CALL mpp_sum('timing', idum) + IF( idum/jpnij /= nsize ) THEN + IF( lwriter ) WRITE(numtime,*) ' ===> W A R N I N G: ' + IF( lwriter ) WRITE(numtime,*) ' Some CPU have different number of routines instrumented for timing' + IF( lwriter ) WRITE(numtime,*) ' No detailed report on averaged timing can be provided' + IF( lwriter ) WRITE(numtime,*) ' The following detailed report only deals with the current processor' + IF( lwriter ) WRITE(numtime,*) + ll_averep = .FALSE. + ENDIF + +#if ! defined key_mpi_off + ! in MPI gather some info + ALLOCATE( all_etime(jpnij), all_ctime(jpnij) ) + CALL MPI_ALLGATHER(t_elaps(2), 1, MPI_DOUBLE_PRECISION, & + all_etime , 1, MPI_DOUBLE_PRECISION, & + MPI_COMM_OCE, icode) + CALL MPI_ALLGATHER(t_cpu(2) , 1, MPI_DOUBLE_PRECISION, & + all_ctime, 1, MPI_DOUBLE_PRECISION, & + MPI_COMM_OCE, icode) + tot_etime = SUM(all_etime(:)) + tot_ctime = SUM(all_ctime(:)) +#else + tot_etime = t_elaps(2) + tot_ctime = t_cpu (2) +#endif + + ! write output file + IF( lwriter ) WRITE(numtime,*) + IF( lwriter ) WRITE(numtime,*) + IF( lwriter ) WRITE(numtime,*) 'Total timing (sum) :' + IF( lwriter ) WRITE(numtime,*) '--------------------' + IF( lwriter ) WRITE(numtime,"('Elapsed Time (s) CPU Time (s)')") + IF( lwriter ) WRITE(numtime,'(5x,f12.3,1x,f12.3)') tot_etime, tot_ctime + IF( lwriter ) WRITE(numtime,*) +#if ! defined key_mpi_off + IF( ll_averep ) CALL waver_info + CALL wmpi_info +#endif + IF( lwriter ) CALL wcurrent_info + + clfmt='(1X,"Timing started on ",2(A2,"/"),A4," at ",2(A2,":"),A2," MET ",A3,":",A2," from GMT")' + IF( lwriter ) WRITE(numtime, TRIM(clfmt)) & + & cdate(1)(7:8), cdate(1)(5:6), cdate(1)(1:4), & + & ctime(1)(1:2), ctime(1)(3:4), ctime(1)(5:6), & + & czone(1:3), czone(4:5) + clfmt='(1X, "Timing ended on ",2(A2,"/"),A4," at ",2(A2,":"),A2," MET ",A3,":",A2," from GMT")' + IF( lwriter ) WRITE(numtime, TRIM(clfmt)) & + & cdate(2)(7:8), cdate(2)(5:6), cdate(2)(1:4), & + & ctime(2)(1:2), ctime(2)(3:4), ctime(2)(5:6), & + & czone(1:3), czone(4:5) + +#if ! defined key_mpi_off + ALLOCATE(timing_glob(4*jpnij), stat=icode) + CALL MPI_GATHER( (/compute_time, waiting_time(1), waiting_time(2), elapsed_time/), & + & 4, MPI_DOUBLE_PRECISION, timing_glob, 4, MPI_DOUBLE_PRECISION, 0, MPI_COMM_OCE, icode) + IF( narea == 1 ) THEN + WRITE(numtime,*) ' ' + WRITE(numtime,*) ' Report on time spent on waiting MPI messages ' + WRITE(numtime,*) ' total timing measured between nit000+1 and nitend-1 ' + WRITE(numtime,*) ' warning: includes restarts writing time if output before nitend... ' + WRITE(numtime,*) ' ' + DO ji = 1, jpnij + zperc = 0._dp ; zsypd = 0._dp + ztot = SUM( timing_glob(4*ji-3:4*ji-1) ) + WRITE(numtime,'(A28,F11.6, A34,I8)') 'Computing time : ',timing_glob(4*ji-3), ' on MPI rank : ', ji + IF ( ztot /= 0._dp ) zperc = timing_glob(4*ji-2) / ztot * 100. + WRITE(numtime,'(A28,F11.6,A2, F4.1,A3,A25,I8)') 'Waiting lbc_lnk time : ',timing_glob(4*ji-2) & + & , ' (', zperc,' %)', ' on MPI rank : ', ji + IF ( ztot /= 0._dp ) zperc = timing_glob(4*ji-1) / ztot * 100. + WRITE(numtime,'(A28,F11.6,A2, F4.1,A3,A25,I8)') 'Waiting global time : ',timing_glob(4*ji-1) & + & , ' (', zperc,' %)', ' on MPI rank : ', ji + IF ( timing_glob(4*ji) /= 0._dp ) zsypd = rn_Dt * REAL(nitend-nit000-1, dp) / (timing_glob(4*ji) * 365.) + WRITE(numtime,'(A28,F11.6,A7,F10.3,A2,A15,I8)') 'Total time : ',timing_glob(4*ji ) & + & , ' (SYPD: ', zsypd, ')', ' on MPI rank : ', ji + END DO + ENDIF + DEALLOCATE(timing_glob) +#endif + + IF( lwriter ) CLOSE(numtime) + ! + END SUBROUTINE timing_finalize + + + SUBROUTINE wcurrent_info + !!---------------------------------------------------------------------- + !! *** ROUTINE wcurrent_info *** + !! ** Purpose : compute and write timing output file + !!---------------------------------------------------------------------- + LOGICAL :: ll_ord + CHARACTER(len=2048) :: clfmt + + ! reorder the current list by elapse time + s_wrk => NULL() + s_timer => s_timer_root + DO + ll_ord = .TRUE. + s_timer => s_timer_root + DO WHILE ( ASSOCIATED( s_timer%next ) ) + IF (.NOT. ASSOCIATED(s_timer%next)) EXIT + IF ( s_timer%tsum_clock < s_timer%next%tsum_clock ) THEN + ALLOCATE(s_wrk) + s_wrk = s_timer%next + CALL insert (s_timer, s_timer_root, s_wrk) + CALL suppress(s_timer%next) + ll_ord = .FALSE. + CYCLE + ENDIF + IF( ASSOCIATED(s_timer%next) ) s_timer => s_timer%next + END DO + IF( ll_ord ) EXIT + END DO + + ! write current info + WRITE(numtime,*) 'Detailed timing for proc :', narea-1 + WRITE(numtime,*) '--------------------------' + WRITE(numtime,*) 'Section ', & + & 'Elapsed Time (s) ','Elapsed Time (%) ', & + & 'CPU Time(s) ','CPU Time (%) ','CPU/Elapsed ','Frequency' + s_timer => s_timer_root + clfmt = '(1x,a,4x,f12.3,6x,f12.3,x,f12.3,2x,f12.3,6x,f7.3,2x,i9)' + DO WHILE ( ASSOCIATED(s_timer) ) + IF( s_timer%tsum_clock > 0._dp ) & + WRITE(numtime,TRIM(clfmt)) s_timer%cname, & + & s_timer%tsum_clock,s_timer%tsum_clock*100./t_elaps(2), & + & s_timer%tsum_cpu ,s_timer%tsum_cpu*100./t_cpu(2) , & + & s_timer%tsum_cpu/s_timer%tsum_clock, s_timer%niter + s_timer => s_timer%next + END DO + WRITE(numtime,*) + ! + END SUBROUTINE wcurrent_info + +#if ! defined key_mpi_off + SUBROUTINE waver_info + !!---------------------------------------------------------------------- + !! *** ROUTINE wcurrent_info *** + !! ** Purpose : compute and write averaged timing informations + !!---------------------------------------------------------------------- + TYPE(alltimer), POINTER :: sl_timer_glob_root => NULL() + TYPE(alltimer), POINTER :: sl_timer_glob => NULL() + TYPE(timer), POINTER :: sl_timer_ave_root => NULL() + TYPE(timer), POINTER :: sl_timer_ave => NULL() + INTEGER :: icode + INTEGER :: ierr + LOGICAL :: ll_ord + CHARACTER(len=200) :: clfmt + + ! Initialised the global strucutre + ALLOCATE(sl_timer_glob_root, Stat=ierr) + IF(ierr /= 0)THEN + WRITE(numtime,*) 'Failed to allocate global timing structure in waver_info' + RETURN + END IF + + ALLOCATE(sl_timer_glob_root%cname (jpnij), & + sl_timer_glob_root%tsum_cpu (jpnij), & + sl_timer_glob_root%tsum_clock(jpnij), & + sl_timer_glob_root%niter (jpnij), Stat=ierr) + IF(ierr /= 0)THEN + WRITE(numtime,*) 'Failed to allocate global timing structure in waver_info' + RETURN + END IF + sl_timer_glob_root%cname(:) = '' + sl_timer_glob_root%tsum_cpu(:) = 0._dp + sl_timer_glob_root%tsum_clock(:) = 0._dp + sl_timer_glob_root%niter(:) = 0 + sl_timer_glob_root%next => NULL() + sl_timer_glob_root%prev => NULL() + !ARPDBG - don't need to allocate a pointer that's immediately then + ! set to point to some other object. + !ALLOCATE(sl_timer_glob) + !ALLOCATE(sl_timer_glob%cname (jpnij)) + !ALLOCATE(sl_timer_glob%tsum_cpu (jpnij)) + !ALLOCATE(sl_timer_glob%tsum_clock(jpnij)) + !ALLOCATE(sl_timer_glob%niter (jpnij)) + sl_timer_glob => sl_timer_glob_root + ! + IF( narea .EQ. 1 ) THEN + ALLOCATE(sl_timer_ave_root) + sl_timer_ave_root%cname = '' + sl_timer_ave_root%t_cpu = 0._dp + sl_timer_ave_root%t_clock = 0._dp + sl_timer_ave_root%tsum_cpu = 0._dp + sl_timer_ave_root%tsum_clock = 0._dp + sl_timer_ave_root%tmax_cpu = 0._dp + sl_timer_ave_root%tmax_clock = 0._dp + sl_timer_ave_root%tmin_cpu = 0._dp + sl_timer_ave_root%tmin_clock = 0._dp + sl_timer_ave_root%tsub_cpu = 0._dp + sl_timer_ave_root%tsub_clock = 0._dp + sl_timer_ave_root%ncount = 0 + sl_timer_ave_root%ncount_rate = 0 + sl_timer_ave_root%ncount_max = 0 + sl_timer_ave_root%niter = 0 + sl_timer_ave_root%l_tdone = .FALSE. + sl_timer_ave_root%next => NULL() + sl_timer_ave_root%prev => NULL() + ALLOCATE(sl_timer_ave) + sl_timer_ave => sl_timer_ave_root + ENDIF + + ! Gather info from all processors + s_timer => s_timer_root + DO WHILE ( ASSOCIATED(s_timer) ) + CALL MPI_GATHER(s_timer%cname , 20, MPI_CHARACTER, & + sl_timer_glob%cname, 20, MPI_CHARACTER, & + 0, MPI_COMM_OCE, icode) + CALL MPI_GATHER(s_timer%tsum_clock , 1, MPI_DOUBLE_PRECISION, & + sl_timer_glob%tsum_clock, 1, MPI_DOUBLE_PRECISION, & + 0, MPI_COMM_OCE, icode) + CALL MPI_GATHER(s_timer%tsum_cpu , 1, MPI_DOUBLE_PRECISION, & + sl_timer_glob%tsum_cpu, 1, MPI_DOUBLE_PRECISION, & + 0, MPI_COMM_OCE, icode) + CALL MPI_GATHER(s_timer%niter , 1, MPI_INTEGER, & + sl_timer_glob%niter, 1, MPI_INTEGER, & + 0, MPI_COMM_OCE, icode) + + IF( narea == 1 .AND. ASSOCIATED(s_timer%next) ) THEN + ALLOCATE(sl_timer_glob%next) + ALLOCATE(sl_timer_glob%next%cname (jpnij)) + ALLOCATE(sl_timer_glob%next%tsum_cpu (jpnij)) + ALLOCATE(sl_timer_glob%next%tsum_clock(jpnij)) + ALLOCATE(sl_timer_glob%next%niter (jpnij)) + sl_timer_glob%next%prev => sl_timer_glob + sl_timer_glob%next%next => NULL() + sl_timer_glob => sl_timer_glob%next + ENDIF + s_timer => s_timer%next + END DO + + IF( narea == 1 ) THEN + ! Compute some stats + sl_timer_glob => sl_timer_glob_root + DO WHILE( ASSOCIATED(sl_timer_glob) ) + sl_timer_ave%cname = sl_timer_glob%cname(1) + sl_timer_ave%tsum_cpu = SUM (sl_timer_glob%tsum_cpu (:)) / jpnij + sl_timer_ave%tsum_clock = SUM (sl_timer_glob%tsum_clock(:)) / jpnij + sl_timer_ave%tmax_cpu = MAXVAL(sl_timer_glob%tsum_cpu (:)) + sl_timer_ave%tmax_clock = MAXVAL(sl_timer_glob%tsum_clock(:)) + sl_timer_ave%tmin_cpu = MINVAL(sl_timer_glob%tsum_cpu (:)) + sl_timer_ave%tmin_clock = MINVAL(sl_timer_glob%tsum_clock(:)) + sl_timer_ave%niter = SUM (sl_timer_glob%niter (:)) + ! + IF( ASSOCIATED(sl_timer_glob%next) ) THEN + ALLOCATE(sl_timer_ave%next) + sl_timer_ave%next%prev => sl_timer_ave + sl_timer_ave%next%next => NULL() + sl_timer_ave => sl_timer_ave%next + ENDIF + sl_timer_glob => sl_timer_glob%next + END DO + + ! reorder the averaged list by CPU time + s_wrk => NULL() + sl_timer_ave => sl_timer_ave_root + DO + ll_ord = .TRUE. + sl_timer_ave => sl_timer_ave_root + DO WHILE( ASSOCIATED( sl_timer_ave%next ) ) + + IF( .NOT. ASSOCIATED(sl_timer_ave%next) ) EXIT + + IF ( sl_timer_ave%tsum_clock < sl_timer_ave%next%tsum_clock ) THEN + ALLOCATE(s_wrk) + ! Copy data into the new object pointed to by s_wrk + s_wrk = sl_timer_ave%next + ! Insert this new timer object before our current position + CALL insert (sl_timer_ave, sl_timer_ave_root, s_wrk) + ! Remove the old object from the list + CALL suppress(sl_timer_ave%next) + ll_ord = .FALSE. + CYCLE + ENDIF + IF( ASSOCIATED(sl_timer_ave%next) ) sl_timer_ave => sl_timer_ave%next + END DO + IF( ll_ord ) EXIT + END DO + + ! write averaged info + WRITE(numtime,"('Averaged timing on all processors :')") + WRITE(numtime,"('-----------------------------------')") + WRITE(numtime,"('Section',13x,'Elap. Time(s)',2x,'Elap. Time(%)',2x, & + & 'CPU Time(s)',2x,'CPU Time(%)',2x,'CPU/Elap',1x, & + & 'Max elap(%)',2x,'Min elap(%)',2x, & + & 'Freq')") + sl_timer_ave => sl_timer_ave_root + clfmt = '((A),E15.7,2x,f6.2,5x,f12.2,5x,f6.2,5x,f7.2,2x,f12.2,4x,f6.2,2x,f9.2)' + DO WHILE ( ASSOCIATED(sl_timer_ave) ) + IF( sl_timer_ave%tsum_clock > 0. ) & + WRITE(numtime,TRIM(clfmt)) sl_timer_ave%cname(1:18), & + & sl_timer_ave%tsum_clock,sl_timer_ave%tsum_clock*100.*jpnij/tot_etime, & + & sl_timer_ave%tsum_cpu ,sl_timer_ave%tsum_cpu*100.*jpnij/tot_ctime , & + & sl_timer_ave%tsum_cpu/sl_timer_ave%tsum_clock, & + & sl_timer_ave%tmax_clock*100.*jpnij/tot_etime, & + & sl_timer_ave%tmin_clock*100.*jpnij/tot_etime, & + & sl_timer_ave%niter/REAL(jpnij) + sl_timer_ave => sl_timer_ave%next + END DO + WRITE(numtime,*) + ! + DEALLOCATE(sl_timer_ave_root) + ENDIF + ! + DEALLOCATE(sl_timer_glob_root) + ! + END SUBROUTINE waver_info + + + SUBROUTINE wmpi_info + !!---------------------------------------------------------------------- + !! *** ROUTINE wmpi_time *** + !! ** Purpose : compute and write a summary of MPI infos + !!---------------------------------------------------------------------- + ! + INTEGER :: idum, icode + INTEGER, ALLOCATABLE, DIMENSION(:) :: iall_rank + REAL(dp) :: ztot_ratio + REAL(dp) :: zmax_etime, zmax_ctime, zmax_ratio, zmin_etime, zmin_ctime, zmin_ratio + REAL(dp) :: zavg_etime, zavg_ctime, zavg_ratio + REAL(dp), ALLOCATABLE, DIMENSION(:) :: zall_ratio + CHARACTER(LEN=128), dimension(8) :: cllignes + CHARACTER(LEN=128) :: clhline, clstart_date, clfinal_date + CHARACTER(LEN=2048) :: clfmt + + ! Gather all times + ALLOCATE( zall_ratio(jpnij), iall_rank(jpnij) ) + IF( narea == 1 ) THEN + iall_rank(:) = (/ (idum,idum=0,jpnij-1) /) + + ! Compute elapse user time + zavg_etime = tot_etime/REAL(jpnij,dp) + zmax_etime = MAXVAL(all_etime(:)) + zmin_etime = MINVAL(all_etime(:)) + + ! Compute CPU user time + zavg_ctime = tot_ctime/REAL(jpnij,dp) + zmax_ctime = MAXVAL(all_ctime(:)) + zmin_ctime = MINVAL(all_ctime(:)) + + ! Compute cpu/elapsed ratio + zall_ratio(:) = all_ctime(:) / all_etime(:) + ztot_ratio = SUM(all_ctime(:))/SUM(all_etime(:)) + zavg_ratio = SUM(zall_ratio(:))/REAL(jpnij,dp) + zmax_ratio = MAXVAL(zall_ratio(:)) + zmin_ratio = MINVAL(zall_ratio(:)) + + ! Output Format + clhline ='1x,13("-"),"|",18("-"),"|",14("-"),"|",18("-"),/,' + cllignes(1)='(1x,"MPI summary report :",/,' + cllignes(2)='1x,"--------------------",//,' + cllignes(3)='1x,"Process Rank |"," Elapsed Time (s) |"," CPU Time (s) |"," Ratio CPU/Elapsed",/,' + cllignes(4)=' (4x,i6,4x,"|",f12.3,6x,"|",f12.3,2x,"|",4x,f7.3,/),' + WRITE(cllignes(4)(1:6),'(I6)') jpnij + cllignes(5)='1x,"Total |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' + cllignes(6)='1x,"Minimum |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' + cllignes(7)='1x,"Maximum |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' + cllignes(8)='1x,"Average |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3)' + clfmt=TRIM(cllignes(1))// TRIM(cllignes(2))//TRIM(cllignes(3))// & + & TRIM(clhline)//TRIM(cllignes(4))//TRIM(clhline)//TRIM(cllignes(5))// & + & TRIM(clhline)//TRIM(cllignes(6))//TRIM(clhline)//TRIM(cllignes(7))// & + & TRIM(clhline)//TRIM(cllignes(8)) + WRITE(numtime, TRIM(clfmt)) & + (iall_rank(idum),all_etime(idum),all_ctime(idum),zall_ratio(idum),idum=1, jpnij), & + tot_etime, tot_ctime, ztot_ratio, & + zmin_etime, zmin_ctime, zmin_ratio, & + zmax_etime, zmax_ctime, zmax_ratio, & + zavg_etime, zavg_ctime, zavg_ratio + WRITE(numtime,*) + END IF + ! + DEALLOCATE(zall_ratio, iall_rank) + ! + END SUBROUTINE wmpi_info +#endif + + + SUBROUTINE timing_ini_var(cdinfo) + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_ini_var *** + !! ** Purpose : create timing structure + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdinfo + LOGICAL :: ll_section + + ! + IF( .NOT. ASSOCIATED(s_timer_root) ) THEN + ALLOCATE(s_timer_root) + s_timer_root%cname = cdinfo + s_timer_root%t_cpu = 0._dp + s_timer_root%t_clock = 0._dp + s_timer_root%tsum_cpu = 0._dp + s_timer_root%tsum_clock = 0._dp + s_timer_root%tmax_cpu = 0._dp + s_timer_root%tmax_clock = 0._dp + s_timer_root%tmin_cpu = 0._dp + s_timer_root%tmin_clock = 0._dp + s_timer_root%tsub_cpu = 0._dp + s_timer_root%tsub_clock = 0._dp + s_timer_root%ncount = 0 + s_timer_root%ncount_rate = 0 + s_timer_root%ncount_max = 0 + s_timer_root%niter = 0 + s_timer_root%l_tdone = .FALSE. + s_timer_root%next => NULL() + s_timer_root%prev => NULL() + s_timer => s_timer_root + ! + ALLOCATE(s_wrk) + s_wrk => NULL() + ! + ALLOCATE(s_timer_old) + s_timer_old%cname = cdinfo + s_timer_old%t_cpu = 0._dp + s_timer_old%t_clock = 0._dp + s_timer_old%tsum_cpu = 0._dp + s_timer_old%tsum_clock = 0._dp + s_timer_old%tmax_cpu = 0._dp + s_timer_old%tmax_clock = 0._dp + s_timer_old%tmin_cpu = 0._dp + s_timer_old%tmin_clock = 0._dp + s_timer_old%tsub_cpu = 0._dp + s_timer_old%tsub_clock = 0._dp + s_timer_old%ncount = 0 + s_timer_old%ncount_rate = 0 + s_timer_old%ncount_max = 0 + s_timer_old%niter = 0 + s_timer_old%l_tdone = .TRUE. + s_timer_old%next => NULL() + s_timer_old%prev => NULL() + + ELSE + s_timer => s_timer_root + ! case of already existing area (typically inside a loop) + ! write(*,*) 'in ini_var for routine : ', cdinfo + DO WHILE( ASSOCIATED(s_timer) ) + IF( TRIM(s_timer%cname) .EQ. TRIM(cdinfo) ) THEN + ! write(*,*) 'in ini_var for routine : ', cdinfo,' we return' + RETURN ! cdinfo is already in the chain + ENDIF + s_timer => s_timer%next + END DO + + ! end of the chain + s_timer => s_timer_root + DO WHILE( ASSOCIATED(s_timer%next) ) + s_timer => s_timer%next + END DO + + ! write(*,*) 'after search', s_timer%cname + ! cdinfo is not part of the chain so we add it with initialisation + ALLOCATE(s_timer%next) + ! write(*,*) 'after allocation of next' + + s_timer%next%cname = cdinfo + s_timer%next%t_cpu = 0._dp + s_timer%next%t_clock = 0._dp + s_timer%next%tsum_cpu = 0._dp + s_timer%next%tsum_clock = 0._dp + s_timer%next%tmax_cpu = 0._dp + s_timer%next%tmax_clock = 0._dp + s_timer%next%tmin_cpu = 0._dp + s_timer%next%tmin_clock = 0._dp + s_timer%next%tsub_cpu = 0._dp + s_timer%next%tsub_clock = 0._dp + s_timer%next%ncount = 0 + s_timer%next%ncount_rate = 0 + s_timer%next%ncount_max = 0 + s_timer%next%niter = 0 + s_timer%next%l_tdone = .FALSE. + s_timer%next%parent_section => NULL() + s_timer%next%prev => s_timer + s_timer%next%next => NULL() + s_timer => s_timer%next + ENDIF + ! write(*,*) 'after allocation' + ! + END SUBROUTINE timing_ini_var + + + SUBROUTINE timing_reset + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_reset *** + !! ** Purpose : go to root of timing tree + !!---------------------------------------------------------------------- + l_initdone = .TRUE. +! IF(lwp) WRITE(numout,*) +! IF(lwp) WRITE(numout,*) 'timing_reset : instrumented routines for timing' +! IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + CALL timing_list(s_timer_root) +! WRITE(numout,*) + ! + END SUBROUTINE timing_reset + + + RECURSIVE SUBROUTINE timing_list(ptr) + + TYPE(timer), POINTER, INTENT(inout) :: ptr + ! + IF( ASSOCIATED(ptr%next) ) CALL timing_list(ptr%next) + IF(lwp) WRITE(numout,*)' ', ptr%cname + ! + END SUBROUTINE timing_list + + + SUBROUTINE insert(sd_current, sd_root ,sd_ptr) + !!---------------------------------------------------------------------- + !! *** ROUTINE insert *** + !! ** Purpose : insert an element in timer structure + !!---------------------------------------------------------------------- + TYPE(timer), POINTER, INTENT(inout) :: sd_current, sd_root, sd_ptr + ! + + IF( ASSOCIATED( sd_current, sd_root ) ) THEN + ! If our current element is the root element then + ! replace it with the one being inserted + sd_root => sd_ptr + ELSE + sd_current%prev%next => sd_ptr + END IF + sd_ptr%next => sd_current + sd_ptr%prev => sd_current%prev + sd_current%prev => sd_ptr + ! Nullify the pointer to the new element now that it is held + ! within the list. If we don't do this then a subsequent call + ! to ALLOCATE memory to this pointer will fail. + sd_ptr => NULL() + ! + END SUBROUTINE insert + + + SUBROUTINE suppress(sd_ptr) + !!---------------------------------------------------------------------- + !! *** ROUTINE suppress *** + !! ** Purpose : supress an element in timer structure + !!---------------------------------------------------------------------- + TYPE(timer), POINTER, INTENT(inout) :: sd_ptr + ! + TYPE(timer), POINTER :: sl_temp + + sl_temp => sd_ptr + sd_ptr => sd_ptr%next + IF ( ASSOCIATED(sl_temp%next) ) sl_temp%next%prev => sl_temp%prev + DEALLOCATE(sl_temp) + sl_temp => NULL() + ! + END SUBROUTINE suppress + + !!===================================================================== +END MODULE timing diff --git a/cfgs/OCE_MIXED_TIMINGS_REFERENCE/trc_oce.F90 b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/trc_oce.F90 new file mode 100644 index 0000000..ed57a5d --- /dev/null +++ b/cfgs/OCE_MIXED_TIMINGS_REFERENCE/trc_oce.F90 @@ -0,0 +1,260 @@ +MODULE trc_oce + !!====================================================================== + !! *** MODULE trc_oce *** + !! Ocean passive tracer : share SMS/Ocean variables + !!====================================================================== + !! History : 1.0 ! 2004-03 (C. Ethe) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trc_oce_rgb : tabulated attenuation coefficients for RGB light penetration + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE dom_oce ! ocean space and time domain + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC trc_oce_rgb ! routine called by traqsr.F90 + PUBLIC trc_oce_rgb_read ! routine called by traqsr.F90 + PUBLIC trc_oce_ext_lev ! function called by traqsr.F90 at least + PUBLIC trc_oce_alloc ! function called by nemogcm.F90 + + LOGICAL , PUBLIC :: l_co2cpl = .false. !: atmospheric pco2 recieved from oasis + LOGICAL , PUBLIC :: l_offline = .false. !: offline passive tracers flag + REAL(wp), PUBLIC :: r_si2 !: largest depth of extinction (blue & 0.01 mg.m-3) (RGB) + LOGICAL , PUBLIC :: ln_trcdc2dm !: Diurnal cycle for TOP + ! + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: etot3 !: light absortion coefficient + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: oce_co2 !: ocean carbon flux + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_mean !: daily mean qsr + +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' bio-model + !!---------------------------------------------------------------------- + LOGICAL, PUBLIC, PARAMETER :: lk_top = .TRUE. !: TOP model +#else + !!---------------------------------------------------------------------- + !! Default option No bio-model light absorption + !!---------------------------------------------------------------------- + LOGICAL, PUBLIC, PARAMETER :: lk_top = .FALSE. !: TOP model +#endif + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: trc_oce.F90 13286 2020-07-09 15:48:29Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trc_oce_alloc() + !!---------------------------------------------------------------------- + !! *** trc_oce_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( etot3(jpi,jpj,jpk), oce_co2(jpi,jpj), qsr_mean(jpi,jpj), STAT=trc_oce_alloc ) + + IF( trc_oce_alloc /= 0 ) CALL ctl_warn('trc_oce_alloc: failed to allocate etot3 array') + ! + END FUNCTION trc_oce_alloc + + + SUBROUTINE trc_oce_rgb( prgb ) + !!--------------------------------------------------------------------- + !! *** ROUTINE p4z_opt_init *** + !! + !! ** Purpose : Initialization of of the optical scheme + !! + !! ** Method : Set a look up table for the optical coefficients + !! i.e. the attenuation coefficient for R-G-B light + !! tabulated in Chlorophyll class (from JM Andre) + !! + !! ** Action : prgb(3,61) tabulated R-G-B attenuation coef. + !! + !! Reference : Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(3,61), INTENT(out) :: prgb ! tabulated attenuation coefficient + ! + INTEGER :: jc ! dummy loop indice + INTEGER :: irgb ! temporary integer + REAL(wp) :: zchl ! temporary scalar + REAL(wp), DIMENSION(4,61) :: zrgb ! tabulated attenuation coefficient (formerly read in 'kRGB61.txt') + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' trc_oce_rgb : Initialisation of the optical look-up table' + WRITE(numout,*) ' ~~~~~~~~~~~ ' + ENDIF + ! + ! Chlorophyll ! Blue attenuation ! Green attenuation ! Red attenuation ! + zrgb(1, 1) = 0.010 ; zrgb(2, 1) = 0.01618 ; zrgb(3, 1) = 0.07464 ; zrgb(4, 1) = 0.37807 + zrgb(1, 2) = 0.011 ; zrgb(2, 2) = 0.01654 ; zrgb(3, 2) = 0.07480 ; zrgb(4, 2) = 0.37823 + zrgb(1, 3) = 0.013 ; zrgb(2, 3) = 0.01693 ; zrgb(3, 3) = 0.07499 ; zrgb(4, 3) = 0.37840 + zrgb(1, 4) = 0.014 ; zrgb(2, 4) = 0.01736 ; zrgb(3, 4) = 0.07518 ; zrgb(4, 4) = 0.37859 + zrgb(1, 5) = 0.016 ; zrgb(2, 5) = 0.01782 ; zrgb(3, 5) = 0.07539 ; zrgb(4, 5) = 0.37879 + zrgb(1, 6) = 0.018 ; zrgb(2, 6) = 0.01831 ; zrgb(3, 6) = 0.07562 ; zrgb(4, 6) = 0.37900 + zrgb(1, 7) = 0.020 ; zrgb(2, 7) = 0.01885 ; zrgb(3, 7) = 0.07586 ; zrgb(4, 7) = 0.37923 + zrgb(1, 8) = 0.022 ; zrgb(2, 8) = 0.01943 ; zrgb(3, 8) = 0.07613 ; zrgb(4, 8) = 0.37948 + zrgb(1, 9) = 0.025 ; zrgb(2, 9) = 0.02005 ; zrgb(3, 9) = 0.07641 ; zrgb(4, 9) = 0.37976 + zrgb(1,10) = 0.028 ; zrgb(2,10) = 0.02073 ; zrgb(3,10) = 0.07672 ; zrgb(4,10) = 0.38005 + zrgb(1,11) = 0.032 ; zrgb(2,11) = 0.02146 ; zrgb(3,11) = 0.07705 ; zrgb(4,11) = 0.38036 + zrgb(1,12) = 0.035 ; zrgb(2,12) = 0.02224 ; zrgb(3,12) = 0.07741 ; zrgb(4,12) = 0.38070 + zrgb(1,13) = 0.040 ; zrgb(2,13) = 0.02310 ; zrgb(3,13) = 0.07780 ; zrgb(4,13) = 0.38107 + zrgb(1,14) = 0.045 ; zrgb(2,14) = 0.02402 ; zrgb(3,14) = 0.07821 ; zrgb(4,14) = 0.38146 + zrgb(1,15) = 0.050 ; zrgb(2,15) = 0.02501 ; zrgb(3,15) = 0.07866 ; zrgb(4,15) = 0.38189 + zrgb(1,16) = 0.056 ; zrgb(2,16) = 0.02608 ; zrgb(3,16) = 0.07914 ; zrgb(4,16) = 0.38235 + zrgb(1,17) = 0.063 ; zrgb(2,17) = 0.02724 ; zrgb(3,17) = 0.07967 ; zrgb(4,17) = 0.38285 + zrgb(1,18) = 0.071 ; zrgb(2,18) = 0.02849 ; zrgb(3,18) = 0.08023 ; zrgb(4,18) = 0.38338 + zrgb(1,19) = 0.079 ; zrgb(2,19) = 0.02984 ; zrgb(3,19) = 0.08083 ; zrgb(4,19) = 0.38396 + zrgb(1,20) = 0.089 ; zrgb(2,20) = 0.03131 ; zrgb(3,20) = 0.08149 ; zrgb(4,20) = 0.38458 + zrgb(1,21) = 0.100 ; zrgb(2,21) = 0.03288 ; zrgb(3,21) = 0.08219 ; zrgb(4,21) = 0.38526 + zrgb(1,22) = 0.112 ; zrgb(2,22) = 0.03459 ; zrgb(3,22) = 0.08295 ; zrgb(4,22) = 0.38598 + zrgb(1,23) = 0.126 ; zrgb(2,23) = 0.03643 ; zrgb(3,23) = 0.08377 ; zrgb(4,23) = 0.38676 + zrgb(1,24) = 0.141 ; zrgb(2,24) = 0.03842 ; zrgb(3,24) = 0.08466 ; zrgb(4,24) = 0.38761 + zrgb(1,25) = 0.158 ; zrgb(2,25) = 0.04057 ; zrgb(3,25) = 0.08561 ; zrgb(4,25) = 0.38852 + zrgb(1,26) = 0.178 ; zrgb(2,26) = 0.04289 ; zrgb(3,26) = 0.08664 ; zrgb(4,26) = 0.38950 + zrgb(1,27) = 0.200 ; zrgb(2,27) = 0.04540 ; zrgb(3,27) = 0.08775 ; zrgb(4,27) = 0.39056 + zrgb(1,28) = 0.224 ; zrgb(2,28) = 0.04811 ; zrgb(3,28) = 0.08894 ; zrgb(4,28) = 0.39171 + zrgb(1,29) = 0.251 ; zrgb(2,29) = 0.05103 ; zrgb(3,29) = 0.09023 ; zrgb(4,29) = 0.39294 + zrgb(1,30) = 0.282 ; zrgb(2,30) = 0.05420 ; zrgb(3,30) = 0.09162 ; zrgb(4,30) = 0.39428 + zrgb(1,31) = 0.316 ; zrgb(2,31) = 0.05761 ; zrgb(3,31) = 0.09312 ; zrgb(4,31) = 0.39572 + zrgb(1,32) = 0.355 ; zrgb(2,32) = 0.06130 ; zrgb(3,32) = 0.09474 ; zrgb(4,32) = 0.39727 + zrgb(1,33) = 0.398 ; zrgb(2,33) = 0.06529 ; zrgb(3,33) = 0.09649 ; zrgb(4,33) = 0.39894 + zrgb(1,34) = 0.447 ; zrgb(2,34) = 0.06959 ; zrgb(3,34) = 0.09837 ; zrgb(4,34) = 0.40075 + zrgb(1,35) = 0.501 ; zrgb(2,35) = 0.07424 ; zrgb(3,35) = 0.10040 ; zrgb(4,35) = 0.40270 + zrgb(1,36) = 0.562 ; zrgb(2,36) = 0.07927 ; zrgb(3,36) = 0.10259 ; zrgb(4,36) = 0.40480 + zrgb(1,37) = 0.631 ; zrgb(2,37) = 0.08470 ; zrgb(3,37) = 0.10495 ; zrgb(4,37) = 0.40707 + zrgb(1,38) = 0.708 ; zrgb(2,38) = 0.09056 ; zrgb(3,38) = 0.10749 ; zrgb(4,38) = 0.40952 + zrgb(1,39) = 0.794 ; zrgb(2,39) = 0.09690 ; zrgb(3,39) = 0.11024 ; zrgb(4,39) = 0.41216 + zrgb(1,40) = 0.891 ; zrgb(2,40) = 0.10374 ; zrgb(3,40) = 0.11320 ; zrgb(4,40) = 0.41502 + zrgb(1,41) = 1.000 ; zrgb(2,41) = 0.11114 ; zrgb(3,41) = 0.11639 ; zrgb(4,41) = 0.41809 + zrgb(1,42) = 1.122 ; zrgb(2,42) = 0.11912 ; zrgb(3,42) = 0.11984 ; zrgb(4,42) = 0.42142 + zrgb(1,43) = 1.259 ; zrgb(2,43) = 0.12775 ; zrgb(3,43) = 0.12356 ; zrgb(4,43) = 0.42500 + zrgb(1,44) = 1.413 ; zrgb(2,44) = 0.13707 ; zrgb(3,44) = 0.12757 ; zrgb(4,44) = 0.42887 + zrgb(1,45) = 1.585 ; zrgb(2,45) = 0.14715 ; zrgb(3,45) = 0.13189 ; zrgb(4,45) = 0.43304 + zrgb(1,46) = 1.778 ; zrgb(2,46) = 0.15803 ; zrgb(3,46) = 0.13655 ; zrgb(4,46) = 0.43754 + zrgb(1,47) = 1.995 ; zrgb(2,47) = 0.16978 ; zrgb(3,47) = 0.14158 ; zrgb(4,47) = 0.44240 + zrgb(1,48) = 2.239 ; zrgb(2,48) = 0.18248 ; zrgb(3,48) = 0.14701 ; zrgb(4,48) = 0.44765 + zrgb(1,49) = 2.512 ; zrgb(2,49) = 0.19620 ; zrgb(3,49) = 0.15286 ; zrgb(4,49) = 0.45331 + zrgb(1,50) = 2.818 ; zrgb(2,50) = 0.21102 ; zrgb(3,50) = 0.15918 ; zrgb(4,50) = 0.45942 + zrgb(1,51) = 3.162 ; zrgb(2,51) = 0.22703 ; zrgb(3,51) = 0.16599 ; zrgb(4,51) = 0.46601 + zrgb(1,52) = 3.548 ; zrgb(2,52) = 0.24433 ; zrgb(3,52) = 0.17334 ; zrgb(4,52) = 0.47313 + zrgb(1,53) = 3.981 ; zrgb(2,53) = 0.26301 ; zrgb(3,53) = 0.18126 ; zrgb(4,53) = 0.48080 + zrgb(1,54) = 4.467 ; zrgb(2,54) = 0.28320 ; zrgb(3,54) = 0.18981 ; zrgb(4,54) = 0.48909 + zrgb(1,55) = 5.012 ; zrgb(2,55) = 0.30502 ; zrgb(3,55) = 0.19903 ; zrgb(4,55) = 0.49803 + zrgb(1,56) = 5.623 ; zrgb(2,56) = 0.32858 ; zrgb(3,56) = 0.20898 ; zrgb(4,56) = 0.50768 + zrgb(1,57) = 6.310 ; zrgb(2,57) = 0.35404 ; zrgb(3,57) = 0.21971 ; zrgb(4,57) = 0.51810 + zrgb(1,58) = 7.079 ; zrgb(2,58) = 0.38154 ; zrgb(3,58) = 0.23129 ; zrgb(4,58) = 0.52934 + zrgb(1,59) = 7.943 ; zrgb(2,59) = 0.41125 ; zrgb(3,59) = 0.24378 ; zrgb(4,59) = 0.54147 + zrgb(1,60) = 8.912 ; zrgb(2,60) = 0.44336 ; zrgb(3,60) = 0.25725 ; zrgb(4,60) = 0.55457 + zrgb(1,61) = 10.000 ; zrgb(2,61) = 0.47804 ; zrgb(3,61) = 0.27178 ; zrgb(4,61) = 0.56870 + ! + prgb(:,:) = zrgb(2:4,:) + ! + r_si2 = 1.e0 / zrgb(2, 1) ! blue with the smallest chlorophyll concentration) + IF(lwp) WRITE(numout,*) ' RGB longest depth of extinction r_si2 = ', r_si2 + ! + DO jc = 1, 61 ! check + zchl = zrgb(1,jc) + irgb = NINT( 41 + 20.* LOG10( zchl ) + 1.e-15 ) + IF( irgb /= jc ) THEN + IF(lwp) WRITE(numout,*) ' jc =', jc, ' Chl = ', zchl, ' Chl class = ', irgb + CALL ctl_stop( 'trc_oce_rgb : inconsistency in Chl tabulated attenuation coeff.' ) + ENDIF + END DO + ! + END SUBROUTINE trc_oce_rgb + + + SUBROUTINE trc_oce_rgb_read( prgb ) + !!---------------------------------------------------------------------- + !! *** ROUTINE p4z_opt_init *** + !! + !! ** Purpose : Initialization of of the optical scheme + !! + !! ** Method : read the look up table for the optical coefficients + !! + !! ** input : xkrgb(61) precomputed array corresponding to the + !! attenuation coefficient (from JM Andre) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(3,61), INTENT(out) :: prgb ! tabulated attenuation coefficient + ! + INTEGER :: jc, jb ! dummy loop indice + INTEGER :: irgb ! temporary integer + REAL(wp) :: zchl ! temporary scalar + INTEGER :: numlight + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' trc_oce_rgb_read : optical look-up table read in kRGB61.txt file' + WRITE(numout,*) ' ~~~~~~~~~~~~~~~~' + WRITE(numout,*) + ENDIF + ! + CALL ctl_opn( numlight, 'kRGB61.txt', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) + DO jc = 1, 61 + READ(numlight,*) zchl, ( prgb(jb,jc), jb = 1, 3 ) + irgb = NINT( 41 + 20.* LOG10( zchl ) + 1.e-15 ) + IF(lwp) WRITE(numout,*) ' jc =', jc, ' Chl = ', zchl, ' irgb = ', irgb + IF( irgb /= jc ) THEN + IF(lwp) WRITE(numout,*) ' jc =', jc, ' Chl = ', zchl, ' Chl class = ', irgb + CALL ctl_stop( 'trc_oce_rgb_read : inconsistency in Chl tabulated attenuation coeff.' ) + ENDIF + END DO + CLOSE( numlight ) + ! + r_si2 = 1.e0 / prgb(1, 1) ! blue with the smallest chlorophyll concentration) + IF(lwp) WRITE(numout,*) ' RGB longest depth of extinction r_si2 = ', r_si2 + ! + END SUBROUTINE trc_oce_rgb_read + + + FUNCTION trc_oce_ext_lev( prldex, pqsr_frc ) RESULT( pjl ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trc_oce_ext_lev *** + !! + !! ** Purpose : compute max. level for light penetration + !! + !! ** Method : the function provides the level at which irradiance + !! becomes negligible (i.e. = 1.e-15 W/m2) for 3 or 2 bands light + !! penetration: I(z) = pqsr_frc * EXP(hext/prldex) = 1.e-15 W/m2 + !! # prldex is the longest depth of extinction: + !! - prldex = 23 m (2 bands case) + !! - prldex = 62 m (3 bands case: blue waveband & 0.01 mg/m2 for the chlorophyll) + !! # pqsr_frc is the fraction of solar radiation which penetrates, + !! considering Qsr=240 W/m2 and rn_abs = 0.58: + !! - pqsr_frc = Qsr * (1-rn_abs) = 1.00e2 W/m2 (2 bands case) + !! - pqsr_frc = Qsr * (1-rn_abs)/3 = 0.33e2 W/m2 (3 bands case & equi-partition) + !! + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in) :: prldex ! longest depth of extinction + REAL(wp), INTENT(in) :: pqsr_frc ! frac. solar radiation which penetrates + ! + INTEGER :: jk, pjl ! levels + REAL(wp) :: zhext ! deepest level till which light penetrates + REAL(wp) :: zprec = 15._wp ! precision to reach -LOG10(1.e-15) + REAL(wp) :: zem ! temporary scalar + !!---------------------------------------------------------------------- + ! + ! It is not necessary to compute anything below the following depth + zhext = prldex * ( LOG(10._wp) * zprec + LOG(pqsr_frc) ) + ! + ! Level of light extinction + pjl = jpkm1 + DO jk = jpkm1, 1, -1 + IF(SUM(tmask(:,:,jk)) > 0 ) THEN + zem = MAXVAL( gdepw_0(:,:,jk+1) * tmask(:,:,jk) ) + IF( zem >= zhext ) pjl = jk ! last T-level reached by Qsr + ELSE + pjl = jk ! or regional sea-bed depth + ENDIF + END DO + ! + END FUNCTION trc_oce_ext_lev + + !!====================================================================== +END MODULE trc_oce \ No newline at end of file -- GitLab