Changeset 14058
- Timestamp:
- 2020-12-03T16:53:41+01:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes
- Files:
-
- 20 deleted
- 93 edited
- 6 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/cfgs/AGRIF_DEMO/EXPREF/1_namelist_cfg
r13558 r14058 299 299 !----------------------------------------------------------------------- 300 300 ln_dynvor_een = .true. ! energy & enstrophy scheme 301 nn_een_e3f = 0 ! =0 e3f = mean masked e3t divided by 4302 301 / 303 302 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/cfgs/AGRIF_DEMO/EXPREF/namelist_cfg
r13558 r14058 300 300 !----------------------------------------------------------------------- 301 301 ln_dynvor_een = .true. ! energy & enstrophy scheme 302 nn_een_e3f = 0 ! =0 e3f = mean masked e3t divided by 4303 302 / 304 303 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/cfgs/AMM12/EXPREF/namelist_cfg
r13558 r14058 291 291 !----------------------------------------------------------------------- 292 292 ln_dynvor_een = .true. ! energy & enstrophy scheme 293 nn_een_e3f = 1! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)293 nn_e3f_typ = 1 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 294 294 / 295 295 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/cfgs/ORCA2_ICE_PISCES/EXPREF/namelist_cfg
r14046 r14058 334 334 !----------------------------------------------------------------------- 335 335 ln_dynvor_een = .true. ! energy & enstrophy scheme 336 nn_een_e3f = 0 ! =0 e3f = mean masked e3t divided by 4337 336 / 338 337 !----------------------------------------------------------------------- … … 389 388 ! ! = 3 as =2 with distinct dissipative an mixing length scale 390 389 nn_etau = 1 ! penetration of tke below the mixed layer (ML) due to NIWs 391 392 393 390 ! ! = 0 none ; = 1 add a tke source below the ML 391 ! ! = 2 add a tke source just at the base of the ML 392 ! ! = 3 as = 1 applied on HF part of the stress (ln_cpl=T) 394 393 ln_mxhsw = .false. ! surface mixing length scale = F(wave height) 395 394 / -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/cfgs/SHARED/axis_def_nemo.xml
r12377 r14058 14 14 <axis id="depthv" long_name="Vertical V levels" unit="m" positive="down" /> 15 15 <axis id="depthw" long_name="Vertical W levels" unit="m" positive="down" /> 16 <axis id="depthf" long_name="Vertical F levels" unit="m" positive="down" /> 16 17 <axis id="nfloat" long_name="Float number" unit="-" /> 17 18 <axis id="icbcla" long_name="Iceberg class" unit="1" /> -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/cfgs/SHARED/domain_def_nemo.xml
r12276 r14058 181 181 <domain id="EqW" domain_ref="grid_W" > <zoom_domain id="EqW"/> </domain> 182 182 183 <!-- F grid --> 184 <domain id="grid_F" long_name="grid F"/> 185 183 186 <!-- zonal mean grid --> 184 187 <domain_group id="gznl"> -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/cfgs/SHARED/field_def_nemo-oce.xml
r14047 r14058 171 171 <field id="tosmint_pot" long_name="vertical integral of potential temperature times density" standard_name="integral_wrt_depth_of_product_of_density_and_potential_temperature" unit="(kg m2) degree_C" /> 172 172 173 173 <field id="ht" long_name="water column height at T point" standard_name="water_column_height_T" unit="m" /> 174 174 <field id="ssh" long_name="sea surface height" standard_name="sea_surface_height_above_geoid" unit="m" /> 175 175 <field id="ssh2" long_name="square of sea surface height" standard_name="square_of_sea_surface_height_above_geoid" unit="m2" > ssh * ssh </field > … … 190 190 191 191 <!-- Energy - horizontal divergence --> 192 <field id="sKE" long_name="surface kinetic energy" standard_name="specific_kinetic_energy_of_sea_water" unit="m2/s2" grid_ref="grid_T_2D" /> 192 193 <field id="hdiv" long_name="horizontal divergence" unit="s-1" grid_ref="grid_T_3D" /> 193 194 … … 556 557 557 558 <field_group id="grid_U" grid_ref="grid_U_2D"> 559 <field id="hu" long_name="water column height at U point" standard_name="water_column_height_U" unit="m" /> 558 560 <field id="e2u" long_name="U-cell width in meridional direction" standard_name="cell_width" unit="m" /> 559 561 <field id="e3u" long_name="U-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_U_3D" /> … … 626 628 <field id="e3v" long_name="V-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_V_3D" /> 627 629 <field id="e3v_0" long_name="Initial V-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_V_3D" /> 630 <field id="hv" long_name="water column height at V point" standard_name="water_column_height_V" unit="m" /> 628 631 <field id="vtau" long_name="Wind Stress along j-axis" standard_name="surface_downward_y_stress" unit="N/m2" /> 629 632 <field id="voce" long_name="ocean current along j-axis" standard_name="sea_water_y_velocity" unit="m/s" grid_ref="grid_V_3D" /> … … 734 737 735 738 <!-- F grid --> 739 <field_group id="grid_F" grid_ref="grid_F_2D"> 740 <field id="e3f" long_name="F-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_F_3D" /> 741 <field id="e3f_0" long_name="F-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_F_3D" /> 742 <field id="hf" long_name="water column height at F point" standard_name="water_column_height_F" unit="m" /> 743 <field id="sKEf" long_name="surface kinetic energy at F point" standard_name="specific_kinetic_energy_of_sea_water" unit="m2/s2" /> 744 <field id="relvor" long_name="relative vorticity" standard_name="relative_vorticity" unit="1/s" /> 745 <field id="plavor" long_name="planetary vorticity" standard_name="planetary_vorticity" unit="1/s" /> 746 <field id="relpotvor" long_name="relative potential vorticity" standard_name="relpot_vorticity" unit="1/m.s" /> 747 <field id="abspotvor" long_name="absolute potential vorticity" standard_name="abspot_vorticity" unit="1/m.s" /> 748 <field id="Ens" long_name="enstrophy" standard_name="enstrophy" unit="1/m2.s2" /> 749 </field_group> 750 736 751 <!-- AGRIF sponge --> 737 752 <field id="agrif_spf" long_name=" AGRIF f-sponge coefficient" unit=" " /> -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/cfgs/SHARED/grid_def_nemo.xml
r12377 r14058 53 53 <domain domain_ref="grid_W" /> 54 54 <axis axis_ref="depthw" /> 55 </grid> 56 <!-- --> 57 <grid id="grid_F_2D" > 58 <domain domain_ref="grid_F" /> 59 </grid> 60 <!-- --> 61 <grid id="grid_F_3D" > 62 <domain domain_ref="grid_F" /> 63 <axis axis_ref="depthf" /> 55 64 </grid> 56 65 <!-- --> -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/cfgs/SHARED/namelist_ref
r14047 r14058 998 998 ln_dynvor_eeT = .false. ! energy conserving scheme (een using e3t) 999 999 ln_dynvor_een = .false. ! energy & enstrophy scheme 1000 nn_een_e3f = 0 ! =0 e3f = mi(mj(e3t))/4 1001 ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) 1000 ! 1002 1001 ln_dynvor_msk = .false. ! vorticity multiplied by fmask (=T) ==>>> PLEASE DO NOT ACTIVATE 1003 ! ! (f-point vorticity schemes only) 1002 ! ! (f-point vorticity schemes only) 1003 ! 1004 nn_e3f_typ = 0 ! type of e3f (EEN, ENE, ENS, MIX only) =0 e3f = mi(mj(e3t))/4 1005 ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) 1004 1006 / 1005 1007 !----------------------------------------------------------------------- … … 1035 1037 ! ! Type of the operator : 1036 1038 ln_dynldf_OFF = .false. ! No operator (i.e. no explicit diffusion) 1039 nn_dynldf_typ = 0 ! =0 div-rot (default) ; =1 symmetric 1037 1040 ln_dynldf_lap = .false. ! laplacian operator 1038 1041 ln_dynldf_blp = .false. ! bilaplacian operator … … 1165 1168 ln_mxl0 = .true. ! surface mixing length scale = F(wind stress) (T) or not (F) 1166 1169 nn_mxlice = 2 ! type of scaling under sea-ice 1167 1168 1169 1170 1170 ! ! = 0 no scaling under sea-ice 1171 ! ! = 1 scaling with constant sea-ice thickness 1172 ! ! = 2 scaling with mean sea-ice thickness ( only with SI3 sea-ice model ) 1173 ! ! = 3 scaling with maximum sea-ice thickness 1171 1174 rn_mxlice = 10. ! max constant ice thickness value when scaling under sea-ice ( nn_mxlice=1) 1172 1175 rn_mxl0 = 0.04 ! surface buoyancy lenght scale minimum value … … 1175 1178 rn_lc = 0.15 ! coef. associated to Langmuir cells 1176 1179 nn_etau = 1 ! penetration of tke below the mixed layer (ML) due to NIWs 1177 1178 1179 1180 ! ! = 0 none ; = 1 add a tke source below the ML 1181 ! ! = 2 add a tke source just at the base of the ML 1182 ! ! = 3 as = 1 applied on HF part of the stress (ln_cpl=T) 1180 1183 rn_efr = 0.05 ! fraction of surface tke value which penetrates below the ML (nn_etau=1 or 2) 1181 1184 nn_htau = 1 ! type of exponential decrease of tke penetration below the ML 1182 1183 1185 ! ! = 0 constant 10 m length scale 1186 ! ! = 1 0.5m at the equator to 30m poleward of 40 degrees 1184 1187 nn_eice = 1 ! attenutaion of langmuir & surface wave breaking under ice 1185 1188 ! ! = 0 no impact of ice cover on langmuir & surface wave breaking … … 1399 1402 ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs 1400 1403 ln_bound_reject = .false. ! Logical to remove obs near boundaries in LAMs. 1404 ln_default_fp_indegs = .true. ! Logical: T=> averaging footprint is in degrees, F=> in metres 1401 1405 ln_sla_fp_indegs = .true. ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres 1402 1406 ln_sst_fp_indegs = .true. ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres … … 1414 1418 cn_gridsearchfile ='gridsearch.nc' ! Grid search file name 1415 1419 rn_gridsearchres = 0.5 ! Grid search resolution 1420 rn_default_avglamscl = 0. ! Default E/W diameter of observation footprint (metres/degrees) 1421 rn_default_avgphiscl = 0. ! Default N/S diameter of observation footprint (metres/degrees) 1416 1422 rn_mdtcorr = 1.61 ! MDT correction 1417 1423 rn_mdtcutoff = 65.0 ! MDT cutoff for computed correction … … 1427 1433 rn_sic_avgphiscl = 0. ! N/S diameter of SIC observation footprint (metres/degrees) 1428 1434 nn_1dint = 0 ! Type of vertical interpolation method 1429 nn_2dint = 0! Default horizontal interpolation method1435 nn_2dint_default = 0 ! Default horizontal interpolation method 1430 1436 nn_2dint_sla = 0 ! Horizontal interpolation method for SLA 1431 1437 nn_2dint_sst = 0 ! Horizontal interpolation method for SST -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/doc/namelists/namobs
r11703 r14058 20 20 ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs 21 21 ln_bound_reject = .false. ! Logical to remove obs near boundaries in LAMs. 22 ln_default_fp_indegs = .true. ! Logical: T=> averaging footprint is in degrees, F=> in metres 22 23 ln_sla_fp_indegs = .true. ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres 23 24 ln_sst_fp_indegs = .true. ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres … … 39 40 rn_dobsini = 00010101.000000 ! Initial date in window YYYYMMDD.HHMMSS 40 41 rn_dobsend = 00010102.000000 ! Final date in window YYYYMMDD.HHMMSS 42 rn_default_avglamscl = 0. ! Default E/W diameter of observation footprint (metres/degrees) 43 rn_default_avgphiscl = 0. ! Default N/S diameter of observation footprint (metres/degrees) 41 44 rn_sla_avglamscl = 0. ! E/W diameter of SLA observation footprint (metres/degrees) 42 45 rn_sla_avgphiscl = 0. ! N/S diameter of SLA observation footprint (metres/degrees) … … 48 51 rn_sic_avgphiscl = 0. ! N/S diameter of SIC observation footprint (metres/degrees) 49 52 nn_1dint = 0 ! Type of vertical interpolation method 50 nn_2dint = 0! Default horizontal interpolation method53 nn_2dint_default = 0 ! Default horizontal interpolation method 51 54 nn_2dint_sla = 0 ! Horizontal interpolation method for SLA 52 55 nn_2dint_sst = 0 ! Horizontal interpolation method for SST -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/iceistate.F90
r14046 r14058 21 21 USE sbc_ice , ONLY : tn_ice, snwice_mass, snwice_mass_b 22 22 USE eosbn2 ! equation of state 23 # if defined key_qco 24 USE domqco ! Variable volume 25 # else 23 26 USE domvvl ! Variable volume 27 # endif 24 28 USE ice ! sea-ice: variables 25 29 USE ice1D ! sea-ice: thermodynamics variables … … 434 438 ssh(:,:,Kbb) = ssh(:,:,Kbb) - snwice_mass(:,:) * r1_rho0 435 439 ! 440 #if defined key_qco 441 IF( .NOT.ln_linssh ) CALL dom_qco_zgr( Kbb, Kmm ) ! interpolation scale factor, depth and water column 442 #else 436 443 IF( .NOT.ln_linssh ) CALL dom_vvl_zgr( Kbb, Kmm, Kaa ) ! interpolation scale factor, depth and water column 437 ! !!st 438 ! IF( .NOT.ln_linssh ) THEN 439 ! ! 440 ! WHERE( ht_0(:,:) > 0 ) ; z2d(:,:) = 1._wp + ssh(:,:,Kmm)*tmask(:,:,1) / ht_0(:,:) 441 ! ELSEWHERE ; z2d(:,:) = 1._wp ; END WHERE 442 ! ! 443 ! DO jk = 1,jpkm1 ! adjust initial vertical scale factors 444 ! e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * z2d(:,:) 445 ! e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm) 446 ! e3t(:,:,jk,Kaa) = e3t(:,:,jk,Kmm) 447 ! END DO 448 ! ! 449 ! ! Reconstruction of all vertical scale factors at now and before time-steps 450 ! ! ========================================================================= 451 ! ! Horizontal scale factor interpolations 452 ! ! -------------------------------------- 453 ! CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) 454 ! CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) 455 ! CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 456 ! CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 457 ! CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) 458 ! ! Vertical scale factor interpolations 459 ! ! ------------------------------------ 460 ! CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) 461 ! CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) 462 ! CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) 463 ! CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) 464 ! CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) 465 ! ! t- and w- points depth 466 ! ! ---------------------- 467 ! !!gm not sure of that.... 468 ! gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm) 469 ! gdepw(:,:,1,Kmm) = 0.0_wp 470 ! gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm) 471 ! DO jk = 2, jpk 472 ! gdept(:,:,jk,Kmm) = gdept(:,:,jk-1,Kmm) + e3w(:,:,jk ,Kmm) 473 ! gdepw(:,:,jk,Kmm) = gdepw(:,:,jk-1,Kmm) + e3t(:,:,jk-1,Kmm) 474 ! gde3w(:,:,jk) = gdept(:,:,jk ,Kmm) - ssh (:,:,Kmm) 475 ! END DO 476 ! ENDIF 444 #endif 445 477 446 ENDIF 478 447 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/NST/agrif_oce_interp.F90
r13286 r14058 28 28 USE agrif_oce 29 29 USE phycst 30 USE dynspg_ts, ONLY: un_adv, vn_adv30 !!! USE dynspg_ts, ONLY: un_adv, vn_adv 31 31 ! 32 32 USE in_out_manager … … 50 50 INTEGER :: bdy_tinterp = 0 51 51 52 !!---------------------------------------------------------------------- 52 !! * Substitutions 53 # include "domzgr_substitute.h90" 53 54 !! NEMO/NST 4.0 , NEMO Consortium (2018) 54 55 !! $Id$ … … 1192 1193 !!---------------------------------------------------------------------- 1193 1194 IF( before ) THEN 1194 IF ( ln_bt_fw ) THEN1195 ! IF ( ln_bt_fw ) THEN 1195 1196 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2) 1196 ELSE1197 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)1198 ENDIF1197 ! ELSE 1198 ! ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2) 1199 ! ENDIF 1199 1200 ELSE 1200 1201 zrhot = Agrif_rhot() … … 1228 1229 ! 1229 1230 IF( before ) THEN 1230 IF ( ln_bt_fw ) THEN1231 ! IF ( ln_bt_fw ) THEN 1231 1232 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2) 1232 ELSE1233 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)1234 ENDIF1233 ! ELSE 1234 ! ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2) 1235 ! ENDIF 1235 1236 ELSE 1236 1237 zrhot = Agrif_rhot() -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/NST/agrif_oce_sponge.F90
r13312 r14058 32 32 33 33 !! * Substitutions 34 # include "domzgr_substitute.h90" 34 35 # include "do_loop_substitute.h90" 35 36 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/NST/agrif_oce_update.F90
r13286 r14058 27 27 USE vremap ! Vertical remapping 28 28 USE lbclnk 29 29 #if defined key_qco 30 USE domqco 31 #endif 30 32 IMPLICIT NONE 31 33 PRIVATE … … 34 36 PUBLIC Update_Scales 35 37 38 !! * Substitutions 39 # include "domzgr_substitute.h90" 36 40 !!---------------------------------------------------------------------- 37 41 !! NEMO/NST 4.0 , NEMO Consortium (2018) … … 191 195 END SUBROUTINE Agrif_Update_Tke 192 196 193 194 197 SUBROUTINE Agrif_Update_vvl( ) 195 198 !!--------------------------------------------- … … 201 204 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update e3 from grid Number',Agrif_Fixed(), 'Step', Agrif_Nb_Step() 202 205 ! 206 #if ! defined key_qco 203 207 Agrif_UseSpecialValueInUpdate = .TRUE. 204 208 Agrif_SpecialValueFineGrid = 0. … … 213 217 CALL dom_vvl_update_UVF 214 218 CALL Agrif_ParentGrid_To_ChildGrid() 219 #else 220 CALL Agrif_ChildGrid_To_ParentGrid() 221 CALL Agrif_Update_qco 222 CALL Agrif_ParentGrid_To_ChildGrid() 223 #endif 215 224 ! 216 225 END SUBROUTINE Agrif_Update_vvl 217 226 227 228 #if defined key_qco 229 SUBROUTINE Agrif_Update_qco 230 !!--------------------------------------------- 231 !! *** ROUTINE dom_Update_qco *** 232 !!--------------------------------------------- 233 ! 234 ! Save arrays prior update (needed for asselin correction) 235 r3t(:,:,Krhs_a) = r3t(:,:,Kmm_a) 236 r3u(:,:,Krhs_a) = r3u(:,:,Kmm_a) 237 r3v(:,:,Krhs_a) = r3v(:,:,Kmm_a) 238 239 ! Update r3x arrays from updated ssh 240 CALL dom_qco_zgr( Kbb_a, Kmm_a ) 241 ! 242 END SUBROUTINE Agrif_Update_qco 243 #endif 244 245 246 #if ! defined key_qco 218 247 SUBROUTINE dom_vvl_update_UVF 219 248 !!--------------------------------------------- … … 224 253 REAL(wp):: zcoef 225 254 !!--------------------------------------------- 226 227 255 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Finalize e3 on grid Number', & 228 256 & Agrif_Fixed(), 'Step', Agrif_Nb_Step() … … 290 318 ! 291 319 END SUBROUTINE dom_vvl_update_UVF 320 #endif 292 321 293 322 #if defined key_vertical … … 1332 1361 END SUBROUTINE updateAVM 1333 1362 1363 #if ! defined key_qco 1334 1364 SUBROUTINE updatee3t(ptab_dum, i1, i2, j1, j2, k1, k2, before ) 1335 1365 !!--------------------------------------------- … … 1443 1473 ! 1444 1474 END SUBROUTINE updatee3t 1475 #endif 1445 1476 1446 1477 #else -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/NST/agrif_user.F90
r13546 r14058 288 288 CALL Agrif_Init_Variable(sshini_id, procname=agrif_initssh) 289 289 CALL lbc_lnk( 'Agrif_Init_Domain', ssh(:,:,Kbb), 'T', 1. ) 290 #if ! defined key_qco 290 291 DO jk = 1, jpk 291 292 e3t(:,:,jk,Kbb) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb) ) & … … 293 294 & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) 294 295 END DO 296 #endif 295 297 ENDIF 296 298 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DIA/diawri.F90
r14047 r14058 19 19 !! 3.7 ! 2014-01 (G. Madec) remove eddy induced velocity from no-IOM output 20 20 !! ! change name of output variables in dia_wri_state 21 !! 4.0 ! 2020-10 (A. Nasser, S. Techene) add diagnostic for SWE 21 22 !!---------------------------------------------------------------------- 22 23 … … 119 120 INTEGER :: ji, jj, jk ! dummy loop indices 120 121 INTEGER :: ikbot ! local integer 121 REAL(wp):: ze3122 122 REAL(wp):: zztmp , zztmpx ! local scalar 123 123 REAL(wp):: zztmp2, zztmpy ! - - 124 REAL(wp):: ze3 124 125 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 125 126 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace … … 138 139 CALL iom_put("e3u_0", e3u_0(:,:,:) ) 139 140 CALL iom_put("e3v_0", e3v_0(:,:,:) ) 141 CALL iom_put("e3f_0", e3f_0(:,:,:) ) 140 142 ! 141 143 IF ( iom_use("e3t") .OR. iom_use("e3tdef") ) THEN ! time-varying e3t … … 164 166 CALL iom_put( "e3w" , z3d(:,:,:) ) 165 167 ENDIF 168 IF ( iom_use("e3f") ) THEN ! time-varying e3f caution here at Kaa 169 DO jk = 1, jpk 170 z3d(:,:,jk) = e3f(:,:,jk) 171 END DO 172 CALL iom_put( "e3f" , z3d(:,:,:) ) 173 ENDIF 166 174 167 175 IF( ll_wd ) THEN ! sea surface height (brought back to the reference used for wetting and drying) 168 CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)* tmask(:,:,1) )176 CALL iom_put( "ssh" , (ssh(:,:,Kmm)+ssh_ref)*ssmask(:,:) ) 169 177 ELSE 170 178 CALL iom_put( "ssh" , ssh(:,:,Kmm) ) ! sea surface height 171 179 ENDIF 172 180 173 IF( iom_use("wetdep") ) & ! wet depth 174 CALL iom_put( "wetdep" , ht_0(:,:) + ssh(:,:,Kmm) ) 181 IF( iom_use("wetdep") ) CALL iom_put( "wetdep" , ht_0(:,:) + ssh(:,:,Kmm) ) ! wet depth 182 183 #if defined key_qco 184 IF( iom_use("ht") ) CALL iom_put( "ht" , ht(:,:) ) ! water column at t-point 185 IF( iom_use("hu") ) CALL iom_put( "hu" , hu(:,:,Kmm) ) ! water column at u-point 186 IF( iom_use("hv") ) CALL iom_put( "hv" , hv(:,:,Kmm) ) ! water column at v-point 187 IF( iom_use("hf") ) CALL iom_put( "hf" , hf_0(:,:)*( 1._wp + r3f(:,:) ) ) ! water column at f-point (caution here at Naa) 188 #endif 175 189 176 190 CALL iom_put( "toce", ts(:,:,:,jp_tem,Kmm) ) ! 3D temperature … … 326 340 ENDIF 327 341 ! 342 IF ( iom_use("sKE") ) THEN ! surface kinetic energy at T point 343 z2d(:,:) = 0._wp 344 DO_2D( 0, 0, 0, 0 ) 345 z2d(ji,jj) = 0.25_wp * ( uu(ji ,jj,1,Kmm) * uu(ji ,jj,1,Kmm) * e1e2u(ji ,jj) * e3u(ji ,jj,1,Kmm) & 346 & + uu(ji-1,jj,1,Kmm) * uu(ji-1,jj,1,Kmm) * e1e2u(ji-1,jj) * e3u(ji-1,jj,1,Kmm) & 347 & + vv(ji,jj ,1,Kmm) * vv(ji,jj ,1,Kmm) * e1e2v(ji,jj ) * e3v(ji,jj ,1,Kmm) & 348 & + vv(ji,jj-1,1,Kmm) * vv(ji,jj-1,1,Kmm) * e1e2v(ji,jj-1) * e3v(ji,jj-1,1,Kmm) ) & 349 & * r1_e1e2t(ji,jj) / e3t(ji,jj,1,Kmm) * ssmask(ji,jj) 350 END_2D 351 CALL lbc_lnk( 'diawri', z2d, 'T', 1. ) 352 IF ( iom_use("sKE" ) ) CALL iom_put( "sKE" , z2d ) 353 ENDIF 354 ! 355 IF ( iom_use("sKEf") ) THEN ! surface kinetic energy at F point 356 z2d(:,:) = 0._wp ! CAUTION : only valid in SWE, not with bathymetry 357 DO_2D( 0, 0, 0, 0 ) 358 z2d(ji,jj) = 0.25_wp * ( uu(ji,jj ,1,Kmm) * uu(ji,jj ,1,Kmm) * e1e2u(ji,jj ) * e3u(ji,jj ,1,Kmm) & 359 & + uu(ji,jj+1,1,Kmm) * uu(ji,jj+1,1,Kmm) * e1e2u(ji,jj+1) * e3u(ji,jj+1,1,Kmm) & 360 & + vv(ji ,jj,1,Kmm) * vv(ji,jj ,1,Kmm) * e1e2v(ji ,jj) * e3v(ji ,jj,1,Kmm) & 361 & + vv(ji+1,jj,1,Kmm) * vv(ji+1,jj,1,Kmm) * e1e2v(ji+1,jj) * e3v(ji+1,jj,1,Kmm) ) & 362 & * r1_e1e2f(ji,jj) / e3f(ji,jj,1) * ssfmask(ji,jj) 363 END_2D 364 CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 365 CALL iom_put( "sKEf", z2d ) 366 ENDIF 367 ! 328 368 CALL iom_put( "hdiv", hdiv ) ! Horizontal divergence 329 369 … … 425 465 426 466 IF (ln_dia25h) CALL dia_25h( kt, Kmm ) ! 25h averaging 467 468 ! Output of vorticity terms 469 IF ( iom_use("relvor") .OR. iom_use("plavor") .OR. & 470 & iom_use("relpotvor") .OR. iom_use("abspotvor") .OR. & 471 & iom_use("Ens") ) THEN 472 ! 473 z2d(:,:) = 0._wp 474 ze3 = 0._wp 475 DO_2D( 1, 0, 1, 0 ) 476 z2d(ji,jj) = ( e2v(ji+1,jj ) * vv(ji+1,jj ,1,Kmm) - e2v(ji,jj) * vv(ji,jj,1,Kmm) & 477 & - e1u(ji ,jj+1) * uu(ji ,jj+1,1,Kmm) + e1u(ji,jj) * uu(ji,jj,1,Kmm) ) * r1_e1e2f(ji,jj) 478 END_2D 479 CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 480 CALL iom_put( "relvor", z2d ) ! relative vorticity ( zeta ) 481 ! 482 CALL iom_put( "plavor", ff_f ) ! planetary vorticity ( f ) 483 ! 484 DO_2D( 1, 0, 1, 0 ) 485 ze3 = ( e3t(ji,jj+1,1,Kmm) * e1e2t(ji,jj+1) + e3t(ji+1,jj+1,1,Kmm) * e1e2t(ji+1,jj+1) & 486 & + e3t(ji,jj ,1,Kmm) * e1e2t(ji,jj ) + e3t(ji+1,jj ,1,Kmm) * e1e2t(ji+1,jj ) ) * r1_e1e2f(ji,jj) 487 IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3 488 ELSE ; ze3 = 0._wp 489 ENDIF 490 z2d(ji,jj) = ze3 * z2d(ji,jj) 491 END_2D 492 CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 493 CALL iom_put( "relpotvor", z2d ) ! relative potential vorticity (zeta/h) 494 ! 495 DO_2D( 1, 0, 1, 0 ) 496 ze3 = ( e3t(ji,jj+1,1,Kmm) * e1e2t(ji,jj+1) + e3t(ji+1,jj+1,1,Kmm) * e1e2t(ji+1,jj+1) & 497 & + e3t(ji,jj ,1,Kmm) * e1e2t(ji,jj ) + e3t(ji+1,jj ,1,Kmm) * e1e2t(ji+1,jj ) ) * r1_e1e2f(ji,jj) 498 IF( ze3 /= 0._wp ) THEN ; ze3 = 4._wp / ze3 499 ELSE ; ze3 = 0._wp 500 ENDIF 501 z2d(ji,jj) = ze3 * ff_f(ji,jj) + z2d(ji,jj) 502 END_2D 503 CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 504 CALL iom_put( "abspotvor", z2d ) ! absolute potential vorticity ( q ) 505 ! 506 DO_2D( 1, 0, 1, 0 ) 507 z2d(ji,jj) = 0.5_wp * z2d(ji,jj) * z2d(ji,jj) 508 END_2D 509 CALL lbc_lnk( 'diawri', z2d, 'F', 1. ) 510 CALL iom_put( "Ens", z2d ) ! potential enstrophy ( 1/2*q2 ) 511 ! 512 ENDIF 427 513 428 514 IF( ln_timing ) CALL timing_stop('dia_wri') … … 998 1084 !! 999 1085 INTEGER :: inum, jk 1000 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, zgdept ! 3D workspace !!st patch to usesubstitution1086 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, zgdept ! 3D workspace for qco substitution 1001 1087 !!---------------------------------------------------------------------- 1002 1088 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/dom_oce.F90
r14046 r14058 131 131 ! 132 132 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2t , r1_e1e2t !: associated metrics at t-point 133 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2u , e2_e1u, r1_e1e2u!: associated metrics at u-point134 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , e1_e2v, r1_e1e2v!: associated metrics at v-point133 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2u , r1_e1e2u , e2_e1u !: associated metrics at u-point 134 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , r1_e1e2v , e1_e2v !: associated metrics at v-point 135 135 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2f , r1_e1e2f !: associated metrics at f-point 136 136 ! … … 162 162 163 163 ! ! reference depths of cells 164 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0 !: t- depth [m]165 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 !: w- depth [m]166 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0 !: w- depth (sum of e3w) [m]164 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0 !: t- depth [m] 165 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 !: w- depth [m] 166 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0 !: w- depth (sum of e3w) [m] 167 167 ! ! time-dependent depths of cells 168 168 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: gdept, gdepw … … 205 205 206 206 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask, ssfmask !: surface mask at T-,U-, V- and F-pts 207 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, wmask, fmask !: land/ocean mask at T-, U-, V-, W- and F-pts 208 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wumask, wvmask !: land/ocean mask at WT-, WU- and WV-pts 209 207 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, wmask, fmask !: land/ocean mask at T-, U-, V-, W- and F-pts 208 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wumask, wvmask !: land/ocean mask at WU- and WV-pts 209 #if defined key_qco 210 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: fe3mask !: land/ocean mask at F-pts for qco 211 #endif 210 212 !!---------------------------------------------------------------------- 211 213 !! calendar variables … … 306 308 & e3w_0(jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , STAT=ierr(ii) ) 307 309 ! 308 #if ! defined key_qco 310 #if defined key_qco 311 ii = ii+1 312 ALLOCATE( r3t (jpi,jpj,jpt) , r3u (jpi,jpj,jpt) , r3v (jpi,jpj,jpt) , r3f (jpi,jpj) , & 313 & r3t_f(jpi,jpj) , r3u_f(jpi,jpj) , r3v_f(jpi,jpj) , STAT=ierr(ii) ) 314 #else 309 315 ii = ii+1 310 316 ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) , & … … 313 319 ! 314 320 ii = ii+1 315 ALLOCATE( r3t (jpi,jpj,jpt) , r3u (jpi,jpj,jpt) , r3v (jpi,jpj,jpt) , r3f (jpi,jpj) , &316 & r3t_f(jpi,jpj) , r3u_f(jpi,jpj) , r3v_f(jpi,jpj) , STAT=ierr(ii) )317 !318 ii = ii+1319 321 ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj) , hv_0(jpi,jpj) , hf_0(jpi,jpj) , & 320 322 & r1_ht_0(jpi,jpj) , r1_hu_0(jpi,jpj) , r1_hv_0(jpi,jpj), r1_hf_0(jpi,jpj) , STAT=ierr(ii) ) … … 323 325 ii = ii+1 324 326 ALLOCATE( ht (jpi,jpj) , hu (jpi,jpj,jpt), hv (jpi,jpj,jpt) , & 325 & r1_hu (jpi,jpj,jpt), r1_hv (jpi,jpj,jpt) , STAT=ierr(ii) )326 #else327 ii = ii+1328 ALLOCATE( hu (jpi,jpj,jpt), hv (jpi,jpj,jpt) , &329 327 & r1_hu (jpi,jpj,jpt), r1_hv (jpi,jpj,jpt) , STAT=ierr(ii) ) 330 328 #endif … … 350 348 ii = ii+1 351 349 ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 350 #if defined key_qco 351 ! 352 ii = ii+1 353 ALLOCATE( fe3mask(jpi,jpj,jpk) , STAT=ierr(ii) ) 354 #endif 352 355 ! 353 356 dom_oce_alloc = MAXVAL(ierr) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/domain.F90
r14046 r14058 15 15 !! 3.7 ! 2015-11 (G. Madec, A. Coward) time varying zgr by default 16 16 !! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface 17 !! 4. x ! 2020-02 (G. Madec, S. Techene)introduce ssh to h0 ratio17 !! 4.1 ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio 18 18 !!---------------------------------------------------------------------- 19 19 … … 28 28 USE oce ! ocean variables 29 29 USE dom_oce ! domain: ocean 30 #if defined key_qco 31 USE domqco ! quasi-eulerian 32 #else 33 USE domvvl ! variable volume 34 #endif 35 USE sshwzv , ONLY : ssh_init_rst ! set initial ssh 30 36 USE sbc_oce ! surface boundary condition: ocean 31 37 USE trc_oce ! shared ocean & passive tracers variab … … 35 41 USE dommsk ! domain: set the mask system 36 42 USE domwri ! domain: write the meshmask file 37 #if ! defined key_qco38 USE domvvl ! variable volume39 #else40 USE domqco ! variable volume41 #endif42 43 USE c1d ! 1D configuration 43 44 USE dyncor_c1d ! 1D configuration: Coriolis term (cor_c1d routine) 44 USE wet_dry , ONLY : ll_wd45 USE closea , ONLY : dom_clo ! closed seas45 USE wet_dry , ONLY : ll_wd ! wet & drying flag 46 USE closea , ONLY : dom_clo ! closed seas routine 46 47 ! 47 48 USE prtctl ! Print control (prt_ctl_info routine) … … 50 51 USE lbclnk ! ocean lateral boundary condition (or mpp link) 51 52 USE lib_mpp ! distributed memory computing library 53 USE restart ! only for lrst_oce 52 54 53 55 IMPLICIT NONE … … 58 60 PUBLIC dom_tile ! called by step.F90 59 61 62 !! * Substitutions 63 # include "do_loop_substitute.h90" 60 64 !!------------------------------------------------------------------------- 61 65 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 84 88 INTEGER :: ji, jj, jk, jt ! dummy loop indices 85 89 INTEGER :: iconf = 0 ! local integers 90 REAL(wp):: zrdt 86 91 CHARACTER (len=64) :: cform = "(A12, 3(A13, I7))" 87 92 INTEGER , DIMENSION(jpi,jpj) :: ik_top , ik_bot ! top and bottom ocean level … … 121 126 WRITE(numout,*) ' cn_cfg = ', TRIM( cn_cfg ), ' nn_cfg = ', nn_cfg 122 127 ENDIF 123 nn_wxios = 0 124 ln_xios_read = .FALSE. 128 125 129 ! 126 130 ! !== Reference coordinate system ==! … … 143 147 hv_0(:,:) = 0._wp 144 148 hf_0(:,:) = 0._wp 145 DO jk = 1, jpk 149 DO jk = 1, jpkm1 146 150 ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk) 147 151 hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk) 148 152 hv_0(:,:) = hv_0(:,:) + e3v_0(:,:,jk) * vmask(:,:,jk) 149 hf_0(:,:) = hf_0(:,:) + e3f_0(:,:,jk) * fmask(:,:,jk)150 153 END DO 154 ! 155 DO jk = 1, jpkm1 156 hf_0(1:jpim1,:) = hf_0(1:jpim1,:) + e3f_0(1:jpim1,:,jk)*vmask(1:jpim1,:,jk)*vmask(2:jpi,:,jk) 157 END DO 158 CALL lbc_lnk('domain', hf_0, 'F', 1._wp) 159 ! 160 IF( lk_SWE ) THEN ! SWE case redefine hf_0 161 hf_0(:,:) = hf_0(:,:) + e3f_0(:,:,1) * ssfmask(:,:) 162 ENDIF 151 163 ! 152 164 r1_ht_0(:,:) = ssmask (:,:) / ( ht_0(:,:) + 1._wp - ssmask (:,:) ) … … 154 166 r1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) ) 155 167 r1_hf_0(:,:) = ssfmask(:,:) / ( hf_0(:,:) + 1._wp - ssfmask(:,:) ) 156 168 ! 169 IF( ll_wd ) THEN ! wet and drying (check ht_0 >= 0) 170 DO_2D( 1, 1, 1, 1 ) 171 IF( ht_0(ji,jj) < 0._wp .AND. ssmask(ji,jj) == 1._wp ) THEN 172 CALL ctl_stop( 'ssh_init_rst : ht_0 must be positive at potentially wet points' ) 173 ENDIF 174 END_2D 175 ENDIF 176 ! 177 ! !== initialisation of time varying coordinate ==! 178 ! 179 ! != ssh initialization 180 IF( .NOT.l_offline .AND. .NOT.l_SAS ) THEN 181 CALL ssh_init_rst( Kbb, Kmm, Kaa ) 182 ELSE 183 ssh(:,:,:) = 0._wp 184 ENDIF 157 185 ! 158 186 #if defined key_qco 159 ! !== initialisation of time varying coordinate ==!Quasi-Euerian coordinate case187 ! != Quasi-Euerian coordinate case 160 188 ! 161 189 IF( .NOT.l_offline ) CALL dom_qco_init( Kbb, Kmm, Kaa ) 162 !163 IF( ln_linssh ) CALL ctl_stop('STOP','domain: key_qco and ln_linssh = T are incompatible')164 !165 190 #else 166 ! !== time varying part of coordinate system ==! 167 ! 168 IF( ln_linssh ) THEN != Fix in time : set to the reference one for all 191 ! 192 IF( ln_linssh ) THEN != Fix in time : set to the reference one for all 169 193 ! 170 194 DO jt = 1, jpt ! depth of t- and w-grid-points … … 175 199 ! 176 200 DO jt = 1, jpt ! vertical scale factors 177 e3t (:,:,:,jt) = e3t_0(:,:,:)178 e3u (:,:,:,jt) = e3u_0(:,:,:)179 e3v (:,:,:,jt) = e3v_0(:,:,:)180 e3w (:,:,:,jt) = e3w_0(:,:,:)201 e3t (:,:,:,jt) = e3t_0(:,:,:) 202 e3u (:,:,:,jt) = e3u_0(:,:,:) 203 e3v (:,:,:,jt) = e3v_0(:,:,:) 204 e3w (:,:,:,jt) = e3w_0(:,:,:) 181 205 e3uw(:,:,:,jt) = e3uw_0(:,:,:) 182 206 e3vw(:,:,:,jt) = e3vw_0(:,:,:) 183 207 END DO 184 e3f (:,:,:) = e3f_0(:,:,:)208 e3f (:,:,:) = e3f_0(:,:,:) 185 209 ! 186 210 DO jt = 1, jpt ! water column thickness and its inverse 187 hu(:,:,jt)= hu_0(:,:)188 hv(:,:,jt)= hv_0(:,:)211 hu(:,:,jt) = hu_0(:,:) 212 hv(:,:,jt) = hv_0(:,:) 189 213 r1_hu(:,:,jt) = r1_hu_0(:,:) 190 214 r1_hv(:,:,jt) = r1_hv_0(:,:) 191 215 END DO 192 ht(:,:) = ht_0(:,:)193 ! 194 ELSE != time varying : initialize before/now/after variables216 ht (:,:) = ht_0(:,:) 217 ! 218 ELSE != Time varying : initialize before/now/after variables 195 219 ! 196 220 IF( .NOT.l_offline ) CALL dom_vvl_init( Kbb, Kmm, Kaa ) … … 373 397 USE ioipsl 374 398 !! 375 INTEGER :: ios ! Local integer 399 INTEGER :: ios ! Local integer 400 REAL(wp):: zrdt 401 !!---------------------------------------------------------------------- 376 402 ! 377 403 NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list, & … … 393 419 ENDIF 394 420 ! 421 ! !=======================! 422 ! !== namelist namdom ==! 423 ! !=======================! 424 ! 425 READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) 426 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' ) 427 READ ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) 428 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' ) 429 IF(lwm) WRITE( numond, namdom ) 430 ! 431 #if defined key_agrif 432 IF( .NOT. Agrif_Root() ) THEN ! AGRIF child, subdivide the Parent timestep 433 rn_Dt = Agrif_Parent (rn_Dt ) / Agrif_Rhot() 434 ENDIF 435 #endif 436 ! 437 IF(lwp) THEN 438 WRITE(numout,*) 439 WRITE(numout,*) ' Namelist : namdom --- space & time domain' 440 WRITE(numout,*) ' linear free surface (=T) ln_linssh = ', ln_linssh 441 WRITE(numout,*) ' create mesh/mask file ln_meshmask = ', ln_meshmask 442 WRITE(numout,*) ' ocean time step rn_Dt = ', rn_Dt 443 WRITE(numout,*) ' asselin time filter parameter rn_atfp = ', rn_atfp 444 WRITE(numout,*) ' online coarsening of dynamical fields ln_crs = ', ln_crs 445 ENDIF 446 ! 447 ! set current model timestep rDt = 2*rn_Dt if MLF or rDt = rn_Dt if RK3 448 rDt = 2._wp * rn_Dt 449 r1_Dt = 1._wp / rDt 450 ! 451 IF( l_SAS .AND. .NOT.ln_linssh ) THEN 452 CALL ctl_warn( 'SAS requires linear ssh : force ln_linssh = T' ) 453 ln_linssh = .TRUE. 454 ENDIF 455 ! 456 #if defined key_qco 457 IF( ln_linssh ) CALL ctl_stop( 'STOP','domain: key_qco and ln_linssh = T are incompatible' ) 458 #endif 459 ! 460 ! !=======================! 461 ! !== namelist namrun ==! 462 ! !=======================! 395 463 ! 396 464 READ ( numnam_ref, namrun, IOSTAT = ios, ERR = 901) … … 452 520 nleapy = nn_leapy 453 521 ninist = nn_istate 522 ! 523 ! !== Set parameters for restart reading using xIOS ==! 524 ! 525 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 526 lrxios = ln_xios_read .AND. ln_rstart 527 IF( nn_wxios > 0 ) lwxios = .TRUE. !* set output file type for XIOS based on NEMO namelist 528 nxioso = nn_wxios 529 ENDIF 530 ! !== Check consistency between ln_rstart and ln_1st_euler ==! (i.e. set l_1st_euler) 454 531 l_1st_euler = ln_1st_euler 455 IF( .NOT. l_1st_euler .AND. .NOT. ln_rstart ) THEN 532 ! 533 IF( ln_rstart ) THEN !* Restart case 534 ! 535 IF(lwp) WRITE(numout,*) 536 IF(lwp) WRITE(numout,*) ' open the restart file' 537 CALL rst_read_open !- Open the restart file 538 ! 539 IF( iom_varid( numror, 'rdt', ldstop = .FALSE. ) > 0 ) THEN !- Check time-step consistency and force Euler restart if changed 540 CALL iom_get( numror, 'rdt', zrdt ) 541 IF( zrdt /= rn_Dt ) THEN 542 IF(lwp) WRITE( numout,*) 543 IF(lwp) WRITE( numout,*) ' rn_Dt = ', rn_Dt,' not equal to the READ one rdt = ', zrdt 544 IF(lwp) WRITE( numout,*) 545 IF(lwp) WRITE( numout,*) ' ==>>> forced euler first time-step' 546 l_1st_euler = .TRUE. 547 ENDIF 548 ENDIF 549 ! 550 IF( .NOT.l_SAS .AND. iom_varid( numror, 'sshb', ldstop = .FALSE. ) <= 0 ) THEN !- Check absence of one of the Kbb field (here sshb) 551 ! ! (any Kbb field is missing ==> all Kbb fields are missing) 552 IF( .NOT.l_1st_euler ) THEN 553 CALL ctl_warn('dom_nam : ssh at Kbb not found in restart files ', & 554 & 'l_1st_euler forced to .true. and ' , & 555 & 'ssh(Kbb) = ssh(Kmm) ' ) 556 l_1st_euler = .TRUE. 557 ENDIF 558 ENDIF 559 ELSEIF( .NOT.l_1st_euler ) THEN !* Initialization case 456 560 IF(lwp) WRITE(numout,*) 457 561 IF(lwp) WRITE(numout,*)' ==>>> Start from rest (ln_rstart=F)' 458 562 IF(lwp) WRITE(numout,*)' an Euler initial time step is used : l_1st_euler is forced to .true. ' 459 l_1st_euler = .true. 460 ENDIF 461 ! ! control of output frequency 462 IF( .NOT. ln_rst_list ) THEN ! we use nn_stock 563 l_1st_euler = .TRUE. 564 ENDIF 565 ! 566 ! !== control of output frequency ==! 567 ! 568 IF( .NOT. ln_rst_list ) THEN ! we use nn_stock 463 569 IF( nn_stock == -1 ) CALL ctl_warn( 'nn_stock = -1 --> no restart will be done' ) 464 570 IF( nn_stock == 0 .OR. nn_stock > nitend ) THEN … … 479 585 IF( Agrif_Root() ) THEN 480 586 IF(lwp) WRITE(numout,*) 481 SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL587 SELECT CASE ( nleapy ) !== Choose calendar for IOIPSL ==! 482 588 CASE ( 1 ) 483 589 CALL ioconf_calendar('gregorian') … … 491 597 END SELECT 492 598 ENDIF 493 494 READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) 495 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' ) 496 READ ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) 497 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist' ) 498 IF(lwm) WRITE( numond, namdom ) 499 ! 500 #if defined key_agrif 501 IF( .NOT. Agrif_Root() ) THEN 502 rn_Dt = Agrif_Parent(rn_Dt) / Agrif_Rhot() 503 ENDIF 504 #endif 505 ! 506 IF(lwp) THEN 507 WRITE(numout,*) 508 WRITE(numout,*) ' Namelist : namdom --- space & time domain' 509 WRITE(numout,*) ' linear free surface (=T) ln_linssh = ', ln_linssh 510 WRITE(numout,*) ' create mesh/mask file ln_meshmask = ', ln_meshmask 511 WRITE(numout,*) ' ocean time step rn_Dt = ', rn_Dt 512 WRITE(numout,*) ' asselin time filter parameter rn_atfp = ', rn_atfp 513 WRITE(numout,*) ' online coarsening of dynamical fields ln_crs = ', ln_crs 514 ENDIF 515 ! 516 !! Initialise current model timestep rDt = 2*rn_Dt if MLF or rDt = rn_Dt if RK3 517 rDt = 2._wp * rn_Dt 518 r1_Dt = 1._wp / rDt 519 599 ! 600 ! !========================! 601 ! !== namelist namtile ==! 602 ! !========================! 603 ! 520 604 READ ( numnam_ref, namtile, IOSTAT = ios, ERR = 905 ) 521 605 905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtile in reference namelist' ) … … 537 621 ENDIF 538 622 ENDIF 539 540 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 541 lrxios = ln_xios_read.AND.ln_rstart 542 !set output file type for XIOS based on NEMO namelist 543 IF (nn_wxios > 0) lwxios = .TRUE. 544 nxioso = nn_wxios 545 ENDIF 546 623 ! 547 624 #if defined key_netcdf4 548 ! ! NetCDF 4 case ("key_netcdf4" defined) 625 ! !=======================! 626 ! !== namelist namnc4 ==! NetCDF 4 case ("key_netcdf4" defined) 627 ! !=======================! 628 ! 549 629 READ ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907) 550 630 907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in reference namelist' ) … … 555 635 IF(lwp) THEN ! control print 556 636 WRITE(numout,*) 557 WRITE(numout,*) ' Namelist namnc4 - Netcdf4 chunking parameters '637 WRITE(numout,*) ' Namelist namnc4 - Netcdf4 chunking parameters ("key_netcdf4" defined)' 558 638 WRITE(numout,*) ' number of chunks in i-dimension nn_nchunks_i = ', nn_nchunks_i 559 639 WRITE(numout,*) ' number of chunks in j-dimension nn_nchunks_j = ', nn_nchunks_j … … 618 698 SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 619 699 !!---------------------------------------------------------------------- 620 !! *** ROUTINE dom _nam***700 !! *** ROUTINE domain_cfg *** 621 701 !! 622 702 !! ** Purpose : read the domain size in domain configuration file -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/dommsk.F90
r13461 r14058 181 181 ssvmask(:,:) = MAXVAL( vmask(:,:,:), DIM=3 ) 182 182 ssfmask(:,:) = MAXVAL( fmask(:,:,:), DIM=3 ) 183 IF( lk_SWE ) THEN ! Shallow Water Eq. case : redefine ssfmask 184 DO_2D( 0,0 , 0,0 ) 185 ssfmask(ji,jj) = MAX( ssmask(ji,jj+1), ssmask(ji+1,jj+1), & 186 & ssmask(ji,jj ), ssmask(ji+1,jj ) ) 187 END_2D 188 CALL lbc_lnk( 'dommsk', ssfmask, 'F', 1.0_wp ) 189 ENDIF 190 #if defined key_qco 191 fe3mask(:,:,:) = fmask(:,:,:) 192 #endif 183 193 184 194 ! Interior domain mask (used for global sum) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/domqco.F90
r14046 r14058 8 8 !! 3.3 ! 2011-10 (M. Leclair) totally rewrote domvvl: vvl option includes z_star and z_tilde coordinates 9 9 !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability 10 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename dom_vvl_sf_swp -> dom_vvl_sf_update for new timestepping11 !! 4.x ! 2020-02 (G. Madec, S. Techene) pure z* (quasi-eulerian) coordinate12 !!---------------------------------------------------------------------- 13 14 !!---------------------------------------------------------------------- 15 !! dom_q e_init: define initial vertical scale factors, depths and column thickness16 !! dom_q e_r3c : Compute ssh/h_0 ratioat t-, u-, v-, and optionally f-points17 !! qe_rst_read : read/write restart file18 !! dom_qe_ctl: Check the vvl options10 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) add time level indices for prognostic variables 11 !! - ! 2020-02 (S. Techene, G. Madec) quasi-eulerian coordinate (z* or s*) 12 !!---------------------------------------------------------------------- 13 14 !!---------------------------------------------------------------------- 15 !! dom_qco_init : define initial vertical scale factors, depths and column thickness 16 !! dom_qco_zgr : Set ssh/h_0 ratio at t 17 !! dom_qco_r3c : Compute ssh/h_0 ratio at t-, u-, v-, and optionally f-points 18 !! qco_ctl : Check the vvl options 19 19 !!---------------------------------------------------------------------- 20 20 USE oce ! ocean dynamics and tracers … … 55 55 LOGICAL , PUBLIC :: ln_vvl_dbg = .FALSE. ! debug control prints 56 56 57 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: un_td, vn_td ! thickness diffusion transport58 59 57 !! * Substitutions 60 58 # include "do_loop_substitute.h90" … … 79 77 !! 80 78 !!---------------------------------------------------------------------- 81 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 79 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! time level indices 80 !!---------------------------------------------------------------------- 82 81 ! 83 82 IF(lwp) WRITE(numout,*) … … 85 84 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 86 85 ! 87 CALL dom_qco_ctl ! choose vertical coordinate (z_star, z_tilde or layer) 88 ! 89 ! ! Read or initialize e3t_(b/n), tilde_e3t_(b/n) and hdiv_lf 90 CALL qe_rst_read( nit000, Kbb, Kmm ) 91 ! 92 CALL dom_qco_zgr(Kbb, Kmm, Kaa) ! interpolation scale factor, depth and water column 86 CALL qco_ctl ! choose vertical coordinate (z_star, z_tilde or layer) 87 ! 88 CALL dom_qco_zgr( Kbb, Kmm ) ! interpolation scale factor, depth and water column 89 ! 90 #if defined key_agrif 91 ! We need to define r3[tuv](Kaa) for AGRIF initialisation (should not be a 92 ! problem for the restartability...) 93 r3t(:,:,Kaa) = r3t(:,:,Kmm) 94 r3u(:,:,Kaa) = r3u(:,:,Kmm) 95 r3v(:,:,Kaa) = r3v(:,:,Kmm) 96 #endif 93 97 ! 94 98 END SUBROUTINE dom_qco_init 95 99 96 100 97 SUBROUTINE dom_qco_zgr( Kbb, Kmm, Kaa)101 SUBROUTINE dom_qco_zgr( Kbb, Kmm ) 98 102 !!---------------------------------------------------------------------- 99 103 !! *** ROUTINE dom_qco_init *** 100 104 !! 101 !! ** Purpose : Initialization of all ssh. to h._0 ratio 102 !! 103 !! ** Method : - interpolate scale factors 104 !! 105 !! ** Action : - r3(t/u/v)_b 106 !! - r3(t/u/v/f)_n 107 !! 108 !! Reference : Leclair, M., and G. Madec, 2011, Ocean Modelling. 109 !!---------------------------------------------------------------------- 110 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 105 !! ** Purpose : Initialization of all r3. = ssh./h._0 ratios 106 !! 107 !! ** Method : Call domqco using Kbb and Kmm 108 !! NB: dom_qco_zgr is called by dom_qco_init it uses ssh from ssh_init 109 !! 110 !! ** Action : - r3(t/u/v)(Kbb) 111 !! - r3(t/u/v/f)(Kmm) 112 !!---------------------------------------------------------------------- 113 INTEGER, INTENT(in) :: Kbb, Kmm ! time level indices 111 114 !!---------------------------------------------------------------------- 112 115 ! 113 116 ! !== Set of all other vertical scale factors ==! (now and before) 114 117 ! ! Horizontal interpolation of e3t 115 CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb) )118 CALL dom_qco_r3c( ssh(:,:,Kbb), r3t(:,:,Kbb), r3u(:,:,Kbb), r3v(:,:,Kbb) ) 116 119 CALL dom_qco_r3c( ssh(:,:,Kmm), r3t(:,:,Kmm), r3u(:,:,Kmm), r3v(:,:,Kmm), r3f(:,:) ) 117 120 ! … … 143 146 ! !== ratio at u-,v-point ==! 144 147 ! 145 IF( ln_dynadv_vec ) THEN !- Vector Form (thickness weighted averaging) 148 !!st IF( ln_dynadv_vec ) THEN !- Vector Form (thickness weighted averaging) 149 #if ! defined key_qcoTest_FluxForm 150 ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average 146 151 DO_2D( 0, 0, 0, 0 ) 147 152 pr3u(ji,jj) = 0.5_wp * ( e1e2t(ji ,jj) * pssh(ji ,jj) & … … 150 155 & + e1e2t(ji,jj+1) * pssh(ji,jj+1) ) * r1_hv_0(ji,jj) * r1_e1e2v(ji,jj) 151 156 END_2D 152 ELSE !- Flux Form (simple averaging) 157 !!st ELSE !- Flux Form (simple averaging) 158 #else 153 159 DO_2D( 0, 0, 0, 0 ) 154 pr3u(ji,jj) = 0.5_wp * ( pssh(ji ,jj) + pssh(ji+1,jj) ) * r1_hu_0(ji,jj)155 pr3v(ji,jj) = 0.5_wp * ( pssh(ji,jj ) + pssh(ji,jj+1) ) * r1_hv_0(ji,jj)160 pr3u(ji,jj) = 0.5_wp * ( pssh(ji,jj) + pssh(ji+1,jj ) ) * r1_hu_0(ji,jj) 161 pr3v(ji,jj) = 0.5_wp * ( pssh(ji,jj) + pssh(ji ,jj+1) ) * r1_hv_0(ji,jj) 156 162 END_2D 157 ENDIF 163 !!st ENDIF 164 #endif 158 165 ! 159 166 IF( .NOT.PRESENT( pr3f ) ) THEN !- lbc on ratio at u-, v-points only … … 163 170 ELSE !== ratio at f-point ==! 164 171 ! 165 IF( ln_dynadv_vec ) THEN !- Vector Form (thickness weighted averaging) 166 DO_2D( 1, 0, 1, 0 ) ! start from 1 since lbc_lnk('F') doesn't update the 1st row/line 172 !!st IF( ln_dynadv_vec ) THEN !- Vector Form (thickness weighted averaging) 173 #if ! defined key_qcoTest_FluxForm 174 ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average 175 176 DO_2D( 0, 0, 0, 0 ) ! start from 1 since lbc_lnk('F') doesn't update the 1st row/line 167 177 pr3f(ji,jj) = 0.25_wp * ( e1e2t(ji ,jj ) * pssh(ji ,jj ) & 168 178 & + e1e2t(ji+1,jj ) * pssh(ji+1,jj ) & … … 170 180 & + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1) ) * r1_hf_0(ji,jj) * r1_e1e2f(ji,jj) 171 181 END_2D 172 ELSE !- Flux Form (simple averaging) 173 DO_2D( 1, 0, 1, 0 ) ! start from 1 since lbc_lnk('F') doesn't update the 1st row/line 174 pr3f(ji,jj) = 0.25_wp * ( pssh(ji ,jj ) + pssh(ji+1,jj ) & 175 & + pssh(ji ,jj+1) + pssh(ji+1,jj+1) ) * r1_hf_0(ji,jj) 182 !!st ELSE !- Flux Form (simple averaging) 183 #else 184 DO_2D( 0, 0, 0, 0 ) ! start from 1 since lbc_lnk('F') doesn't update the 1st row/line 185 pr3f(ji,jj) = 0.25_wp * ( pssh(ji,jj ) + pssh(ji+1,jj ) & 186 & + pssh(ji,jj+1) + pssh(ji+1,jj+1) ) * r1_hf_0(ji,jj) 176 187 END_2D 177 ENDIF 188 !!st ENDIF 189 #endif 178 190 ! ! lbc on ratio at u-,v-,f-points 179 191 CALL lbc_lnk_multi( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp, pr3f, 'F', 1._wp ) … … 184 196 185 197 186 SUBROUTINE q e_rst_read( kt, Kbb, Kmm )198 SUBROUTINE qco_ctl 187 199 !!--------------------------------------------------------------------- 188 !! *** ROUTINE qe_rst_read *** 189 !! 190 !! ** Purpose : Read ssh in restart file 191 !! 192 !! ** Method : use of IOM library 193 !! if the restart does not contain ssh, 194 !! it is set to the _0 values. 195 !!---------------------------------------------------------------------- 196 INTEGER , INTENT(in) :: kt ! ocean time-step 197 INTEGER , INTENT(in) :: Kbb, Kmm ! ocean time level indices 198 ! 199 INTEGER :: ji, jj, jk 200 INTEGER :: id1, id2 ! local integers 201 !!---------------------------------------------------------------------- 202 ! 203 IF( ln_rstart ) THEN !* Read the restart file 204 CALL rst_read_open ! open the restart file if necessary 205 ! 206 id1 = iom_varid( numror, 'sshb', ldstop = .FALSE. ) 207 id2 = iom_varid( numror, 'sshn', ldstop = .FALSE. ) 208 ! 209 ! ! --------- ! 210 ! ! all cases ! 211 ! ! --------- ! 212 ! 213 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 214 CALL iom_get( numror, jpdom_auto, 'sshb' , ssh(:,:,Kbb) ) 215 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) ) 216 ! needed to restart if land processor not computed 217 IF(lwp) write(numout,*) 'qe_rst_read : ssh(:,:,Kbb) and ssh(:,:,Kmm) found in restart files' 218 WHERE ( ssmask(:,:) == 0.0_wp ) !!gm/st ==> sm should not be necessary on ssh when it was required on e3 219 ssh(:,:,Kmm) = 0._wp 220 ssh(:,:,Kbb) = 0._wp 221 END WHERE 222 IF( l_1st_euler ) THEN 223 ssh(:,:,Kbb) = ssh(:,:,Kmm) 224 ENDIF 225 ELSE IF( id1 > 0 ) THEN 226 IF(lwp) write(numout,*) 'qe_rst_read WARNING : ssh(:,:,Kmm) not found in restart files' 227 IF(lwp) write(numout,*) 'sshn set equal to sshb.' 228 IF(lwp) write(numout,*) 'neuler is forced to 0' 229 CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb) ) 230 ssh(:,:,Kmm) = ssh(:,:,Kbb) 231 l_1st_euler = .TRUE. 232 ELSE IF( id2 > 0 ) THEN 233 IF(lwp) write(numout,*) 'qe_rst_read WARNING : ssh(:,:,Kbb) not found in restart files' 234 IF(lwp) write(numout,*) 'sshb set equal to sshn.' 235 IF(lwp) write(numout,*) 'neuler is forced to 0' 236 CALL iom_get( numror, jpdom_auto, 'sshn', ssh(:,:,Kmm) ) 237 ssh(:,:,Kbb) = ssh(:,:,Kmm) 238 l_1st_euler = .TRUE. 239 ELSE 240 IF(lwp) write(numout,*) 'qe_rst_read WARNING : ssh(:,:,Kmm) not found in restart file' 241 IF(lwp) write(numout,*) 'ssh_b and ssh_n set to zero' 242 IF(lwp) write(numout,*) 'neuler is forced to 0' 243 ssh(:,:,:) = 0._wp 244 l_1st_euler = .TRUE. 245 ENDIF 246 ! 247 ELSE !* Initialize at "rest" 248 ! 249 IF( ll_wd ) THEN ! MJB ll_wd edits start here - these are essential 250 ! 251 IF( cn_cfg == 'wad' ) THEN ! Wetting and drying test case 252 CALL usr_def_istate( gdept(:,:,:,Kbb), tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) ) 253 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones 254 ssh(:,: ,Kmm) = ssh(:,: ,Kbb) 255 uu (:,:,: ,Kmm) = uu (:,:,: ,Kbb) 256 vv (:,:,: ,Kmm) = vv (:,:,: ,Kbb) 257 ELSE ! if not test case 258 ssh(:,:,Kmm) = -ssh_ref 259 ssh(:,:,Kbb) = -ssh_ref 260 ! 261 DO_2D( 1, 1, 1, 1 ) 262 IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth 263 ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) ) 264 ssh(ji,jj,Kmm) = rn_wdmin1 - (ht_0(ji,jj) ) 265 ENDIF 266 END_2D 267 ENDIF 268 269 DO ji = 1, jpi 270 DO jj = 1, jpj 271 IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN 272 CALL ctl_stop( 'qe_rst_read: ht_0 must be positive at potentially wet points' ) 273 ENDIF 274 END DO 275 END DO 276 ! 277 ELSE 278 ! 279 ! Just to read set ssh in fact, called latter once vertical grid 280 ! is set up: 281 ! CALL usr_def_istate( gdept_0, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) ) 282 ! ! 283 ssh(:,:,:) = 0._wp 284 ! 285 ENDIF ! end of ll_wd edits 286 ! 287 ENDIF 288 ! 289 END SUBROUTINE qe_rst_read 290 291 292 SUBROUTINE dom_qco_ctl 293 !!--------------------------------------------------------------------- 294 !! *** ROUTINE dom_qco_ctl *** 200 !! *** ROUTINE qco_ctl *** 295 201 !! 296 202 !! ** Purpose : Control the consistency between namelist options … … 312 218 IF(lwp) THEN ! Namelist print 313 219 WRITE(numout,*) 314 WRITE(numout,*) ' dom_qco_ctl : choice/control of the variable vertical coordinate'315 WRITE(numout,*) '~~~~~~~~ ~~~'220 WRITE(numout,*) 'qco_ctl : choice/control of the variable vertical coordinate' 221 WRITE(numout,*) '~~~~~~~~' 316 222 WRITE(numout,*) ' Namelist nam_vvl : chose a vertical coordinate' 317 223 WRITE(numout,*) ' zstar ln_vvl_zstar = ', ln_vvl_zstar … … 357 263 #endif 358 264 ! 359 END SUBROUTINE dom_qco_ctl265 END SUBROUTINE qco_ctl 360 266 361 267 !!====================================================================== -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/domvvl.F90
r14046 r14058 9 9 !! 3.6 ! 2014-11 (P. Mathiot) add ice shelf capability 10 10 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) rename dom_vvl_sf_swp -> dom_vvl_sf_update for new timestepping 11 !! 4.x !2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio11 !! - ! 2020-02 (G. Madec, S. Techene) introduce ssh to h0 ratio 12 12 !!---------------------------------------------------------------------- 13 13 … … 766 766 !! ** Purpose : Read or write VVL file in restart file 767 767 !! 768 !! ** Method : use of IOM library 769 !! if the restart does not contain vertical scale factors, 770 !! they are set to the _0 values 771 !! if the restart does not contain vertical scale factors increments (z_tilde), 772 !! they are set to 0. 768 !! ** Method : * restart comes from a linear ssh simulation : 769 !! an attempt to read e3t_n stops simulation 770 !! * restart comes from a z-star, z-tilde, or layer : 771 !! read e3t_n and e3t_b 772 !! * restart comes from a z-star : 773 !! set tilde_e3t_n, tilde_e3t_n, and hdiv_lf to 0 774 !! * restart comes from layer : 775 !! read tilde_e3t_n and tilde_e3t_b 776 !! set hdiv_lf to 0 777 !! * restart comes from a z-tilde: 778 !! read tilde_e3t_n, tilde_e3t_b, and hdiv_lf 779 !! 780 !! NB: if l_1st_euler = T (ln_1st_euler or ssh_b not found) 781 !! Kbb fields set to Kmm ones 773 782 !!---------------------------------------------------------------------- 774 783 INTEGER , INTENT(in) :: kt ! ocean time-step … … 776 785 CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag 777 786 ! 778 INTEGER :: ji, jj, jk 779 INTEGER :: id 1, id2, id3, id4, id5! local integers780 !!---------------------------------------------------------------------- 781 ! 782 IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise783 ! ! ===============784 IF( ln_rstart ) THEN !* Read the restart file785 CALL rst_read_open ! open the restart file if necessary786 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) )787 INTEGER :: ji, jj, jk ! dummy loop indices 788 INTEGER :: id3, id4, id5 ! local integers 789 !!---------------------------------------------------------------------- 790 ! 791 ! !=====================! 792 IF( TRIM(cdrw) == 'READ' ) THEN ! Read / initialise ! 793 ! !=====================! 794 ! 795 IF( ln_rstart ) THEN !== Read the restart file ==! 787 796 ! 788 id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) 789 id2 = iom_varid( numror, 'e3t_n', ldstop = .FALSE. ) 790 id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. ) 797 CALL rst_read_open !* open the restart file if necessary 798 ! ! --------- ! 799 ! ! all cases ! 800 ! ! --------- ! 801 ! 802 id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. ) !* check presence 791 803 id4 = iom_varid( numror, 'tilde_e3t_n', ldstop = .FALSE. ) 792 id5 = iom_varid( numror, 'hdiv_lf' , ldstop = .FALSE. )804 id5 = iom_varid( numror, 'hdiv_lf' , ldstop = .FALSE. ) 793 805 ! 794 ! ! --------- ! 795 ! ! all cases ! 796 ! ! --------- ! 797 ! 798 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 806 ! !* scale factors 807 IF(lwp) WRITE(numout,*) ' Kmm scale factor read in the restart file' 808 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 809 WHERE ( tmask(:,:,:) == 0.0_wp ) 810 e3t(:,:,:,Kmm) = e3t_0(:,:,:) 811 END WHERE 812 IF( l_1st_euler ) THEN ! euler 813 IF(lwp) WRITE(numout,*) ' Euler first time step : e3t(Kbb) = e3t(Kmm)' 814 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 815 ELSE ! leap frog 816 IF(lwp) WRITE(numout,*) ' Kbb scale factor read in the restart file' 799 817 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 800 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) )801 ! needed to restart if land processor not computed802 IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files'803 818 WHERE ( tmask(:,:,:) == 0.0_wp ) 804 e3t(:,:,:,Kmm) = e3t_0(:,:,:)805 819 e3t(:,:,:,Kbb) = e3t_0(:,:,:) 806 820 END WHERE 807 IF( l_1st_euler ) THEN808 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)809 ENDIF810 ELSE IF( id1 > 0 ) THEN811 IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kmm) not found in restart files'812 IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.'813 IF(lwp) write(numout,*) 'l_1st_euler is forced to true'814 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) )815 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb)816 l_1st_euler = .true.817 ELSE IF( id2 > 0 ) THEN818 IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kbb) not found in restart files'819 IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.'820 IF(lwp) write(numout,*) 'l_1st_euler is forced to true'821 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) )822 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)823 l_1st_euler = .true.824 ELSE825 IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t(:,:,:,Kmm) not found in restart file'826 IF(lwp) write(numout,*) 'Compute scale factor from sshn'827 IF(lwp) write(numout,*) 'l_1st_euler is forced to true'828 DO jk = 1, jpk829 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) &830 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) &831 & + e3t_0(:,:,jk) * (1._wp -tmask(:,:,jk))832 END DO833 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm)834 l_1st_euler = .true.835 821 ENDIF 836 ! !----------- !837 IF( ln_vvl_zstar ) THEN !z_star case !838 ! !----------- !822 ! ! ------------ ! 823 IF( ln_vvl_zstar ) THEN ! z_star case ! 824 ! ! ------------ ! 839 825 IF( MIN( id3, id4 ) > 0 ) THEN 840 826 CALL ctl_stop( 'dom_vvl_rst: z_star cannot restart from a z_tilde or layer run' ) 841 827 ENDIF 842 ! ! ----------------------- ! 843 ELSE ! z_tilde and layer cases ! 844 ! ! ----------------------- ! 845 IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist 846 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 828 ! ! ------------------------ ! 829 ELSE ! z_tilde and layer cases ! 830 ! ! ------------------------ ! 831 ! 832 IF( id4 > 0 ) THEN !* scale factor increments 833 IF(lwp) WRITE(numout,*) ' Kmm scale factor increments read in the restart file' 847 834 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 848 ELSE ! one at least array is missing 835 IF( l_1st_euler ) THEN ! euler 836 IF(lwp) WRITE(numout,*) ' Euler first time step : tilde_e3t(Kbb) = tilde_e3t(Kmm)' 837 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) 838 ELSE ! leap frog 839 IF(lwp) WRITE(numout,*) ' Kbb scale factor increments read in the restart file' 840 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 841 ENDIF 842 ELSE 849 843 tilde_e3t_b(:,:,:) = 0.0_wp 850 844 tilde_e3t_n(:,:,:) = 0.0_wp 851 845 ENDIF 852 ! ! ------------ !853 IF( ln_vvl_ztilde ) THEN ! z_tilde case !854 ! ! ------------ !846 ! ! ------------ ! 847 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 848 ! ! ------------ ! 855 849 IF( id5 > 0 ) THEN ! required array exists 856 850 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) 857 851 ELSE ! array is missing 858 hdiv_lf(:,:,:) = 0.0_wp 852 hdiv_lf(:,:,:) = 0.0_wp 859 853 ENDIF 860 854 ENDIF 861 855 ENDIF 862 856 ! 863 ELSE ! * Initialize at "rest"857 ELSE !== Initialize at "rest" with ssh ==! 864 858 ! 865 866 IF( ll_wd ) THEN ! MJB ll_wd edits start here - these are essential 867 ! 868 IF( cn_cfg == 'wad' ) THEN 869 ! Wetting and drying test case 870 CALL usr_def_istate( gdept(:,:,:,Kbb), tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) ) 871 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones 872 ssh (:,:,Kmm) = ssh(:,:,Kbb) 873 uu (:,:,:,Kmm) = uu (:,:,:,Kbb) 874 vv (:,:,:,Kmm) = vv (:,:,:,Kbb) 875 ELSE 876 ! if not test case 877 ssh(:,:,Kmm) = -ssh_ref 878 ssh(:,:,Kbb) = -ssh_ref 879 880 DO_2D( 1, 1, 1, 1 ) 881 IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth 882 ssh(ji,jj,Kbb) = rn_wdmin1 - (ht_0(ji,jj) ) 883 ssh(ji,jj,Kmm) = rn_wdmin1 - (ht_0(ji,jj) ) 884 ENDIF 885 END_2D 886 ENDIF !If test case else 887 888 ! Adjust vertical metrics for all wad 889 DO jk = 1, jpk 890 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) & 891 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & 892 & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) 893 END DO 894 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 895 896 DO_2D( 1, 1, 1, 1 ) 897 IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN 898 CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' ) 899 ENDIF 900 END_2D 901 ! 902 ELSE 903 ! 904 ! Just to read set ssh in fact, called latter once vertical grid 905 ! is set up: 906 ! CALL usr_def_istate( gdept_0, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) ) 907 ! ! 908 ! DO jk=1,jpk 909 ! e3t(:,:,jk,Kbb) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb) ) & 910 ! & / ( ht_0(:,:) + 1._wp -ssmask(:,:) ) * tmask(:,:,jk) 911 ! END DO 912 ! e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 913 ssh(:,:,Kmm)=0._wp 914 e3t(:,:,:,Kmm)=e3t_0(:,:,:) 915 e3t(:,:,:,Kbb)=e3t_0(:,:,:) 916 ! 917 END IF ! end of ll_wd edits 918 859 DO jk = 1, jpk 860 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( 1._wp + ssh(:,:,Kmm) * r1_ht_0(:,:) * tmask(:,:,jk) ) 861 END DO 862 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 863 ! 919 864 IF( ln_vvl_ztilde .OR. ln_vvl_layer) THEN 920 865 tilde_e3t_b(:,:,:) = 0._wp 921 866 tilde_e3t_n(:,:,:) = 0._wp 922 867 IF( ln_vvl_ztilde ) hdiv_lf(:,:,:) = 0._wp 923 END 868 ENDIF 924 869 ENDIF 925 ! 926 ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file 927 ! ! =================== 870 ! !=======================! 871 ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file ! 872 ! !=======================! 873 ! 928 874 IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 929 875 ! ! --------- ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/domzgr_substitute.h90
r13237 r14058 15 15 # define e3u(i,j,k,t) (e3u_0(i,j,k)*(1._wp+r3u(i,j,t)*umask(i,j,k))) 16 16 # define e3v(i,j,k,t) (e3v_0(i,j,k)*(1._wp+r3v(i,j,t)*vmask(i,j,k))) 17 # define e3f(i,j,k) (e3f_0(i,j,k)*(1._wp+r3f(i,j)*fmask(i,j,k))) 17 # define e3f(i,j,k) (e3f_0(i,j,k)*(1._wp+r3f(i,j)*fe3mask(i,j,k))) 18 # define e3f_vor(i,j,k) (e3f_0vor(i,j,k)*(1._wp+r3f(i,j)*fe3mask(i,j,k))) 18 19 # define e3w(i,j,k,t) (e3w_0(i,j,k)*(1._wp+r3t(i,j,t))) 19 20 # define e3uw(i,j,k,t) (e3uw_0(i,j,k)*(1._wp+r3u(i,j,t))) 20 21 # define e3vw(i,j,k,t) (e3vw_0(i,j,k)*(1._wp+r3v(i,j,t))) 21 # define ht(i,j) (ht_0(i,j) +ssh(i,j,Kmm))22 # define ht(i,j) (ht_0(i,j)*(1._wp+r3t(i,j,Kmm))) 22 23 # define hu(i,j,t) (hu_0(i,j)*(1._wp+r3u(i,j,t))) 23 24 # define hv(i,j,t) (hv_0(i,j)*(1._wp+r3v(i,j,t))) … … 29 30 #endif 30 31 !!---------------------------------------------------------------------- 32 !!# define e3t_f(i,j,k) (e3t_0(i,j,k)*(1._wp+r3t_f(i,j)*tmask(i,j,k))) 33 !!# define e3u_f(i,j,k) (e3u_0(i,j,k)*(1._wp+r3u_f(i,j)*umask(i,j,k))) 34 !!# define e3v_f(i,j,k) (e3v_0(i,j,k)*(1._wp+r3v_f(i,j)*vmask(i,j,k))) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/istate.F90
r13295 r14058 42 42 PRIVATE 43 43 44 PUBLIC istate_init ! routine called by step.F9044 PUBLIC istate_init ! routine called by nemogcm.F90 45 45 46 46 !! * Substitutions … … 59 59 !! 60 60 !! ** Purpose : Initialization of the dynamics and tracer fields. 61 !! 62 !! ** Method : 61 63 !!---------------------------------------------------------------------- 62 64 INTEGER, INTENT( in ) :: Kbb, Kmm, Kaa ! ocean time level indices 63 65 ! 64 66 INTEGER :: ji, jj, jk ! dummy loop indices 65 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgdept ! 3D table !!st patch to use gdept subtitute67 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zgdept ! 3D table for qco substitute 66 68 !!gm see comment further down 67 69 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zuvd ! U & V data workspace … … 73 75 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 74 76 75 !!gm Why not include in the first call of dta_tsd ?76 !!gm probably associated with the use of internal damping...77 77 CALL dta_tsd_init ! Initialisation of T & S input data 78 !!gm to be moved in usrdef of C1D case 78 79 79 ! IF( lk_c1d ) CALL dta_uvd_init ! Initialization of U & V input data 80 !!gm81 80 82 rhd (:,:,: ) = 0._wp ; rhop (:,:,: ) = 0._wp ! set one for all to 0 at level jpk83 rn2b (:,:,: ) = 0._wp ; rn2 (:,:,: ) = 0._wp ! set one for all to 0 at levels 1 and jpk84 ts (:,:,:,:,Kaa) = 0._wp ! set one for all to 0 at level jpk85 rab_b(:,:,:,: ) = 0._wp ; rab_n(:,:,:,:) = 0._wp ! set one for all to 0 at level jpk81 rhd (:,:,: ) = 0._wp ; rhop (:,:,: ) = 0._wp ! set one for all to 0 at level jpk 82 rn2b (:,:,: ) = 0._wp ; rn2 (:,:,: ) = 0._wp ! set one for all to 0 at levels 1 and jpk 83 ts (:,:,:,:,Kaa) = 0._wp ! set one for all to 0 at level jpk 84 rab_b(:,:,:,: ) = 0._wp ; rab_n(:,:,:,:) = 0._wp ! set one for all to 0 at level jpk 86 85 #if defined key_agrif 87 86 uu (:,:,: ,Kaa) = 0._wp ! used in agrif_oce_sponge at initialization … … 96 95 CALL agrif_istate( Kbb, Kmm, Kaa ) ! Interp from parent 97 96 ! 98 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) 99 ssh (:,:,Kmm) = ssh(:,:,Kbb) 100 uu (:,:,:,Kmm) = uu (:,:,:,Kbb) 101 vv (:,:,:,Kmm) = vv (:,:,:,Kbb) 97 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) 98 !!st 99 !!st need for a recent agrif version to be displaced toward ssh_init_rst with agrif_istate_ssh 100 ssh(:,:, Kmm) = ssh(:,: ,Kbb) 101 !!st end 102 uu (:,:,: ,Kmm) = uu (:,:,: ,Kbb) 103 vv (:,:,: ,Kmm) = vv (:,:,: ,Kbb) 102 104 ELSE 103 105 #endif … … 117 119 CALL dta_tsd( nit000, ts(:,:,:,:,Kbb) ) ! read 3D T and S data at nit000 118 120 ! 119 ssh(:,:,Kbb) = 0._wp ! set the ocean at rest 120 uu (:,:,:,Kbb) = 0._wp 121 vv (:,:,:,Kbb) = 0._wp 121 uu (:,:,:,Kbb) = 0._wp 122 vv (:,:,:,Kbb) = 0._wp 122 123 ! 123 IF( ll_wd ) THEN124 ssh(:,:,Kbb) = -ssh_ref ! Added in 30 here for bathy that adds 30 as Iterative test CEOD125 !126 ! Apply minimum wetdepth criterion127 !128 DO_2D( 1, 1, 1, 1 )129 IF( ht_0(ji,jj) + ssh(ji,jj,Kbb) < rn_wdmin1 ) THEN130 ssh(ji,jj,Kbb) = tmask(ji,jj,1)*( rn_wdmin1 - (ht_0(ji,jj)) )131 ENDIF132 END_2D133 ENDIF134 !135 124 ELSE ! user defined initial T and S 136 125 DO jk = 1, jpk 137 126 zgdept(:,:,jk) = gdept(:,:,jk,Kbb) 138 127 END DO 139 CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb) , ssh(:,:,Kbb) )128 CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb) ) 140 129 ENDIF 141 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones 142 ssh (:,:,Kmm) = ssh(:,:,Kbb) 143 uu (:,:,:,Kmm) = uu (:,:,:,Kbb) 144 vv (:,:,:,Kmm) = vv (:,:,:,Kbb) 145 146 !!gm POTENTIAL BUG : 147 !!gm ISSUE : if ssh(:,:,Kbb) /= 0 then, in non linear free surface, the e3._n, e3._b should be recomputed 148 !! as well as gdept_ and gdepw_.... !!!!! 149 !! ===>>>> probably a call to domvvl initialisation here.... 150 130 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones 131 uu (:,:,: ,Kmm) = uu (:,:,: ,Kbb) 132 vv (:,:,: ,Kmm) = vv (:,:,: ,Kbb) 151 133 152 134 ! 153 !!gm to be moved in usrdef of C1D case154 !IF ( ln_uvd_init .AND. lk_c1d ) THEN ! read 3D U and V data at nit000155 !ALLOCATE( zuvd(jpi,jpj,jpk,2) )156 ! CALL dta_uvd( nit000, zuvd )157 ! uu(:,:,:,Kbb) = zuvd(:,:,:,1); uu(:,:,:,Kmm) = uu(:,:,:,Kbb)158 ! vv(:,:,:,Kbb) = zuvd(:,:,:,2); vv(:,:,:,Kmm) = vv(:,:,:,Kbb)159 !DEALLOCATE( zuvd )160 !ENDIF135 !!gm ==>>> to be moved in usrdef_istate of C1D case 136 IF ( ln_uvd_init .AND. lk_c1d ) THEN ! read 3D U and V data at nit000 137 ALLOCATE( zuvd(jpi,jpj,jpk,2) ) 138 CALL dta_uvd( nit000, Kbb, zuvd ) 139 uu(:,:,:,Kbb) = zuvd(:,:,:,1) ; uu(:,:,:,Kmm) = uu(:,:,:,Kbb) 140 vv(:,:,:,Kbb) = zuvd(:,:,:,2) ; vv(:,:,:,Kmm) = vv(:,:,:,Kbb) 141 DEALLOCATE( zuvd ) 142 ENDIF 161 143 ! 162 !!gm This is to be changed !!!!163 ! ! - ML - ssh(:,:,Kmm) could be modified by istate_eel, so that initialization of e3t(:,:,:,Kbb) is done here164 ! IF( .NOT.ln_linssh ) THEN165 ! DO jk = 1, jpk166 ! e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm)167 ! END DO168 ! ENDIF169 !!gm170 144 ! 171 145 ENDIF -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/phycst.F90
r12489 r14058 66 66 REAL(wp), PUBLIC :: r1_rhos !: 1 / rhos 67 67 REAL(wp), PUBLIC :: r1_rcpi !: 1 / rcpi 68 68 69 !!---------------------------------------------------------------------- 69 70 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DYN/dynadv.F90
r12377 r14058 127 127 IF( ioptio /= 1 ) CALL ctl_stop( 'choose ONE and only ONE advection scheme' ) 128 128 IF( nn_dynkeg /= nkeg_C2 .AND. nn_dynkeg /= nkeg_HW ) CALL ctl_stop( 'KEG scheme wrong value of nn_dynkeg' ) 129 129 #if defined key_qcoTest_FluxForm 130 IF( ln_dynadv_vec ) THEN CALL ctl_stop( 'STOP', 'key_qcoTest_FluxForm requires flux form advection' ) 131 #endif 130 132 131 133 IF(lwp) THEN ! Print the choice -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DYN/dynatf_qco.F90
r13295 r14058 1 MODULE dynatf qco1 MODULE dynatf_qco 2 2 !!========================================================================= 3 !! *** MODULE dynatf qco ***3 !! *** MODULE dynatf_qco *** 4 4 !! Ocean dynamics: time filtering 5 5 !!========================================================================= … … 50 50 USE prtctl ! Print control 51 51 USE timing ! Timing 52 #if defined key_agrif53 USE agrif_oce_interp54 #endif55 52 56 53 IMPLICIT NONE … … 199 196 ! JC: Would be more clever to swap variables than to make a full vertical 200 197 ! integration 201 ! 198 ! CAUTION : calculation need to be done in the same way than see GM 202 199 uu_b(:,:,Kaa) = e3u(:,:,1,Kaa) * puu(:,:,1,Kaa) * umask(:,:,1) 203 uu_b(:,:,Kmm) = e3u(:,:,1,Kmm) * puu(:,:,1,Kmm) * umask(:,:,1)200 uu_b(:,:,Kmm) = (e3u_0(:,:,1) * ( 1._wp + r3u_f(:,:) * umask(:,:,1) )) * puu(:,:,1,Kmm) * umask(:,:,1) 204 201 vv_b(:,:,Kaa) = e3v(:,:,1,Kaa) * pvv(:,:,1,Kaa) * vmask(:,:,1) 205 vv_b(:,:,Kmm) = e3v(:,:,1,Kmm) * pvv(:,:,1,Kmm) * vmask(:,:,1)202 vv_b(:,:,Kmm) = (e3v_0(:,:,1) * ( 1._wp + r3v_f(:,:) * vmask(:,:,1))) * pvv(:,:,1,Kmm) * vmask(:,:,1) 206 203 DO jk = 2, jpkm1 207 204 uu_b(:,:,Kaa) = uu_b(:,:,Kaa) + e3u(:,:,jk,Kaa) * puu(:,:,jk,Kaa) * umask(:,:,jk) 208 uu_b(:,:,Kmm) = uu_b(:,:,Kmm) + e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk)205 uu_b(:,:,Kmm) = uu_b(:,:,Kmm) + (e3u_0(:,:,jk) * ( 1._wp + r3u_f(:,:) * umask(:,:,jk) )) * puu(:,:,jk,Kmm) * umask(:,:,jk) 209 206 vv_b(:,:,Kaa) = vv_b(:,:,Kaa) + e3v(:,:,jk,Kaa) * pvv(:,:,jk,Kaa) * vmask(:,:,jk) 210 vv_b(:,:,Kmm) = vv_b(:,:,Kmm) + e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk)207 vv_b(:,:,Kmm) = vv_b(:,:,Kmm) + (e3v_0(:,:,jk) * ( 1._wp + r3v_f(:,:) * vmask(:,:,jk) )) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) 211 208 END DO 212 209 uu_b(:,:,Kaa) = uu_b(:,:,Kaa) * r1_hu(:,:,Kaa) 213 210 vv_b(:,:,Kaa) = vv_b(:,:,Kaa) * r1_hv(:,:,Kaa) 214 uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * r1_hu(:,:,Kmm)215 vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * r1_hv(:,:,Kmm)211 uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * (r1_hu_0(:,:)/( 1._wp + r3u_f(:,:) )) 212 vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * (r1_hv_0(:,:)/( 1._wp + r3v_f(:,:) )) 216 213 ! 217 214 IF( .NOT.ln_dynspg_ts ) THEN ! output the barotropic currents … … 235 232 236 233 !!========================================================================= 237 END MODULE dynatf qco234 END MODULE dynatf_qco -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DYN/dynldf_lap_blp.F90
r13497 r14058 5 5 !!====================================================================== 6 6 !! History : 3.7 ! 2014-01 (G. Madec, S. Masson) Original code, re-entrant laplacian 7 !! 4.0 ! 2020-04 (A. Nasser, G. Madec) Add symmetric mixing tensor 7 8 !!---------------------------------------------------------------------- 8 9 … … 19 20 USE in_out_manager ! I/O manager 20 21 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 21 22 USE lib_mpp 23 22 24 IMPLICIT NONE 23 25 PRIVATE … … 47 49 !! 48 50 !! ** Action : - pu_rhs, pv_rhs increased by the harmonic operator applied on pu, pv. 51 !! 52 !! Reference : S.Griffies, R.Hallberg 2000 Mon.Wea.Rev., DOI:/ 49 53 !!---------------------------------------------------------------------- 50 54 INTEGER , INTENT(in ) :: kt ! ocean time-step index … … 57 61 REAL(wp) :: zsign ! local scalars 58 62 REAL(wp) :: zua, zva ! local scalars 59 REAL(wp), DIMENSION(jpi,jpj) :: zcur, zdiv 63 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zcur, zdiv 64 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zten, zshe ! tension (diagonal) and shearing (anti-diagonal) terms 60 65 !!---------------------------------------------------------------------- 61 66 ! … … 70 75 ENDIF 71 76 ! 72 ! ! =============== 73 DO jk = 1, jpkm1 ! Horizontal slab 74 ! ! =============== 75 DO_2D( 0, 1, 0, 1 ) 76 ! ! ahm * e3 * curl (computed from 1 to jpim1/jpjm1) 77 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 78 & * ( e2v(ji ,jj-1) * pv(ji ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk) & 79 & - e1u(ji-1,jj ) * pu(ji-1,jj ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk) ) 80 ! ! ahm * div (computed from 2 to jpi/jpj) 81 zdiv(ji,jj) = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb) & ! ahmt already * by tmask 82 & * ( 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) & 83 & + 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) ) 84 END_2D 77 SELECT CASE( nn_dynldf_typ ) 78 ! 79 CASE ( np_typ_rot ) !== Vorticity-Divergence operator ==! 85 80 ! 86 DO_2D( 0, 0, 0, 0 ) ! - curl( curl) + grad( div ) 87 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * ( & ! * by umask is mandatory for dyn_ldf_blp use 88 & - ( zcur(ji ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & 89 & + ( zdiv(ji+1,jj) - zdiv(ji,jj ) ) * r1_e1u(ji,jj) ) 81 ALLOCATE( zcur(jpi,jpj) , zdiv(jpi,jpj) ) 82 ! 83 DO jk = 1, jpkm1 ! Horizontal slab 84 ! 85 DO_2D( 0, 1, 0, 1 ) 86 ! ! ahm * e3 * curl (computed from 1 to jpim1/jpjm1) 87 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 88 & * ( e2v(ji ,jj-1) * pv(ji ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk) & 89 & - e1u(ji-1,jj ) * pu(ji-1,jj ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk) ) 90 ! ! ahm * div (computed from 2 to jpi/jpj) 91 zdiv(ji,jj) = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb) & ! ahmt already * by tmask 92 & * ( 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) & 93 & + 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) ) 94 END_2D 95 ! 96 DO_2D( 0, 0, 0, 0 ) ! - curl( curl) + grad( div ) 97 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * ( & ! * by umask is mandatory for dyn_ldf_blp use 98 & - ( zcur(ji ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & 99 & + ( zdiv(ji+1,jj) - zdiv(ji,jj ) ) * r1_e1u(ji,jj) ) 90 100 ! 91 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * vmask(ji,jj,jk) * ( & ! * by vmask is mandatory for dyn_ldf_blp use 92 & ( zcur(ji,jj ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm) & 93 & + ( zdiv(ji,jj+1) - zdiv(ji ,jj) ) * r1_e2v(ji,jj) ) 94 END_2D 95 ! ! =============== 96 END DO ! End of slab 97 ! ! =============== 101 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * vmask(ji,jj,jk) * ( & ! * by vmask is mandatory for dyn_ldf_blp use 102 & ( zcur(ji,jj ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm) & 103 & + ( zdiv(ji,jj+1) - zdiv(ji ,jj) ) * r1_e2v(ji,jj) ) 104 END_2D 105 ! 106 END DO ! End of slab 107 ! 108 DEALLOCATE( zcur , zdiv ) 109 ! 110 CASE ( np_typ_sym ) !== Symmetric operator ==! 111 ! 112 ALLOCATE( zten(jpi,jpj) , zshe(jpi,jpj) ) 113 ! 114 DO jk = 1, jpkm1 ! Horizontal slab 115 ! 116 DO_2D( 0, 1, 0, 1 ) 117 ! ! shearing stress component (F-point) NB : ahmf has already been multiplied by fmask 118 zshe(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) & 119 & * ( e1f(ji-1,jj-1) * r1_e2f(ji-1,jj-1) & 120 & * ( pu(ji-1,jj ,jk) * r1_e1u(ji-1,jj ) - pu(ji-1,jj-1,jk) * r1_e1u(ji-1,jj-1) ) & 121 & + e2f(ji-1,jj-1) * r1_e1f(ji-1,jj-1) & 122 & * ( pv(ji ,jj-1,jk) * r1_e2v(ji ,jj-1) - pv(ji-1,jj-1,jk) * r1_e2v(ji-1,jj-1) ) ) 123 ! ! tension stress component (T-point) NB : ahmt has already been multiplied by tmask 124 zten(ji,jj) = ahmt(ji,jj,jk) & 125 & * ( e2t(ji,jj) * r1_e1t(ji,jj) & 126 & * ( pu(ji,jj,jk) * r1_e2u(ji,jj) - pu(ji-1,jj,jk) * r1_e2u(ji-1,jj) ) & 127 & - e1t(ji,jj) * r1_e2t(ji,jj) & 128 & * ( pv(ji,jj,jk) * r1_e1v(ji,jj) - pv(ji,jj-1,jk) * r1_e1v(ji,jj-1) ) ) 129 END_2D 130 ! 131 DO_2D( 0, 0, 0, 0 ) 132 pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) & 133 & * ( ( zten(ji+1,jj ) * e2t(ji+1,jj )*e2t(ji+1,jj ) * e3t(ji+1,jj ,jk,Kmm) & 134 & - zten(ji ,jj ) * e2t(ji ,jj )*e2t(ji ,jj ) * e3t(ji ,jj ,jk,Kmm) ) * r1_e2u(ji,jj) & 135 & + ( zshe(ji ,jj ) * e1f(ji ,jj )*e1f(ji ,jj ) * e3f(ji ,jj ,jk) & 136 & - zshe(ji ,jj-1) * e1f(ji ,jj-1)*e1f(ji ,jj-1) * e3f(ji ,jj-1,jk) ) * r1_e1u(ji,jj) ) 137 ! 138 pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) & 139 & * ( ( zshe(ji ,jj ) * e2f(ji ,jj )*e2f(ji ,jj ) * e3f(ji ,jj ,jk) & 140 & - zshe(ji-1,jj ) * e2f(ji-1,jj )*e2f(ji-1,jj ) * e3f(ji-1,jj ,jk) ) * r1_e2v(ji,jj) & 141 & - ( zten(ji ,jj+1) * e1t(ji ,jj+1)*e1t(ji ,jj+1) * e3t(ji ,jj+1,jk,Kmm) & 142 & - zten(ji ,jj ) * e1t(ji ,jj )*e1t(ji ,jj ) * e3t(ji ,jj ,jk,Kmm) ) * r1_e1v(ji,jj) ) 143 ! 144 END_2D 145 ! 146 END DO 147 ! 148 DEALLOCATE( zten , zshe ) 149 ! 150 END SELECT 98 151 ! 99 152 END SUBROUTINE dyn_ldf_lap -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DYN/dynspg_ts.F90
r14046 r14058 306 306 ENDIF 307 307 ! 308 ! != Add atmospheric pressureforcing =!309 ! ! ------------------ ----------------!310 IF( ln_bt_fw ) THEN ! Add wind forcing308 ! != Add wind forcing =! 309 ! ! ------------------ ! 310 IF( ln_bt_fw ) THEN 311 311 DO_2D( 0, 0, 0, 0 ) 312 312 zu_frc(ji,jj) = zu_frc(ji,jj) + r1_rho0 * utau(ji,jj) * r1_hu(ji,jj,Kmm) … … 386 386 ! 387 387 IF( ln_linssh ) THEN ! mid-step ocean depth is fixed (hup2_e=hu_n=hu_0) 388 zhup2_e(:,:) = hu (:,:,Kmm)389 zhvp2_e(:,:) = hv (:,:,Kmm)390 zhtp2_e(:,:) = ht (:,:)391 ENDIF 392 ! 393 IF (ln_bt_fw) THEN! FORWARD integration: start from NOW fields394 sshn_e(:,:) = pssh (:,:,Kmm)388 zhup2_e(:,:) = hu_0(:,:) 389 zhvp2_e(:,:) = hv_0(:,:) 390 zhtp2_e(:,:) = ht_0(:,:) 391 ENDIF 392 ! 393 IF( ln_bt_fw ) THEN ! FORWARD integration: start from NOW fields 394 sshn_e(:,:) = pssh (:,:,Kmm) 395 395 un_e (:,:) = puu_b(:,:,Kmm) 396 396 vn_e (:,:) = pvv_b(:,:,Kmm) … … 401 401 hvr_e (:,:) = r1_hv(:,:,Kmm) 402 402 ELSE ! CENTRED integration: start from BEFORE fields 403 sshn_e(:,:) = pssh (:,:,Kbb)403 sshn_e(:,:) = pssh (:,:,Kbb) 404 404 un_e (:,:) = puu_b(:,:,Kbb) 405 405 vn_e (:,:) = pvv_b(:,:,Kbb) … … 412 412 ! 413 413 ! Initialize sums: 414 puu_b 415 pvv_b 414 puu_b (:,:,Kaa) = 0._wp ! After barotropic velocities (or transport if flux form) 415 pvv_b (:,:,Kaa) = 0._wp 416 416 pssh (:,:,Kaa) = 0._wp ! Sum for after averaged sea level 417 un_adv(:,:) = 0._wp ! Sum for now transport issued from ts loop418 vn_adv(:,:) = 0._wp417 un_adv(:,:) = 0._wp ! Sum for now transport issued from ts loop 418 vn_adv(:,:) = 0._wp 419 419 ! 420 420 IF( ln_wd_dl ) THEN … … 475 475 ! 476 476 ! ! ocean u- and v-depth at mid-step (separate DO-loops remove the need of a lbc_lnk) 477 #if defined key_qcoTest_FluxForm 478 ! ! 'key_qcoTest_FluxForm' : simple ssh average 479 DO_2D( 1, 1, 1, 0 ) ! not jpi-column 480 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji+1,jj ) ) * ssumask(ji,jj) 481 END_2D 482 DO_2D( 1, 0, 1, 1 ) 483 zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji ,jj+1) ) * ssvmask(ji,jj) 484 END_2D 485 #else 486 ! ! no 'key_qcoTest_FluxForm' : surface weighted ssh average 477 487 DO_2D( 1, 1, 1, 0 ) ! not jpi-column 478 488 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj) & … … 485 495 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) 486 496 END_2D 497 #endif 487 498 ! 488 499 ENDIF … … 540 551 ! 541 552 ! Sea Surface Height at u-,v-points (vvl case only) 542 IF( .NOT.ln_linssh ) THEN 553 IF( .NOT.ln_linssh ) THEN 554 #if defined key_qcoTest_FluxForm 555 ! ! 'key_qcoTest_FluxForm' : simple ssh average 556 DO_2D( 1, 1, 1, 0 ) 557 zsshu_a(ji,jj) = r1_2 * ( ssha_e(ji,jj) + ssha_e(ji+1,jj ) ) * ssumask(ji,jj) 558 END_2D 559 DO_2D( 1, 0, 1, 1 ) 560 zsshv_a(ji,jj) = r1_2 * ( ssha_e(ji,jj) + ssha_e(ji ,jj+1) ) * ssvmask(ji,jj) 561 END_2D 562 #else 543 563 DO_2D( 0, 0, 0, 0 ) 544 zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) & 545 & * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & 546 & + e1e2t(ji+1,jj ) * ssha_e(ji+1,jj ) ) 547 zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj) & 548 & * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & 549 & + e1e2t(ji ,jj+1) * ssha_e(ji ,jj+1) ) 550 END_2D 551 ENDIF 564 zsshu_a(ji,jj) = r1_2 * r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & 565 & + e1e2t(ji+1,jj ) * ssha_e(ji+1,jj ) ) * ssumask(ji,jj) 566 zsshv_a(ji,jj) = r1_2 * r1_e1e2v(ji,jj) * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & 567 & + e1e2t(ji ,jj+1) * ssha_e(ji ,jj+1) ) * ssvmask(ji,jj) 568 END_2D 569 #endif 570 ENDIF 552 571 ! 553 572 ! Half-step back interpolation of SSH for surface pressure computation at step jit+1/2 … … 624 643 ! ! hu_e, hv_e hold depth at jn, zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 625 644 ! ! backward interpolated depth used in spg terms at jn+1/2 645 #if defined key_qcoTest_FluxForm 646 ! ! 'key_qcoTest_FluxForm' : simple ssh average 647 zhu_bck = hu_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji+1,jj ) ) * ssumask(ji,jj) 648 zhv_bck = hv_0(ji,jj) + r1_2 * ( zsshp2_e(ji,jj) + zsshp2_e(ji ,jj+1) ) * ssvmask(ji,jj) 649 #else 626 650 zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 627 651 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 628 652 zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & 629 653 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) 654 #endif 630 655 ! ! inverse depth at jn+1 631 656 z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) … … 646 671 IF ( ll_wd ) THEN ! revert to explicit for bit comparison tests in non wad runs 647 672 DO_2D( 0, 0, 0, 0 ) 648 ua_e(ji,jj) = ua_e(ji,jj) /(1.0 - rDt_e * zCdU_u(ji,jj) * hur_e(ji,jj))649 va_e(ji,jj) = va_e(ji,jj) /(1.0 - rDt_e * zCdU_v(ji,jj) * hvr_e(ji,jj))673 ua_e(ji,jj) = ua_e(ji,jj) / ( 1._wp - rDt_e * zCdU_u(ji,jj) * hur_e(ji,jj) ) 674 va_e(ji,jj) = va_e(ji,jj) / ( 1._wp - rDt_e * zCdU_v(ji,jj) * hvr_e(ji,jj) ) 650 675 END_2D 651 676 ENDIF 652 677 653 678 IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) 654 hu_e (2:jpim1,2:jpjm1) = hu_0(2:jpim1,2:jpjm1) + zsshu_a(2:jpim1,2:jpjm1)655 hur_e(2:jpim1,2:jpjm1) = ssumask(2:jpim1,2:jpjm1) / ( hu_e(2:jpim1,2:jpjm1) + 1._wp - ssumask(2:jpim1,2:jpjm1))656 hv_e (2:jpim1,2:jpjm1) = hv_0(2:jpim1,2:jpjm1) + zsshv_a(2:jpim1,2:jpjm1)657 hvr_e(2:jpim1,2:jpjm1) = ssvmask(2:jpim1,2:jpjm1) / ( hv_e(2:jpim1,2:jpjm1) + 1._wp - ssvmask(2:jpim1,2:jpjm1))679 hu_e (2:jpim1,2:jpjm1) = hu_0(2:jpim1,2:jpjm1) + zsshu_a(2:jpim1,2:jpjm1) 680 hur_e(2:jpim1,2:jpjm1) = ssumask(2:jpim1,2:jpjm1) / ( hu_e(2:jpim1,2:jpjm1) + 1._wp - ssumask(2:jpim1,2:jpjm1) ) 681 hv_e (2:jpim1,2:jpjm1) = hv_0(2:jpim1,2:jpjm1) + zsshv_a(2:jpim1,2:jpjm1) 682 hvr_e(2:jpim1,2:jpjm1) = ssvmask(2:jpim1,2:jpjm1) / ( hv_e(2:jpim1,2:jpjm1) + 1._wp - ssvmask(2:jpim1,2:jpjm1) ) 658 683 ENDIF 659 684 ! … … 743 768 ELSE 744 769 ! At this stage, pssh(:,:,:,Krhs) has been corrected: compute new depths at velocity points 770 #if defined key_qcoTest_FluxForm 771 ! ! 'key_qcoTest_FluxForm' : simple ssh average 745 772 DO_2D( 1, 0, 1, 0 ) 746 zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) & 747 & * ( e1e2t(ji ,jj) * pssh(ji ,jj,Kaa) & 748 & + e1e2t(ji+1,jj) * pssh(ji+1,jj,Kaa) ) 749 zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj) & 750 & * ( e1e2t(ji,jj ) * pssh(ji,jj ,Kaa) & 751 & + e1e2t(ji,jj+1) * pssh(ji,jj+1,Kaa) ) 752 END_2D 773 zsshu_a(ji,jj) = r1_2 * ( pssh(ji,jj,Kaa) + pssh(ji+1,jj ,Kaa) ) * ssumask(ji,jj) 774 zsshv_a(ji,jj) = r1_2 * ( pssh(ji,jj,Kaa) + pssh(ji ,jj+1,Kaa) ) * ssvmask(ji,jj) 775 END_2D 776 #else 777 DO_2D( 1, 0, 1, 0 ) 778 zsshu_a(ji,jj) = r1_2 * r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj) * pssh(ji ,jj,Kaa) & 779 & + e1e2t(ji+1,jj) * pssh(ji+1,jj,Kaa) ) * ssumask(ji,jj) 780 zsshv_a(ji,jj) = r1_2 * r1_e1e2v(ji,jj) * ( e1e2t(ji,jj ) * pssh(ji,jj ,Kaa) & 781 & + e1e2t(ji,jj+1) * pssh(ji,jj+1,Kaa) ) * ssvmask(ji,jj) 782 END_2D 783 #endif 753 784 CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 754 785 ! 755 786 DO jk=1,jpkm1 756 puu(:,:,jk,Krhs) = puu(:,:,jk,Krhs) + r1_hu(:,:,Kmm) * ( puu_b(:,:,Kaa) - puu_b(:,:,Kbb) * hu(:,:,Kbb) ) * r1_Dt_b 757 pvv(:,:,jk,Krhs) = pvv(:,:,jk,Krhs) + r1_hv(:,:,Kmm) * ( pvv_b(:,:,Kaa) - pvv_b(:,:,Kbb) * hv(:,:,Kbb) ) * r1_Dt_b 787 puu(:,:,jk,Krhs) = puu(:,:,jk,Krhs) + r1_hu(:,:,Kmm) & 788 & * ( puu_b(:,:,Kaa) - puu_b(:,:,Kbb) * hu(:,:,Kbb) ) * r1_Dt_b 789 pvv(:,:,jk,Krhs) = pvv(:,:,jk,Krhs) + r1_hv(:,:,Kmm) & 790 & * ( pvv_b(:,:,Kaa) - pvv_b(:,:,Kbb) * hv(:,:,Kbb) ) * r1_Dt_b 758 791 END DO 759 792 ! Save barotropic velocities not transport: … … 899 932 IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise 900 933 ! ! --------------- 901 IF( ln_rstart .AND. ln_bt_fw .AND. (.NOT.l_1st_euler)) THEN !* Read the restart file934 IF( ln_rstart .AND. ln_bt_fw .AND. .NOT.l_1st_euler ) THEN !* Read the restart file 902 935 CALL iom_get( numror, jpdom_auto, 'ub2_b' , ub2_b (:,:), cd_type = 'U', psgn = -1._wp ) 903 936 CALL iom_get( numror, jpdom_auto, 'vb2_b' , vb2_b (:,:), cd_type = 'V', psgn = -1._wp ) … … 1060 1093 !! although they should be updated in the variable volume case. Not a big approximation. 1061 1094 !! To remove this approximation, copy lines below inside barotropic loop 1062 !! and update depths at T- F points (ht and zhf resp.) at each barotropic time step1095 !! and update depths at T- points (ht) at each barotropic time step 1063 1096 !! 1064 1097 !! Compute zwz = f / ( height of the water colomn ) … … 1067 1100 INTEGER :: ji ,jj, jk ! dummy loop indices 1068 1101 REAL(wp) :: z1_ht 1069 REAL(wp), DIMENSION(jpi,jpj) :: zhf1070 1102 !!---------------------------------------------------------------------- 1071 1103 ! 1072 1104 SELECT CASE( nvor_scheme ) 1073 CASE( np_EEN ) != EEN scheme using e3f energy & enstrophy scheme1074 SELECT CASE( nn_e en_e3f )!* ff_f/e3 at F-point1105 CASE( np_EEN, np_ENE, np_ENS , np_MIX ) != schemes using the same e3f definition 1106 SELECT CASE( nn_e3f_typ ) !* ff_f/e3 at F-point 1075 1107 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 1076 DO_2D( 1, 0, 1, 0 )1077 zwz(ji,jj) = ( ht(ji ,jj+1) + ht(ji+1,jj+1) +&1078 & ht(ji ,jj ) + ht(ji+1,jj )) * 0.25_wp1108 DO_2D( 0, 0, 0, 0 ) 1109 zwz(ji,jj) = ( ht(ji,jj+1) + ht(ji+1,jj+1) & 1110 & + ht(ji,jj ) + ht(ji+1,jj ) ) * 0.25_wp 1079 1111 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 1080 1112 END_2D 1081 1113 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) 1082 DO_2D( 1, 0, 1, 0 )1083 zwz(ji,jj) = ( ht (ji ,jj+1) + ht(ji+1,jj+1) &1084 & + ht (ji ,jj ) + ht(ji+1,jj ) ) &1085 & / ( MAX( 1._wp, ssmask(ji,jj+1) + ssmask(ji+1,jj+1) &1086 & + ssmask(ji ,jj ) + ssmask(ji+1,jj )) )1114 DO_2D( 0, 0, 0, 0 ) 1115 zwz(ji,jj) = ( ht(ji,jj+1) + ht(ji+1,jj+1) & 1116 & + ht(ji,jj ) + ht(ji+1,jj ) ) & 1117 & / ( MAX(ssmask(ji,jj+1) + ssmask(ji+1,jj+1) & 1118 & + ssmask(ji,jj ) + ssmask(ji+1,jj ) , 1._wp ) ) 1087 1119 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 1088 1120 END_2D 1089 1121 END SELECT 1090 1122 CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) 1091 ! 1092 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 1123 END SELECT 1124 ! 1125 SELECT CASE( nvor_scheme ) 1126 CASE( np_EEN ) 1127 ! 1128 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 1093 1129 DO_2D( 0, 1, 0, 1 ) 1094 1130 ftne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1) … … 1098 1134 END_2D 1099 1135 ! 1100 CASE( np_EET ) != EEN scheme using e3t energy conserving scheme1101 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ;ftsw(1,:) = 0._wp1136 CASE( np_EET ) != EEN scheme using e3t energy conserving scheme 1137 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 1102 1138 DO_2D( 0, 1, 0, 1 ) 1103 1139 z1_ht = ssmask(ji,jj) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) ) … … 1108 1144 END_2D 1109 1145 ! 1110 CASE( np_ENE, np_ENS , np_MIX ) != all other schemes (ENE, ENS, MIX) except ENT !1111 !1112 zwz(:,:) = 0._wp1113 zhf(:,:) = 0._wp1114 1115 !!gm assume 0 in both cases (which is almost surely WRONG ! ) as hvatf has been removed1116 !!gm A priori a better value should be something like :1117 !!gm zhf(i,j) = masked sum of ht(i,j) , ht(i+1,j) , ht(i,j+1) , (i+1,j+1)1118 !!gm divided by the sum of the corresponding mask1119 !!gm1120 !!1121 IF( .NOT.ln_sco ) THEN1122 1123 !!gm agree the JC comment : this should be done in a much clear way1124 1125 ! JC: It not clear yet what should be the depth at f-points over land in z-coordinate case1126 ! Set it to zero for the time being1127 ! IF( rn_hmin < 0._wp ) THEN ; jk = - INT( rn_hmin ) ! from a nb of level1128 ! ELSE ; jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 ) ! from a depth1129 ! ENDIF1130 ! zhf(:,:) = gdepw_0(:,:,jk+1)1131 !1132 ELSE1133 !1134 !zhf(:,:) = hbatf(:,:)1135 DO_2D( 1, 0, 1, 0 )1136 zhf(ji,jj) = ( ht_0 (ji,jj ) + ht_0 (ji+1,jj ) &1137 & + ht_0 (ji,jj+1) + ht_0 (ji+1,jj+1) ) &1138 & / MAX( ssmask(ji,jj ) + ssmask(ji+1,jj ) &1139 & + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp )1140 END_2D1141 ENDIF1142 !1143 DO jj = 1, jpjm11144 zhf(:,jj) = zhf(:,jj) * (1._wp- umask(:,jj,1) * umask(:,jj+1,1))1145 END DO1146 !1147 DO jk = 1, jpkm11148 DO jj = 1, jpjm11149 zhf(:,jj) = zhf(:,jj) + e3f(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk)1150 END DO1151 END DO1152 CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp )1153 ! JC: TBC. hf should be greater than 01154 DO_2D( 1, 1, 1, 1 )1155 IF( zhf(ji,jj) /= 0._wp ) zwz(ji,jj) = 1._wp / zhf(ji,jj)1156 END_2D1157 zwz(:,:) = ff_f(:,:) * zwz(:,:)1158 1146 END SELECT 1159 1147 1160 1148 END SUBROUTINE dyn_cor_2d_init 1161 1162 1149 1163 1150 … … 1353 1340 END SUBROUTINE wad_spg 1354 1341 1355 1356 1342 1357 1343 SUBROUTINE dyn_drg_init( Kbb, Kmm, puu, pvv, puu_b ,pvv_b, pu_RHSi, pv_RHSi, pCdU_u, pCdU_v ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DYN/dynvor.F90
r14046 r14058 21 21 !! - ! 2018-03 (G. Madec) add two new schemes (ln_dynvor_enT and ln_dynvor_eet) 22 22 !! - ! 2018-04 (G. Madec) add pre-computed gradient for metric term calculation 23 !! 4.x ! 2020-03 (G. Madec, A. Nasser) make ln_dynvor_msk truly efficient on relative vorticity 23 24 !! 4.2 ! 2020-12 (G. Madec, E. Clementi) add vortex force trends (ln_vortex_force=T) 24 25 !!---------------------------------------------------------------------- … … 26 27 !!---------------------------------------------------------------------- 27 28 !! dyn_vor : Update the momentum trend with the vorticity trend 29 !! vor_enT : energy conserving scheme at T-pt (ln_dynvor_enT=T) 30 !! vor_ene : energy conserving scheme (ln_dynvor_ene=T) 28 31 !! vor_ens : enstrophy conserving scheme (ln_dynvor_ens=T) 29 !! vor_ene : energy conserving scheme (ln_dynvor_ene=T)30 32 !! vor_een : energy and enstrophy conserving (ln_dynvor_een=T) 33 !! vor_eeT : energy conserving at T-pt (ln_dynvor_eeT=T) 31 34 !! dyn_vor_init : set and control of the different vorticity option 32 35 !!---------------------------------------------------------------------- … … 58 61 LOGICAL, PUBLIC :: ln_dynvor_eeT !: t-point energy conserving scheme (EET) 59 62 LOGICAL, PUBLIC :: ln_dynvor_een !: energy & enstrophy conserving scheme (EEN) 60 INTEGER, PUBLIC :: nn_een_e3f !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)61 63 LOGICAL, PUBLIC :: ln_dynvor_mix !: mixed scheme (MIX) 62 64 LOGICAL, PUBLIC :: ln_dynvor_msk !: vorticity multiplied by fmask (=T) or not (=F) (all vorticity schemes) 65 INTEGER, PUBLIC :: nn_e3f_typ !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 63 66 64 67 INTEGER, PUBLIC :: nvor_scheme !: choice of the type of advection scheme … … 81 84 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2u_2 ! = di(e2u)/2 used in T-point metric term calculation 82 85 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1v_2 ! = dj(e1v)/2 - - - - 83 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2v_2e1e2f ! = di(e2v)/(2*e1e2f) used in F-point metric term calculation 84 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1u)/(2*e1e2f) - - - - 86 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: di_e2v_2e1e2f ! = di(e2u)/(2*e1e2f) used in F-point metric term calculation 87 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: dj_e1u_2e1e2f ! = dj(e1v)/(2*e1e2f) - - - - 88 ! 89 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: e3f_0vor ! e3f used in EEN, ENE and ENS cases (key_qco only) 85 90 86 91 REAL(wp) :: r1_4 = 0.250_wp ! =1/4 … … 235 240 INTEGER :: ji, jj, jk ! dummy loop indices 236 241 REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars 237 REAL(wp), DIMENSION(jpi,jpj) 238 REAL(wp), DIMENSION(jpi,jpj,jpkm1) :: zwz! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined242 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwt ! 2D workspace 243 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwz ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined 239 244 !!---------------------------------------------------------------------- 240 245 ! … … 246 251 ! 247 252 ! 248 SELECT CASE( kvor ) !== volume weighted vorticity considered ==! 249 CASE ( np_RVO ) !* relative vorticity 250 DO jk = 1, jpkm1 ! Horizontal slab 253 SELECT CASE( kvor ) !== relative vorticity considered ==! 254 ! 255 CASE ( np_RVO , np_CRV ) !* relative vorticity at f-point is used 256 ALLOCATE( zwz(jpi,jpj,jpk) ) 257 DO jk = 1, jpkm1 ! Horizontal slab 251 258 DO_2D( 1, 0, 1, 0 ) 252 259 zwz(ji,jj,jk) = ( e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) & 253 260 & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) 254 261 END_2D 255 IF( ln_dynvor_msk ) THEN ! mask /unmaskrelative vorticity262 IF( ln_dynvor_msk ) THEN ! mask relative vorticity 256 263 DO_2D( 1, 0, 1, 0 ) 257 264 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) … … 259 266 ENDIF 260 267 END DO 261 262 268 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 263 264 CASE ( np_CRV ) !* Coriolis + relative vorticity 265 DO jk = 1, jpkm1 ! Horizontal slab 266 DO_2D( 1, 0, 1, 0 ) ! relative vorticity 267 zwz(ji,jj,jk) = ( e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk) & 268 & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) 269 END_2D 270 IF( ln_dynvor_msk ) THEN ! mask/unmask relative vorticity 271 DO_2D( 1, 0, 1, 0 ) 272 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 273 END_2D 274 ENDIF 275 END DO 276 277 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 278 269 ! 279 270 END SELECT 280 271 281 272 ! ! =============== 282 273 DO jk = 1, jpkm1 ! Horizontal slab 283 !! ===============284 274 ! ! =============== 275 ! 285 276 SELECT CASE( kvor ) !== volume weighted vorticity considered ==! 277 ! 286 278 CASE ( np_COR ) !* Coriolis (planetary vorticity) 287 279 zwt(:,:) = ff_t(:,:) * e1e2t(:,:)*e3t(:,:,jk,Kmm) 288 280 CASE ( np_RVO ) !* relative vorticity 289 281 DO_2D( 0, 1, 0, 1 ) 290 zwt(ji,jj) = r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) &291 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) )&292 & 282 zwt(ji,jj) = r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) & 283 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) & 284 & * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 293 285 END_2D 294 286 CASE ( np_MET ) !* metric term 295 287 DO_2D( 0, 1, 0, 1 ) 296 zwt(ji,jj) = ( ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) &297 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) &298 & 288 zwt(ji,jj) = ( ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & 289 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) & 290 & * e3t(ji,jj,jk,Kmm) 299 291 END_2D 300 292 CASE ( np_CRV ) !* Coriolis + relative vorticity 301 293 DO_2D( 0, 1, 0, 1 ) 302 zwt(ji,jj) = ( ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) &303 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) ) &304 & 294 zwt(ji,jj) = ( ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj ,jk) + zwz(ji,jj ,jk) & 295 & + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) ) & 296 & * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 305 297 END_2D 306 298 CASE ( np_CME ) !* Coriolis + metric 307 299 DO_2D( 0, 1, 0, 1 ) 308 zwt(ji,jj) = ( ff_t(ji,jj) * e1e2t(ji,jj) &309 & + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) &310 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) &311 & 300 zwt(ji,jj) = ( ff_t(ji,jj) * e1e2t(ji,jj) & 301 & + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj) & 302 & - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj) ) & 303 & * e3t(ji,jj,jk,Kmm) 312 304 END_2D 313 305 CASE DEFAULT ! error 314 CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' 306 CALL ctl_stop('STOP','dyn_vor: wrong value for kvor') 315 307 END SELECT 316 308 ! … … 328 320 END DO ! End of slab 329 321 ! ! =============== 322 ! 323 SELECT CASE( kvor ) ! deallocate zwz if necessary 324 CASE ( np_RVO , np_CRV ) ; DEALLOCATE( zwz ) 325 END SELECT 326 ! 330 327 END SUBROUTINE vor_enT 331 328 … … 358 355 ! 359 356 INTEGER :: ji, jj, jk ! dummy loop indices 360 REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars357 REAL(wp) :: zx1, zy1, zx2, zy2, ze3f, zmsk ! local scalars 361 358 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwz ! 2D workspace 362 359 !!---------------------------------------------------------------------- … … 380 377 & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) 381 378 END_2D 379 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity 380 DO_2D( 1, 0, 1, 0 ) 381 zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 382 END_2D 383 ENDIF 382 384 CASE ( np_MET ) !* metric term 383 385 DO_2D( 1, 0, 1, 0 ) … … 390 392 & - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) 391 393 END_2D 394 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity (NOT the Coriolis term) 395 DO_2D( 1, 0, 1, 0 ) 396 zwz(ji,jj) = ( zwz(ji,jj) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) 397 END_2D 398 ENDIF 392 399 CASE ( np_CME ) !* Coriolis + metric 393 400 DO_2D( 1, 0, 1, 0 ) … … 399 406 END SELECT 400 407 ! 401 IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==! 402 DO_2D( 1, 0, 1, 0 ) 403 zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 404 END_2D 405 ENDIF 406 407 IF( ln_sco ) THEN 408 zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 409 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 410 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 411 ELSE 412 zwx(:,:) = e2u(:,:) * pu(:,:,jk) 413 zwy(:,:) = e1v(:,:) * pv(:,:,jk) 414 ENDIF 408 #if defined key_qco 409 DO_2D( 1, 0, 1, 0 ) !== potential vorticity ==! (key_qco) 410 zwz(ji,jj) = zwz(ji,jj) / e3f_vor(ji,jj,jk) 411 END_2D 412 #else 413 SELECT CASE( nn_e3f_typ ) !== potential vorticity ==! 414 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 415 DO_2D( 1, 0, 1, 0 ) 416 ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & 417 & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 418 & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & 419 & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 420 IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * 4._wp / ze3f 421 ELSE ; zwz(ji,jj) = 0._wp 422 ENDIF 423 END_2D 424 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) 425 DO_2D( 1, 0, 1, 0 ) 426 ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & 427 & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 428 & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & 429 & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 430 zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & 431 & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) ) 432 IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * zmsk / ze3f 433 ELSE ; zwz(ji,jj) = 0._wp 434 ENDIF 435 END_2D 436 END SELECT 437 #endif 438 ! !== horizontal fluxes ==! 439 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 440 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 441 ! 415 442 ! !== compute and add the vorticity term trend =! 416 443 DO_2D( 0, 0, 0, 0 ) … … 455 482 ! 456 483 INTEGER :: ji, jj, jk ! dummy loop indices 457 REAL(wp) :: zuav, zvau ! local scalars484 REAL(wp) :: zuav, zvau, ze3f, zmsk ! local scalars 458 485 REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwz, zww ! 2D workspace 459 486 !!---------------------------------------------------------------------- … … 476 503 & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) 477 504 END_2D 505 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity 506 DO_2D( 1, 0, 1, 0 ) 507 zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 508 END_2D 509 ENDIF 478 510 CASE ( np_MET ) !* metric term 479 511 DO_2D( 1, 0, 1, 0 ) … … 486 518 & - e1u(ji ,jj+1) * pu(ji ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj) 487 519 END_2D 520 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity (NOT the Coriolis term) 521 DO_2D( 1, 0, 1, 0 ) 522 zwz(ji,jj) = ( zwz(ji,jj) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) 523 END_2D 524 ENDIF 488 525 CASE ( np_CME ) !* Coriolis + metric 489 526 DO_2D( 1, 0, 1, 0 ) … … 495 532 END SELECT 496 533 ! 497 IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==! 498 DO_2D( 1, 0, 1, 0 ) 499 zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 500 END_2D 501 ENDIF 502 ! 503 IF( ln_sco ) THEN !== horizontal fluxes ==! 504 zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 505 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 506 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 507 ELSE 508 zwx(:,:) = e2u(:,:) * pu(:,:,jk) 509 zwy(:,:) = e1v(:,:) * pv(:,:,jk) 510 ENDIF 534 ! 535 #if defined key_qco 536 DO_2D( 1, 0, 1, 0 ) !== potential vorticity ==! (key_qco) 537 zwz(ji,jj) = zwz(ji,jj) / e3f_vor(ji,jj,jk) 538 END_2D 539 #else 540 SELECT CASE( nn_e3f_typ ) !== potential vorticity ==! 541 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 542 DO_2D( 1, 0, 1, 0 ) 543 ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & 544 & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 545 & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & 546 & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 547 IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * 4._wp / ze3f 548 ELSE ; zwz(ji,jj) = 0._wp 549 ENDIF 550 END_2D 551 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) 552 DO_2D( 1, 0, 1, 0 ) 553 ze3f = ( e3t(ji ,jj+1,jk,Kmm)*tmask(ji ,jj+1,jk) & 554 & + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk) & 555 & + e3t(ji ,jj ,jk,Kmm)*tmask(ji ,jj ,jk) & 556 & + e3t(ji+1,jj ,jk,Kmm)*tmask(ji+1,jj ,jk) ) 557 zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & 558 & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) ) 559 IF( ze3f /= 0._wp ) THEN ; zwz(ji,jj) = zwz(ji,jj) * zmsk / ze3f 560 ELSE ; zwz(ji,jj) = 0._wp 561 ENDIF 562 END_2D 563 END SELECT 564 #endif 565 ! !== horizontal fluxes ==! 566 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 567 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 568 ! 511 569 ! !== compute and add the vorticity term trend =! 512 570 DO_2D( 0, 0, 0, 0 ) … … 566 624 ! ! =============== 567 625 ! 568 SELECT CASE( nn_een_e3f ) ! == reciprocal of e3 at F-point 626 #if defined key_qco 627 DO_2D( 1, 0, 1, 0 ) ! == reciprocal of e3 at F-point (key_qco) 628 z1_e3f(ji,jj) = 1._wp / e3f_vor(ji,jj,jk) 629 END_2D 630 #else 631 SELECT CASE( nn_e3f_typ ) ! == reciprocal of e3 at F-point 569 632 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 570 633 DO_2D( 1, 0, 1, 0 ) … … 590 653 END_2D 591 654 END SELECT 655 #endif 592 656 ! 593 657 SELECT CASE( kvor ) !== vorticity considered ==! 658 ! 594 659 CASE ( np_COR ) !* Coriolis (planetary vorticity) 595 660 DO_2D( 1, 0, 1, 0 ) … … 601 666 & - e1u(ji ,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk) ) * r1_e1e2f(ji,jj)*z1_e3f(ji,jj) 602 667 END_2D 668 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity 669 DO_2D( 1, 0, 1, 0 ) 670 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 671 END_2D 672 ENDIF 603 673 CASE ( np_MET ) !* metric term 604 674 DO_2D( 1, 0, 1, 0 ) … … 612 682 & * r1_e1e2f(ji,jj) ) * z1_e3f(ji,jj) 613 683 END_2D 684 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity 685 DO_2D( 1, 0, 1, 0 ) 686 zwz(ji,jj,jk) = ( zwz(ji,jj,jk) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) 687 END_2D 688 ENDIF 614 689 CASE ( np_CME ) !* Coriolis + metric 615 690 DO_2D( 1, 0, 1, 0 ) … … 620 695 CALL ctl_stop('STOP','dyn_vor: wrong value for kvor' ) 621 696 END SELECT 622 ! 623 IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==! 624 DO_2D( 1, 0, 1, 0 ) 625 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 626 END_2D 627 ENDIF 697 ! ! =============== 628 698 END DO ! End of slab 629 ! 699 ! ! =============== 700 ! 630 701 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 631 702 ! 703 ! ! =============== 632 704 DO jk = 1, jpkm1 ! Horizontal slab 705 ! ! =============== 633 706 ! 634 707 ! !== horizontal fluxes ==! 635 708 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 636 709 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 637 710 ! 638 711 ! !== compute and add the vorticity term trend =! 639 jj = 2 640 ztne(1,:) = 0 ; ztnw(1,:) = 0 ; ztse(1,:) = 0 ; ztsw(1,:) = 0 641 DO ji = 2, jpi ! split in 2 parts due to vector opt. 642 ztne(ji,jj) = zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) 643 ztnw(ji,jj) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) 644 ztse(ji,jj) = zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) 645 ztsw(ji,jj) = zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) 646 END DO 647 DO jj = 3, jpj 648 DO ji = 2, jpi ! vector opt. ok because we start at jj = 3 649 ztne(ji,jj) = zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) 650 ztnw(ji,jj) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) 651 ztse(ji,jj) = zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) 652 ztsw(ji,jj) = zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) 653 END DO 654 END DO 712 DO_2D( 0, 1, 0, 1 ) 713 ztne(ji,jj) = zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) 714 ztnw(ji,jj) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) 715 ztse(ji,jj) = zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) 716 ztsw(ji,jj) = zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) 717 END_2D 718 ! 655 719 DO_2D( 0, 0, 0, 0 ) 656 720 zua = + r1_12 * r1_e1u(ji,jj) * ( ztne(ji,jj ) * zwy(ji ,jj ) + ztnw(ji+1,jj) * zwy(ji+1,jj ) & … … 667 731 668 732 669 670 733 SUBROUTINE vor_eeT( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) 671 734 !!---------------------------------------------------------------------- … … 685 748 !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 686 749 !!---------------------------------------------------------------------- 687 INTEGER , INTENT(in ) :: kt ! ocean time-step index750 INTEGER , INTENT(in ) :: kt ! ocean time-step index 688 751 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 689 INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric690 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities691 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs 752 INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric 753 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities 754 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu_rhs, pv_rhs ! total v-trend 692 755 ! 693 756 INTEGER :: ji, jj, jk ! dummy loop indices … … 702 765 IF( kt == nit000 ) THEN 703 766 IF(lwp) WRITE(numout,*) 704 IF(lwp) WRITE(numout,*) 'dyn:vor_ee n: vorticity term: energy and enstrophy conserving scheme'767 IF(lwp) WRITE(numout,*) 'dyn:vor_eeT : vorticity term: energy and enstrophy conserving scheme' 705 768 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 706 769 ENDIF … … 722 785 & * r1_e1e2f(ji,jj) 723 786 END_2D 787 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity 788 DO_2D( 1, 0, 1, 0 ) 789 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 790 END_2D 791 ENDIF 724 792 CASE ( np_MET ) !* metric term 725 793 DO_2D( 1, 0, 1, 0 ) … … 733 801 & * r1_e1e2f(ji,jj) ) 734 802 END_2D 803 IF( ln_dynvor_msk ) THEN ! mask the relative vorticity 804 DO_2D( 1, 0, 1, 0 ) 805 zwz(ji,jj,jk) = ( zwz(ji,jj,jk) - ff_f(ji,jj) ) * fmask(ji,jj,jk) + ff_f(ji,jj) 806 END_2D 807 ENDIF 735 808 CASE ( np_CME ) !* Coriolis + metric 736 809 DO_2D( 1, 0, 1, 0 ) … … 742 815 END SELECT 743 816 ! 744 IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==! 745 DO_2D( 1, 0, 1, 0 ) 746 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 747 END_2D 748 ENDIF 749 END DO 817 ! ! =============== 818 END DO ! End of slab 819 ! ! =============== 750 820 ! 751 821 CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 752 822 ! 823 ! ! =============== 753 824 DO jk = 1, jpkm1 ! Horizontal slab 754 755 ! !== horizontal fluxes ==! 825 ! ! =============== 826 ! 827 ! !== horizontal fluxes ==! 756 828 zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 757 829 zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 758 830 ! 759 831 ! !== compute and add the vorticity term trend =! 760 jj = 2 761 ztne(1,:) = 0 ; ztnw(1,:) = 0 ; ztse(1,:) = 0 ; ztsw(1,:) = 0 762 DO ji = 2, jpi ! split in 2 parts due to vector opt. 763 z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 764 ztne(ji,jj) = ( zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) ) * z1_e3t 765 ztnw(ji,jj) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) ) * z1_e3t 766 ztse(ji,jj) = ( zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) ) * z1_e3t 767 ztsw(ji,jj) = ( zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) ) * z1_e3t 768 END DO 769 DO jj = 3, jpj 770 DO ji = 2, jpi ! vector opt. ok because we start at jj = 3 771 z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 772 ztne(ji,jj) = ( zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) ) * z1_e3t 773 ztnw(ji,jj) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) ) * z1_e3t 774 ztse(ji,jj) = ( zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) ) * z1_e3t 775 ztsw(ji,jj) = ( zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) ) * z1_e3t 776 END DO 777 END DO 832 DO_2D( 0, 1, 0, 1 ) 833 z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 834 ztne(ji,jj) = ( zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) ) * z1_e3t 835 ztnw(ji,jj) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) + zwz(ji ,jj ,jk) ) * z1_e3t 836 ztse(ji,jj) = ( zwz(ji ,jj ,jk) + zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) ) * z1_e3t 837 ztsw(ji,jj) = ( zwz(ji ,jj-1,jk) + zwz(ji-1,jj-1,jk) + zwz(ji-1,jj ,jk) ) * z1_e3t 838 END_2D 839 ! 778 840 DO_2D( 0, 0, 0, 0 ) 779 841 zua = + r1_12 * r1_e1u(ji,jj) * ( ztne(ji,jj ) * zwy(ji ,jj ) + ztnw(ji+1,jj) * zwy(ji+1,jj ) & … … 799 861 INTEGER :: ji, jj, jk ! dummy loop indices 800 862 INTEGER :: ioptio, ios ! local integer 863 REAL(wp) :: zmsk ! local scalars 801 864 !! 802 865 NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_enT, ln_dynvor_eeT, & 803 & ln_dynvor_een, nn_e en_e3f, ln_dynvor_mix, ln_dynvor_msk866 & ln_dynvor_een, nn_e3f_typ , ln_dynvor_mix, ln_dynvor_msk 804 867 !!---------------------------------------------------------------------- 805 868 ! … … 823 886 WRITE(numout,*) ' energy conserving scheme (een using e3t) ln_dynvor_eeT = ', ln_dynvor_eeT 824 887 WRITE(numout,*) ' enstrophy and energy conserving scheme ln_dynvor_een = ', ln_dynvor_een 825 WRITE(numout,*) ' e3f = averaging /4 (=0) or /sum(tmask) (=1) nn_e en_e3f = ', nn_een_e3f888 WRITE(numout,*) ' e3f = averaging /4 (=0) or /sum(tmask) (=1) nn_e3f_typ = ', nn_e3f_typ 826 889 WRITE(numout,*) ' mixed enstrophy/energy conserving scheme ln_dynvor_mix = ', ln_dynvor_mix 827 890 WRITE(numout,*) ' masked (=T) or unmasked(=F) vorticity ln_dynvor_msk = ', ln_dynvor_msk 828 891 ENDIF 829 830 IF( ln_dynvor_msk ) CALL ctl_stop( 'dyn_vor_init: masked vorticity is not currently not available')831 892 832 893 !!gm this should be removed when choosing a unique strategy for fmask at the coast … … 891 952 ! 892 953 END SELECT 893 954 #if defined key_qco 955 SELECT CASE( nvor_scheme ) ! qco case: pre-computed a specific e3f_0 for some vorticity schemes 956 CASE( np_ENS , np_ENE , np_EEN , np_MIX ) 957 ! 958 ALLOCATE( e3f_0vor(jpi,jpj,jpk) ) 959 ! 960 SELECT CASE( nn_e3f_typ ) 961 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 962 DO_3D( 0, 0, 0, 0, 1, jpk ) 963 e3f_0vor(ji,jj,jk) = ( e3t_0(ji ,jj+1,jk)*tmask(ji ,jj+1,jk) & 964 & + e3t_0(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & 965 & + e3t_0(ji ,jj ,jk)*tmask(ji ,jj ,jk) & 966 & + e3t_0(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) * 0.25_wp 967 END_3D 968 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) 969 DO_3D( 0, 0, 0, 0, 1, jpk ) 970 zmsk = (tmask(ji,jj+1,jk) +tmask(ji+1,jj+1,jk) & 971 & + tmask(ji,jj ,jk) +tmask(ji+1,jj ,jk) ) 972 ! 973 IF( zmsk /= 0._wp ) THEN 974 e3f_0vor(ji,jj,jk) = ( e3t_0(ji ,jj+1,jk)*tmask(ji ,jj+1,jk) & 975 & + e3t_0(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & 976 & + e3t_0(ji ,jj ,jk)*tmask(ji ,jj ,jk) & 977 & + e3t_0(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) / zmsk 978 ENDIF 979 END_3D 980 END SELECT 981 ! 982 CALL lbc_lnk( 'dynvor', e3f_0vor, 'F', 1._wp ) 983 ! ! insure e3f_0vor /= 0 984 WHERE( e3f_0vor(:,:,:) == 0._wp ) e3f_0vor(:,:,:) = e3f_0(:,:,:) 985 ! 986 END SELECT 987 ! 988 #endif 894 989 IF(lwp) THEN ! Print the choice 895 990 WRITE(numout,*) … … 898 993 CASE( np_ENE ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (Coriolis at F-points) (ENE)' 899 994 CASE( np_ENT ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (Coriolis at T-points) (ENT)' 995 IF( ln_dynadv_vec ) CALL ctl_warn('dyn_vor_init: ENT scheme may not work in vector form') 900 996 CASE( np_EET ) ; WRITE(numout,*) ' ==>>> energy conserving scheme (EEN scheme using e3t) (EET)' 901 997 CASE( np_EEN ) ; WRITE(numout,*) ' ==>>> energy and enstrophy conserving scheme (EEN)' -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DYN/sshwzv.F90
r13497 r14058 6 6 !! History : 3.1 ! 2009-02 (G. Madec, M. Leclair) Original code 7 7 !! 3.3 ! 2010-04 (M. Leclair, G. Madec) modified LF-RA 8 !! - ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface 9 !! - ! 2010-09 (D.Storkey and E.O'Dea) bug fixes for BDY module 10 !! 3.3 ! 2011-10 (M. Leclair) split former ssh_wzv routine and remove all vvl related work 11 !! 4.0 ! 2018-12 (A. Coward) add mixed implicit/explicit advection 12 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) Rename ssh_nxt -> ssh_atf. Now only does time filtering. 8 !! - ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface 9 !! - ! 2010-09 (D.Storkey and E.O'Dea) bug fixes for BDY module 10 !! 3.3 ! 2011-10 (M. Leclair) split former ssh_wzv routine and remove all vvl related work 11 !! 4.0 ! 2018-12 (A. Coward) add mixed implicit/explicit advection 12 !! 4.1 ! 2019-08 (A. Coward, D. Storkey) Rename ssh_nxt -> ssh_atf. Now only does time filtering. 13 !! - ! 2020-08 (S. Techene, G. Madec) add here ssh initiatlisation 13 14 !!---------------------------------------------------------------------- 14 15 … … 17 18 !! ssh_atf : time filter the ssh arrays 18 19 !! wzv : compute now vertical velocity 20 !! ssh_init_rst : ssh set from restart or domcfg.nc file or usr_def_istat_ssh 19 21 !!---------------------------------------------------------------------- 20 22 USE oce ! ocean dynamics and tracers variables … … 40 42 USE timing ! Timing 41 43 USE wet_dry ! Wetting/Drying flux limiting 42 44 USE usrdef_istate, ONLY : usr_def_istate_ssh ! user defined ssh initial state 45 43 46 IMPLICIT NONE 44 47 PRIVATE 45 48 46 PUBLIC ssh_nxt ! called by step.F90 47 PUBLIC wzv ! called by step.F90 48 PUBLIC wAimp ! called by step.F90 49 PUBLIC ssh_atf ! called by step.F90 49 PUBLIC ssh_nxt ! called by step.F90 50 PUBLIC wzv ! called by step.F90 51 PUBLIC wAimp ! called by step.F90 52 PUBLIC ssh_atf ! called by step.F90 53 PUBLIC ssh_init_rst ! called by domain.F90 50 54 51 55 !! * Substitutions 52 56 # include "do_loop_substitute.h90" 53 57 # include "domzgr_substitute.h90" 54 55 58 !!---------------------------------------------------------------------- 56 59 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 299 302 ! ! filtered "now" field 300 303 pssh(:,:,Kmm) = pssh(:,:,Kmm) + rn_atfp * ( pssh(:,:,Kbb) - 2 * pssh(:,:,Kmm) + pssh(:,:,Kaa) ) 304 ! 301 305 IF( .NOT.ln_linssh ) THEN ! "now" <-- with forcing removed 302 306 zcoef = rn_atfp * rn_Dt * r1_rho0 … … 307 311 308 312 ! ice sheet coupling 309 IF ( ln_isf .AND. ln_isfcpl .AND. kt == nit000+1) pssh(:,:,Kbb) = pssh(:,:,Kbb) - rn_atfp * rn_Dt * ( risfcpl_ssh(:,:) - 0.0 ) * ssmask(:,:) 313 IF( ln_isf .AND. ln_isfcpl .AND. kt == nit000+1 ) & 314 & pssh(:,:,Kbb) = pssh(:,:,Kbb) - rn_atfp * rn_Dt * ( risfcpl_ssh(:,:) - 0.0 ) * ssmask(:,:) 310 315 311 316 ENDIF 312 317 ENDIF 313 318 ! 314 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pssh(:,:,Kmm), clinfo1=' pssh(:,:,Kmm) -: ', mask1=tmask )319 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=pssh(:,:,Kmm), clinfo1=' atf - pssh(:,:,Kmm): ', mask1=tmask ) 315 320 ! 316 321 IF( ln_timing ) CALL timing_stop('ssh_atf') … … 431 436 ! 432 437 END SUBROUTINE wAimp 438 439 440 SUBROUTINE ssh_init_rst( Kbb, Kmm, Kaa ) 441 !!--------------------------------------------------------------------- 442 !! *** ROUTINE ssh_init_rst *** 443 !! 444 !! ** Purpose : ssh initialization of the sea surface height (ssh) 445 !! 446 !! ** Method : set ssh from restart or read configuration, or user_def 447 !! * ln_rstart = T 448 !! USE of IOM library to read ssh in the restart file 449 !! Leap-Frog: Kbb and Kmm are read except for l_1st_euler=T 450 !! 451 !! * otherwise 452 !! call user defined ssh or 453 !! set to -ssh_ref in wet and drying case with domcfg.nc 454 !! 455 !! NB: ssh_b/n are written by restart.F90 456 !!---------------------------------------------------------------------- 457 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices 458 ! 459 INTEGER :: ji, jj, jk 460 !!---------------------------------------------------------------------- 461 ! 462 IF(lwp) THEN 463 WRITE(numout,*) 464 WRITE(numout,*) 'ssh_init_rst : ssh initialization' 465 WRITE(numout,*) '~~~~~~~~~~~~ ' 466 ENDIF 467 ! 468 ! !=============================! 469 IF( ln_rstart ) THEN !== Read the restart file ==! 470 ! !=============================! 471 ! 472 ! !* Read ssh at Kmm 473 IF(lwp) WRITE(numout,*) 474 IF(lwp) WRITE(numout,*) ' Kmm sea surface height read in the restart file' 475 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) ) 476 ! 477 IF( l_1st_euler ) THEN !* Euler at first time-step 478 IF(lwp) WRITE(numout,*) 479 IF(lwp) WRITE(numout,*) ' Euler first time step : ssh(Kbb) = ssh(Kmm)' 480 ssh(:,:,Kbb) = ssh(:,:,Kmm) 481 ! 482 ELSE !* read ssh at Kbb 483 IF(lwp) WRITE(numout,*) 484 IF(lwp) WRITE(numout,*) ' Kbb sea surface height read in the restart file' 485 CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb) ) 486 ENDIF 487 ! !============================! 488 ELSE !== Initialize at "rest" ==! 489 ! !============================! 490 ! 491 IF(lwp) WRITE(numout,*) 492 IF(lwp) WRITE(numout,*) ' initialization at rest' 493 ! 494 IF( ll_wd ) THEN !* wet and dry 495 ! 496 IF( ln_read_cfg ) THEN ! read configuration : ssh_ref is read in domain_cfg file 497 !!st why ssh is not masked : i.e. ssh(:,:,Kmm) = -ssh_ref*ssmask(:,:), 498 !!st since at the 1st time step lbclnk will be applied on ssh at Kaa but not initially at Kbb and Kmm 499 ssh(:,:,Kbb) = -ssh_ref 500 ! 501 DO_2D( 1, 1, 1, 1 ) 502 IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth 503 ssh(ji,jj,Kbb) = rn_wdmin1 - ht_0(ji,jj) 504 ENDIF 505 END_2D 506 ELSE ! user define configuration case 507 CALL usr_def_istate_ssh( tmask, ssh(:,:,Kbb) ) 508 ENDIF 509 ! 510 ELSE !* user defined configuration 511 CALL usr_def_istate_ssh( tmask, ssh(:,:,Kbb) ) 512 ! 513 ENDIF 514 ! 515 ssh(:,:,Kmm) = ssh(:,:,Kbb) !* set now values from to before ones 516 ssh(:,:,Kaa) = 0._wp 517 ENDIF 518 ! 519 END SUBROUTINE ssh_init_rst 520 433 521 !!====================================================================== 434 522 END MODULE sshwzv -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/IOM/iom.F90
r14047 r14058 174 174 CALL set_grid( "V", glamv, gphiv, .FALSE., .FALSE. ) 175 175 CALL set_grid( "W", glamt, gphit, .FALSE., .FALSE. ) 176 CALL set_grid( "F", glamf, gphif, .FALSE., .FALSE. ) 176 177 CALL set_grid_znl( gphit ) 177 178 ! … … 180 181 CALL iom_set_domain_attr("grid_U", area = real( e1e2u(Nis0:Nie0, Njs0:Nje0), dp)) 181 182 CALL iom_set_domain_attr("grid_V", area = real( e1e2v(Nis0:Nie0, Njs0:Nje0), dp)) 182 CALL iom_set_domain_attr("grid_W", area = real( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) 183 CALL iom_set_domain_attr("grid_W", area = REAL( e1e2t(Nis0:Nie0, Njs0:Nje0), dp)) 184 CALL iom_set_domain_attr("grid_F", area = real( e1e2f(Nis0:Nie0, Njs0:Nje0), dp)) 183 185 CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) 184 186 CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) 185 187 CALL set_grid_bounds( "V", glamu, gphiu, glamv, gphiv ) 186 188 CALL set_grid_bounds( "W", glamf, gphif, glamt, gphit ) 189 CALL set_grid_bounds( "F", glamt, gphit, glamf, gphif ) 187 190 ENDIF 188 191 ENDIF … … 191 194 CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 192 195 ! 193 CALL set_grid( "T", glamt_crs, gphit_crs, .FALSE., .FALSE. ) 194 CALL set_grid( "U", glamu_crs, gphiu_crs, .FALSE., .FALSE. ) 195 CALL set_grid( "V", glamv_crs, gphiv_crs, .FALSE., .FALSE. ) 196 CALL set_grid( "W", glamt_crs, gphit_crs, .FALSE., .FALSE. ) 196 CALL set_grid( "T", glamt_crs, gphit_crs, .FALSE., .FALSE. ) 197 CALL set_grid( "U", glamu_crs, gphiu_crs, .FALSE., .FALSE. ) 198 CALL set_grid( "V", glamv_crs, gphiv_crs, .FALSE., .FALSE. ) 199 CALL set_grid( "W", glamt_crs, gphit_crs, .FALSE., .FALSE. ) 197 200 CALL set_grid_znl( gphit_crs ) 198 201 ! … … 217 220 CALL iom_set_axis_attr( "depthv", paxis = gdept_1d ) 218 221 CALL iom_set_axis_attr( "depthw", paxis = gdepw_1d ) 222 CALL iom_set_axis_attr( "depthf", paxis = gdept_1d ) 219 223 220 224 ! ABL … … 238 242 CALL iom_set_axis_attr( "depthv", bounds=zw_bnds ) 239 243 CALL iom_set_axis_attr( "depthw", bounds=zt_bnds ) 244 CALL iom_set_axis_attr( "depthf", bounds=zw_bnds ) 240 245 241 246 ! ABL -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/IOM/restart.F90
r14046 r14058 11 11 !! 3.7 ! 2014-01 (G. Madec) suppression of curl and hdiv from the restart 12 12 !! - ! 2014-12 (G. Madec) remove KPP scheme 13 !! 4.1 ! 2020-11 (S. Techene, G. Madec) move ssh initiatlisation in DYN/sshwzv:ssh_init_rst 13 14 !!---------------------------------------------------------------------- 14 15 … … 139 140 !! ** Method : Write in numrow when kt == nitrst in NetCDF 140 141 !! file, save fields which are necessary for restart 142 !! 143 !! NB: ssh is written here (rst_write) 144 !! but is read or set in DYN/sshwzv:shh_init_rst 141 145 !!---------------------------------------------------------------------- 142 146 INTEGER, INTENT(in) :: kt ! ocean time-step … … 233 237 !! *** ROUTINE rst_read *** 234 238 !! 235 !! ** Purpose : Read files for NetCDF restart 236 !! 237 !! ** Method : Read in restart.nc file fields which are necessary for restart 239 !! ** Purpose : Read velocity and T-S fields in the restart file 240 !! 241 !! ** Method : Read in restart.nc fields which are necessary for restart 242 !! 243 !! NB: restart file openned in DOM/domain.F90:dom_init 244 !! before field in restart tested in DOM/domain.F90:dom_init 245 !! (sshb) 246 !! 247 !! NB: ssh is read or set in DYN/sshwzv:shh_init_rst 248 !! but is written in IOM/restart:rst_write 238 249 !!---------------------------------------------------------------------- 239 250 INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices 240 REAL(wp) :: zrdt241 251 INTEGER :: jk 242 252 REAL(wp), DIMENSION(jpi, jpj, jpk) :: w3d 243 253 !!---------------------------------------------------------------------- 244 245 CALL rst_read_open ! open restart for reading (if not already opened) 246 247 ! Check dynamics and tracer time-step consistency and force Euler restart if changed 248 IF( iom_varid( numror, 'rdt', ldstop = .FALSE. ) > 0 ) THEN 249 CALL iom_get( numror, 'rdt', zrdt ) 250 IF( zrdt /= rn_Dt ) THEN 251 IF(lwp) WRITE( numout,*) 252 IF(lwp) WRITE( numout,*) 'rst_read: rdt not equal to the read one' 253 IF(lwp) WRITE( numout,*) 254 IF(lwp) WRITE( numout,*) ' ==>>> forced euler first time-step' 255 l_1st_euler = .TRUE. 256 ENDIF 257 ENDIF 258 254 ! 259 255 IF(.NOT.lrxios ) CALL iom_delay_rst( 'READ', 'OCE', numror ) ! read only ocean delayed global communication variables 260 261 ! Diurnal DSST262 IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst )256 ! 257 ! !* Diurnal DSST 258 IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst ) 263 259 IF ( ln_diurnal_only ) THEN 264 260 IF(lwp) WRITE( numout, * ) & … … 269 265 RETURN 270 266 ENDIF 271 272 IF( iom_varid( numror, 'ub', ldstop = .FALSE. ) > 0 ) THEN 273 ! before fields 267 ! 268 ! !* Read Kmm fields 269 IF(lwp) WRITE(numout,*) ' Kmm u, v and T-S fields read in the restart file' 270 CALL iom_get( numror, jpdom_auto, 'un' , uu(:,:,: ,Kmm), cd_type = 'U', psgn = -1._wp ) 271 CALL iom_get( numror, jpdom_auto, 'vn' , vv(:,:,: ,Kmm), cd_type = 'V', psgn = -1._wp ) 272 CALL iom_get( numror, jpdom_auto, 'tn' , ts(:,:,:,jp_tem,Kmm) ) 273 CALL iom_get( numror, jpdom_auto, 'sn' , ts(:,:,:,jp_sal,Kmm) ) 274 ! 275 IF( l_1st_euler ) THEN !* Euler restart 276 IF(lwp) WRITE(numout,*) ' Kbb u, v and T-S fields set to Kmm values' 277 ts(:,:,:,:,Kbb) = ts(:,:,:,:,Kmm) ! all before fields set to now values 278 uu(:,:,: ,Kbb) = uu(:,:,: ,Kmm) 279 vv(:,:,: ,Kbb) = vv(:,:,: ,Kmm) 280 ELSE !* Leap frog restart 281 IF(lwp) WRITE(numout,*) ' Kbb u, v and T-S fields read in the restart file' 274 282 CALL iom_get( numror, jpdom_auto, 'ub' , uu(:,:,: ,Kbb), cd_type = 'U', psgn = -1._wp ) 275 283 CALL iom_get( numror, jpdom_auto, 'vb' , vv(:,:,: ,Kbb), cd_type = 'V', psgn = -1._wp ) 276 284 CALL iom_get( numror, jpdom_auto, 'tb' , ts(:,:,:,jp_tem,Kbb) ) 277 285 CALL iom_get( numror, jpdom_auto, 'sb' , ts(:,:,:,jp_sal,Kbb) ) 278 CALL iom_get( numror, jpdom_auto, 'sshb' ,ssh(:,: ,Kbb) ) 279 ELSE 280 l_1st_euler = .TRUE. ! before field not found, forced euler 1st time-step 281 ENDIF 282 ! 283 ! now fields 284 CALL iom_get( numror, jpdom_auto, 'un' , uu(:,:,: ,Kmm), cd_type = 'U', psgn = -1._wp ) 285 CALL iom_get( numror, jpdom_auto, 'vn' , vv(:,:,: ,Kmm), cd_type = 'V', psgn = -1._wp ) 286 CALL iom_get( numror, jpdom_auto, 'tn' , ts(:,:,:,jp_tem,Kmm) ) 287 CALL iom_get( numror, jpdom_auto, 'sn' , ts(:,:,:,jp_sal,Kmm) ) 288 CALL iom_get( numror, jpdom_auto, 'sshn' ,ssh(:,: ,Kmm) ) 286 ENDIF 287 ! 289 288 IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN 290 289 CALL iom_get( numror, jpdom_auto, 'rhop' , rhop ) ! now potential density … … 293 292 ENDIF 294 293 ! 295 IF( l_1st_euler ) THEN ! Euler restart296 ts (:,:,:,:,Kbb) = ts (:,:,:,:,Kmm) ! all before fields set to now values297 uu (:,:,: ,Kbb) = uu (:,:,: ,Kmm)298 vv (:,:,: ,Kbb) = vv (:,:,: ,Kmm)299 ssh (:,: ,Kbb) = ssh (:,: ,Kmm)300 ENDIF301 !302 294 END SUBROUTINE rst_read 303 295 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ISF/isfcpl.F90
r14046 r14058 10 10 11 11 !!---------------------------------------------------------------------- 12 !! isfrst : read/write iceshelf variables in/from restart12 !! isfrst : read/write iceshelf variables in/from restart 13 13 !!---------------------------------------------------------------------- 14 USE isf_oce ! ice shelf variable 14 USE oce ! ocean dynamics and tracers 15 #if defined key_qco 16 USE domqco , ONLY : dom_qco_zgr ! vertical scale factor interpolation 17 #else 18 USE domvvl , ONLY : dom_vvl_zgr ! vertical scale factor interpolation 19 #endif 20 USE domutl , ONLY : dom_ngb ! find the closest grid point from a given lon/lat position 21 USE isf_oce ! ice shelf variable 15 22 USE isfutils, ONLY : debug 16 USE lib_mpp , ONLY: mpp_sum, mpp_max ! mpp routine17 #if ! defined key_qco18 USE domvvl , ONLY: dom_vvl_zgr ! vertical scale factor interpolation19 #else20 USE domqco , ONLY: dom_qco_zgr ! vertical scale factor interpolation21 #endif22 USE domutl , ONLY: dom_ngb ! find the closest grid point from a given lon/lat position23 23 ! 24 USE oce ! ocean dynamics and tracers25 24 USE in_out_manager ! I/O manager 26 25 USE iom ! I/O library 26 USE lib_mpp , ONLY : mpp_sum, mpp_max ! mpp routine 27 27 ! 28 28 IMPLICIT NONE … … 34 34 35 35 TYPE isfcons 36 INTEGER :: ii ! i global37 INTEGER :: jj ! j global38 INTEGER :: kk ! k level39 REAL(wp):: dvol ! volume increment40 REAL(wp):: dsal ! salt increment41 REAL(wp):: dtem ! heat increment42 REAL(wp):: lon ! lon43 REAL(wp):: lat ! lat44 INTEGER :: ngb ! 0/1 (valid location or not (ie on halo or no neigbourg))36 INTEGER :: ii ! i global 37 INTEGER :: jj ! j global 38 INTEGER :: kk ! k level 39 REAL(wp):: dvol ! volume increment 40 REAL(wp):: dsal ! salt increment 41 REAL(wp):: dtem ! heat increment 42 REAL(wp):: lon ! lon 43 REAL(wp):: lat ! lat 44 INTEGER :: ngb ! 0/1 (valid location or not (ie on halo or no neigbourg)) 45 45 END TYPE 46 46 ! … … 121 121 #endif 122 122 END SUBROUTINE isfcpl_init 123 ! 124 SUBROUTINE isfcpl_rst_write(kt, Kmm) 123 124 125 SUBROUTINE isfcpl_rst_write( kt, Kmm ) 125 126 !!--------------------------------------------------------------------- 126 127 !! *** ROUTINE iscpl_rst_write *** … … 133 134 !!---------------------------------------------------------------------- 134 135 INTEGER :: jk ! loop index 135 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw ! e3t , e3u, e3v !!st patch to usesubstitution136 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t, ze3u, ze3v, zgdepw ! for qco substitution 136 137 !!---------------------------------------------------------------------- 137 138 ! … … 153 154 END SUBROUTINE isfcpl_rst_write 154 155 156 155 157 SUBROUTINE isfcpl_ssh(Kbb, Kmm, Kaa) 156 158 !!---------------------------------------------------------------------- … … 184 186 zdssmask(:,:) = ssmask(:,:) - zssmask0(:,:) 185 187 DO_2D( 0, 0, 0, 0 ) 186 jip1=ji+1 ; jim1=ji-1;187 jjp1=jj+1 ; jjm1=jj-1;188 jip1=ji+1 ; jim1=ji-1 189 jjp1=jj+1 ; jjm1=jj-1 188 190 ! 189 191 zsummsk = zssmask0(jip1,jj) + zssmask0(jim1,jj) + zssmask0(ji,jjp1) + zssmask0(ji,jjm1) … … 191 193 IF (zdssmask(ji,jj) == 1._wp .AND. zsummsk /= 0._wp) THEN 192 194 ssh(ji,jj,Kmm)=( zssh(jip1,jj)*zssmask0(jip1,jj) & 193 & + zssh(jim1,jj)*zssmask0(jim1,jj) &194 & + zssh(ji,jjp1)*zssmask0(ji,jjp1) &195 & + zssh(ji,jjm1)*zssmask0(ji,jjm1)) / zsummsk195 & + zssh(jim1,jj)*zssmask0(jim1,jj) & 196 & + zssh(ji,jjp1)*zssmask0(ji,jjp1) & 197 & + zssh(ji,jjm1)*zssmask0(ji,jjm1)) / zsummsk 196 198 zssmask_b(ji,jj) = 1._wp 197 199 ENDIF … … 222 224 CALL dom_vvl_zgr(Kbb, Kmm, Kaa) 223 225 #else 224 CALL dom_qco_zgr(Kbb, Kmm , Kaa)226 CALL dom_qco_zgr(Kbb, Kmm) 225 227 #endif 226 228 ! 227 229 END SUBROUTINE isfcpl_ssh 228 230 231 229 232 SUBROUTINE isfcpl_tra(Kmm) 230 233 !!---------------------------------------------------------------------- … … 375 378 ! 376 379 END SUBROUTINE isfcpl_tra 380 377 381 378 382 SUBROUTINE isfcpl_vol(Kmm) … … 466 470 risfcpl_ssh(:,:) = risfcpl_ssh(:,:) + risfcpl_vol(:,:,jk) * r1_e1e2t(:,:) 467 471 END DO 468 472 ! 469 473 END SUBROUTINE isfcpl_vol 470 474 475 471 476 SUBROUTINE isfcpl_cons(Kmm) 472 477 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ISF/isfdynatf.F90
r13237 r14058 15 15 USE phycst , ONLY: r1_rho0 ! physical constant 16 16 USE dom_oce ! time and space domain 17 USE oce, ONLY : ssh ! sea-surface height !!st needed forsubstitution17 USE oce, ONLY : ssh ! sea-surface height for qco substitution 18 18 19 19 USE in_out_manager -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ISF/isfrst.F90
r14046 r14058 28 28 !!---------------------------------------------------------------------- 29 29 CONTAINS 30 !31 SUBROUTINE isfrst_read( cdisf, ptsc, pfwf, ptsc_b, pfwf_b )30 31 SUBROUTINE isfrst_read( cdisf, ptsc, pfwf, ptsc_b, pfwf_b ) 32 32 !!--------------------------------------------------------------------- 33 33 !! … … 51 51 ! 52 52 ! read restart 53 IF( iom_varid( numror, cfwf_b, ldstop = .FALSE. ) > 0) THEN53 IF( .NOT.l_1st_euler ) THEN 54 54 IF(lwp) WRITE(numout,*) ' nit000-1 isf tracer content forcing fields read in the restart file' 55 55 CALL iom_get( numror, jpdom_auto, cfwf_b, pfwf_b(:,:) ) ! before ice shelf melt … … 62 62 ! 63 63 END SUBROUTINE isfrst_read 64 ! 65 SUBROUTINE isfrst_write(kt, cdisf, ptsc, pfwf ) 64 65 66 SUBROUTINE isfrst_write( kt, cdisf, ptsc, pfwf ) 66 67 !!--------------------------------------------------------------------- 67 68 !! … … 94 95 ! 95 96 END SUBROUTINE isfrst_write 96 ! 97 98 !!====================================================================== 97 99 END MODULE isfrst -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/LBC/mppini.F90
r14046 r14058 217 217 ! then we calculate them here now that we have our communicator size 218 218 IF(lwp) THEN 219 WRITE(numout,*) 219 220 WRITE(numout,*) 'mpp_init:' 220 221 WRITE(numout,*) '~~~~~~~~ ' 221 WRITE(numout,*)222 222 ENDIF 223 223 IF( jpni < 1 .OR. jpnj < 1 ) THEN -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/LDF/ldfdyn.F90
r13497 r14058 34 34 ! !!* Namelist namdyn_ldf : lateral mixing on momentum * 35 35 LOGICAL , PUBLIC :: ln_dynldf_OFF !: No operator (i.e. no explicit diffusion) 36 INTEGER , PUBLIC :: nn_dynldf_typ !: operator type (0: div-rot ; 1: symmetric) 36 37 LOGICAL , PUBLIC :: ln_dynldf_lap !: laplacian operator 37 38 LOGICAL , PUBLIC :: ln_dynldf_blp !: bilaplacian operator … … 52 53 53 54 ! !!* Parameter to control the type of lateral viscous operator 54 INTEGER, PARAMETER, PUBLIC :: np_ERROR =-10 !: error in setting the operator 55 INTEGER, PARAMETER, PUBLIC :: np_no_ldf = 00 !: without operator (i.e. no lateral viscous trend) 55 INTEGER, PARAMETER, PUBLIC :: np_ERROR =-10 !: error in setting the operator 56 INTEGER, PARAMETER, PUBLIC :: np_no_ldf = 00 !: without operator (i.e. no lateral viscous trend) 57 ! 58 INTEGER, PARAMETER, PUBLIC :: np_typ_rot = 0 !: div-rot operator 59 INTEGER, PARAMETER, PUBLIC :: np_typ_sym = 1 !: symmetric operator 60 ! 56 61 ! !! laplacian ! bilaplacian ! 57 62 INTEGER, PARAMETER, PUBLIC :: np_lap = 10 , np_blp = 20 !: iso-level operator … … 109 114 CHARACTER(len=5) :: cl_Units ! units (m2/s or m4/s) 110 115 !! 111 NAMELIST/namdyn_ldf/ ln_dynldf_OFF, ln_dynldf_lap, ln_dynldf_blp, & ! type of operator112 & ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso, & ! acting direction of the operator113 & nn_ahm_ijk_t , rn_Uv , rn_Lv, rn_ahm_b,& ! lateral eddy coefficient114 & rn_csmc , rn_minfac , rn_maxfac ! Smagorinsky settings116 NAMELIST/namdyn_ldf/ ln_dynldf_OFF, nn_dynldf_typ, ln_dynldf_lap, ln_dynldf_blp, & ! type of operator 117 & ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso, & ! acting direction of the operator 118 & nn_ahm_ijk_t , rn_Uv , rn_Lv , rn_ahm_b, & ! lateral eddy coefficient 119 & rn_csmc , rn_minfac , rn_maxfac ! Smagorinsky settings 115 120 !!---------------------------------------------------------------------- 116 121 ! … … 130 135 WRITE(numout,*) ' type :' 131 136 WRITE(numout,*) ' no explicit diffusion ln_dynldf_OFF = ', ln_dynldf_OFF 137 WRITE(numout,*) ' type of operator (div-rot or sym) nn_dynldf_typ = ', nn_dynldf_typ 132 138 WRITE(numout,*) ' laplacian operator ln_dynldf_lap = ', ln_dynldf_lap 133 139 WRITE(numout,*) ' bilaplacian operator ln_dynldf_blp = ', ln_dynldf_blp … … 147 153 WRITE(numout,*) ' Smagorinsky coefficient rn_csmc = ', rn_csmc 148 154 WRITE(numout,*) ' factor multiplier for eddy visc.' 149 WRITE(numout,*) ' lower limit (default 1.0) rn_minfac = ', rn_minfac150 WRITE(numout,*) ' upper limit (default 1.0) rn_maxfac = ', rn_maxfac155 WRITE(numout,*) ' lower limit (default 1.0) rn_minfac = ', rn_minfac 156 WRITE(numout,*) ' upper limit (default 1.0) rn_maxfac = ', rn_maxfac 151 157 ENDIF 152 158 … … 160 166 IF( ln_dynldf_lap ) THEN ; ioptio = ioptio + 1 ; ENDIF 161 167 IF( ln_dynldf_blp ) THEN ; ioptio = ioptio + 1 ; ENDIF 162 IF( ioptio /= 1 ) CALL ctl_stop( ' dyn_ldf_init: use ONE of the 3 operator options (NONE/lap/blp)' )168 IF( ioptio /= 1 ) CALL ctl_stop( 'ldf_dyn_init: use ONE of the 3 operator options (NONE/lap/blp)' ) 163 169 ! 164 170 IF(.NOT.ln_dynldf_OFF ) THEN !== direction ==>> type of operator ==! 171 ! 172 SELECT CASE( nn_dynldf_typ ) ! div-rot or symmetric 173 CASE( np_typ_rot ) ; IF(lwp) WRITE(numout,*) ' ==>>> use div-rot operator ' 174 CASE( np_typ_sym ) ; IF(lwp) WRITE(numout,*) ' ==>>> use symmetric operator ' 175 CASE DEFAULT ! error 176 CALL ctl_stop('ldf_dyn_init: wrong value for nn_dynldf_typ (0 or 1)' ) 177 END SELECT 178 ! 165 179 ioptio = 0 166 180 IF( ln_dynldf_lev ) ioptio = ioptio + 1 167 181 IF( ln_dynldf_hor ) ioptio = ioptio + 1 168 182 IF( ln_dynldf_iso ) ioptio = ioptio + 1 169 IF( ioptio /= 1 ) CALL ctl_stop( ' dyn_ldf_init: use ONE of the 3 direction options (level/hor/iso)' )183 IF( ioptio /= 1 ) CALL ctl_stop( 'ldf_dyn_init: use ONE of the 3 direction options (level/hor/iso)' ) 170 184 ! 171 185 ! ! Set nldf_dyn, the type of lateral diffusion, from ln_dynldf_... logicals -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/OBS/diaobs.F90
r13216 r14058 57 57 PUBLIC calc_date ! Compute the date of a timestep 58 58 59 LOGICAL, PUBLIC :: ln_diaobs !: Logical switch for the obs operator 60 LOGICAL :: ln_sstnight ! Logical switch for night mean SST obs 61 LOGICAL :: ln_sla_fp_indegs ! T=> SLA obs footprint size specified in degrees, F=> in metres 62 LOGICAL :: ln_sst_fp_indegs ! T=> SST obs footprint size specified in degrees, F=> in metres 63 LOGICAL :: ln_sss_fp_indegs ! T=> SSS obs footprint size specified in degrees, F=> in metres 64 LOGICAL :: ln_sic_fp_indegs ! T=> sea-ice obs footprint size specified in degrees, F=> in metres 65 66 REAL(wp) :: rn_sla_avglamscl ! E/W diameter of SLA observation footprint (metres) 67 REAL(wp) :: rn_sla_avgphiscl ! N/S diameter of SLA observation footprint (metres) 68 REAL(wp) :: rn_sst_avglamscl ! E/W diameter of SST observation footprint (metres) 69 REAL(wp) :: rn_sst_avgphiscl ! N/S diameter of SST observation footprint (metres) 70 REAL(wp) :: rn_sss_avglamscl ! E/W diameter of SSS observation footprint (metres) 71 REAL(wp) :: rn_sss_avgphiscl ! N/S diameter of SSS observation footprint (metres) 72 REAL(wp) :: rn_sic_avglamscl ! E/W diameter of sea-ice observation footprint (metres) 73 REAL(wp) :: rn_sic_avgphiscl ! N/S diameter of sea-ice observation footprint (metres) 74 75 INTEGER :: nn_1dint ! Vertical interpolation method 76 INTEGER :: nn_2dint ! Default horizontal interpolation method 77 INTEGER :: nn_2dint_sla ! SLA horizontal interpolation method 78 INTEGER :: nn_2dint_sst ! SST horizontal interpolation method 79 INTEGER :: nn_2dint_sss ! SSS horizontal interpolation method 80 INTEGER :: nn_2dint_sic ! Seaice horizontal interpolation method 59 LOGICAL, PUBLIC :: ln_diaobs !: Logical switch for the obs operator 60 LOGICAL :: ln_sstnight ! Logical switch for night mean SST obs 61 LOGICAL :: ln_default_fp_indegs ! T=> Default obs footprint size specified in degrees, F=> in metres 62 LOGICAL :: ln_sla_fp_indegs ! T=> SLA obs footprint size specified in degrees, F=> in metres 63 LOGICAL :: ln_sst_fp_indegs ! T=> SST obs footprint size specified in degrees, F=> in metres 64 LOGICAL :: ln_sss_fp_indegs ! T=> SSS obs footprint size specified in degrees, F=> in metres 65 LOGICAL :: ln_sic_fp_indegs ! T=> sea-ice obs footprint size specified in degrees, F=> in metres 66 67 REAL(wp) :: rn_default_avglamscl ! E/W diameter of SLA observation footprint (metres) 68 REAL(wp) :: rn_default_avgphiscl ! N/S diameter of SLA observation footprint (metre 69 REAL(wp) :: rn_sla_avglamscl ! E/W diameter of SLA observation footprint (metres) 70 REAL(wp) :: rn_sla_avgphiscl ! N/S diameter of SLA observation footprint (metres) 71 REAL(wp) :: rn_sst_avglamscl ! E/W diameter of SST observation footprint (metres) 72 REAL(wp) :: rn_sst_avgphiscl ! N/S diameter of SST observation footprint (metres) 73 REAL(wp) :: rn_sss_avglamscl ! E/W diameter of SSS observation footprint (metres) 74 REAL(wp) :: rn_sss_avgphiscl ! N/S diameter of SSS observation footprint (metres) 75 REAL(wp) :: rn_sic_avglamscl ! E/W diameter of sea-ice observation footprint (metres) 76 REAL(wp) :: rn_sic_avgphiscl ! N/S diameter of sea-ice observation footprint (metres) 77 78 INTEGER :: nn_1dint ! Vertical interpolation method 79 INTEGER :: nn_2dint_default ! Default horizontal interpolation method 80 INTEGER :: nn_2dint_sla ! SLA horizontal interpolation method 81 INTEGER :: nn_2dint_sst ! SST horizontal interpolation method 82 INTEGER :: nn_2dint_sss ! SSS horizontal interpolation method 83 INTEGER :: nn_2dint_sic ! Seaice horizontal interpolation method 81 84 INTEGER, DIMENSION(imaxavtypes) :: nn_profdavtypes ! Profile data types representing a daily average 82 85 INTEGER :: nproftypes ! Number of profile obs types … … 94 97 TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: profdataqc !: Profile data after quality control 95 98 96 CHARACTER(len= lca), PUBLIC, DIMENSION(:), ALLOCATABLE :: cobstypesprof, cobstypessurf !: Profile & surface obs types99 CHARACTER(len=8), PUBLIC, DIMENSION(:), ALLOCATABLE :: cobstypesprof, cobstypessurf !: Profile & surface obs types 97 100 98 101 !!---------------------------------------------------------------------- … … 121 124 INTEGER :: jvar ! Counter for variables 122 125 INTEGER :: jfile ! Counter for files 123 INTEGER :: jnumsstbias 126 INTEGER :: jnumsstbias ! Number of SST bias files to read and apply 127 INTEGER :: n2dint_type ! Local version of nn_2dint* 124 128 ! 125 129 CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: & … … 130 134 & cn_sicfbfiles, & ! Seaice concentration input filenames 131 135 & cn_velfbfiles, & ! Velocity profile input filenames 132 & cn_sstbiasfiles ! SST bias input filenames136 & cn_sstbiasfiles ! SST bias input filenames 133 137 CHARACTER(LEN=128) :: & 134 138 & cn_altbiasfile ! Altimeter bias input filename … … 136 140 & clproffiles, & ! Profile filenames 137 141 & clsurffiles ! Surface filenames 142 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: & 143 & clvars ! Expected variable names 138 144 ! 139 145 LOGICAL :: ln_t3d ! Logical switch for temperature profiles … … 150 156 LOGICAL :: ln_s_at_t ! Logical switch to compute model S at T obs 151 157 LOGICAL :: ln_bound_reject ! Logical to remove obs near boundaries in LAMs. 152 LOGICAL :: llvar1 ! Logical for profile variable 1 153 LOGICAL :: llvar2 ! Logical for profile variable 1 158 LOGICAL :: ltype_fp_indegs ! Local version of ln_*_fp_indegs 159 LOGICAL :: ltype_night ! Local version of ln_sstnight (false for other variables) 160 LOGICAL, DIMENSION(:), ALLOCATABLE :: llvar ! Logical for profile variable read 154 161 LOGICAL, DIMENSION(jpmaxnfiles) :: lmask ! Used for finding number of sstbias files 155 162 ! 156 REAL(dp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS 157 REAL(dp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS 158 REAL(wp), DIMENSION(jpi,jpj) :: zglam1, zglam2 ! Model longitudes for profile variable 1 & 2 159 REAL(wp), DIMENSION(jpi,jpj) :: zgphi1, zgphi2 ! Model latitudes for profile variable 1 & 2 160 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask1, zmask2 ! Model land/sea mask associated with variable 1 & 2 163 REAL(dp) :: rn_dobsini ! Obs window start date YYYYMMDD.HHMMSS 164 REAL(dp) :: rn_dobsend ! Obs window end date YYYYMMDD.HHMMSS 165 REAL(wp) :: ztype_avglamscl ! Local version of rn_*_avglamscl 166 REAL(wp) :: ztype_avgphiscl ! Local version of rn_*_avgphiscl 167 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zglam ! Model longitudes for profile variables 168 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zgphi ! Model latitudes for profile variables 169 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zmask ! Model land/sea mask associated with variables 161 170 !! 162 171 NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla, & … … 165 174 & ln_grid_global, ln_grid_search_lookup, & 166 175 & ln_ignmis, ln_s_at_t, ln_bound_reject, & 167 & ln_sstnight, 176 & ln_sstnight, ln_default_fp_indegs, & 168 177 & ln_sla_fp_indegs, ln_sst_fp_indegs, & 169 178 & ln_sss_fp_indegs, ln_sic_fp_indegs, & … … 174 183 & cn_gridsearchfile, rn_gridsearchres, & 175 184 & rn_dobsini, rn_dobsend, & 185 & rn_default_avglamscl, rn_default_avgphiscl, & 176 186 & rn_sla_avglamscl, rn_sla_avgphiscl, & 177 187 & rn_sst_avglamscl, rn_sst_avgphiscl, & 178 188 & rn_sss_avglamscl, rn_sss_avgphiscl, & 179 189 & rn_sic_avglamscl, rn_sic_avgphiscl, & 180 & nn_1dint, nn_2dint ,&190 & nn_1dint, nn_2dint_default, & 181 191 & nn_2dint_sla, nn_2dint_sst, & 182 192 & nn_2dint_sss, nn_2dint_sic, & … … 234 244 WRITE(numout,*) ' Final date in window YYYYMMDD.HHMMSS rn_dobsend = ', rn_dobsend 235 245 WRITE(numout,*) ' Type of vertical interpolation method nn_1dint = ', nn_1dint 236 WRITE(numout,*) ' Type of horizontal interpolation method nn_2dint = ', nn_2dint 246 WRITE(numout,*) ' Default horizontal interpolation method nn_2dint_default = ', nn_2dint_default 247 WRITE(numout,*) ' Type of horizontal interpolation method for SLA nn_2dint_sla = ', nn_2dint_sla 248 WRITE(numout,*) ' Type of horizontal interpolation method for SST nn_2dint_sst = ', nn_2dint_sst 249 WRITE(numout,*) ' Type of horizontal interpolation method for SSS nn_2dint_sss = ', nn_2dint_sss 250 WRITE(numout,*) ' Type of horizontal interpolation method for SIC nn_2dint_sic = ', nn_2dint_sic 251 WRITE(numout,*) ' Default E/W diameter of obs footprint rn_default_avglamscl = ', rn_default_avglamscl 252 WRITE(numout,*) ' Default N/S diameter of obs footprint rn_default_avgphiscl = ', rn_default_avgphiscl 253 WRITE(numout,*) ' Default obs footprint in deg [T] or m [F] ln_default_fp_indegs = ', ln_default_fp_indegs 254 WRITE(numout,*) ' SLA E/W diameter of obs footprint rn_sla_avglamscl = ', rn_sla_avglamscl 255 WRITE(numout,*) ' SLA N/S diameter of obs footprint rn_sla_avgphiscl = ', rn_sla_avgphiscl 256 WRITE(numout,*) ' SLA obs footprint in deg [T] or m [F] ln_sla_fp_indegs = ', ln_sla_fp_indegs 257 WRITE(numout,*) ' SST E/W diameter of obs footprint rn_sst_avglamscl = ', rn_sst_avglamscl 258 WRITE(numout,*) ' SST N/S diameter of obs footprint rn_sst_avgphiscl = ', rn_sst_avgphiscl 259 WRITE(numout,*) ' SST obs footprint in deg [T] or m [F] ln_sst_fp_indegs = ', ln_sst_fp_indegs 260 WRITE(numout,*) ' SIC E/W diameter of obs footprint rn_sic_avglamscl = ', rn_sic_avglamscl 261 WRITE(numout,*) ' SIC N/S diameter of obs footprint rn_sic_avgphiscl = ', rn_sic_avgphiscl 262 WRITE(numout,*) ' SIC obs footprint in deg [T] or m [F] ln_sic_fp_indegs = ', ln_sic_fp_indegs 237 263 WRITE(numout,*) ' Rejection of observations near land switch ln_nea = ', ln_nea 238 264 WRITE(numout,*) ' Rejection of obs near open bdys ln_bound_reject = ', ln_bound_reject … … 278 304 IF( ln_t3d .OR. ln_s3d ) THEN 279 305 jtype = jtype + 1 280 CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'prof ', &281 & cn_profbfiles, ifilesprof, cobstypesprof, clproffiles )306 cobstypesprof(jtype) = 'prof' 307 clproffiles(jtype,:) = cn_profbfiles 282 308 ENDIF 283 309 IF( ln_vel3d ) THEN 284 310 jtype = jtype + 1 285 CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'vel ', &286 & cn_velfbfiles, ifilesprof, cobstypesprof, clproffiles )311 cobstypesprof(jtype) = 'vel' 312 clproffiles(jtype,:) = cn_velfbfiles 287 313 ENDIF 314 ! 315 CALL obs_settypefiles( nproftypes, jpmaxnfiles, ifilesprof, cobstypesprof, clproffiles ) 288 316 ! 289 317 ENDIF … … 303 331 IF( ln_sla ) THEN 304 332 jtype = jtype + 1 305 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sla ', & 306 & cn_slafbfiles, ifilessurf, cobstypessurf, clsurffiles ) 307 CALL obs_setinterpopts( nsurftypes, jtype, 'sla ', & 308 & nn_2dint, nn_2dint_sla, & 309 & rn_sla_avglamscl, rn_sla_avgphiscl, & 310 & ln_sla_fp_indegs, .FALSE., & 311 & n2dintsurf, zavglamscl, zavgphiscl, & 312 & lfpindegs, llnightav ) 333 cobstypessurf(jtype) = 'sla' 334 clsurffiles(jtype,:) = cn_slafbfiles 313 335 ENDIF 314 336 IF( ln_sst ) THEN 315 337 jtype = jtype + 1 316 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sst ', & 317 & cn_sstfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 318 CALL obs_setinterpopts( nsurftypes, jtype, 'sst ', & 319 & nn_2dint, nn_2dint_sst, & 320 & rn_sst_avglamscl, rn_sst_avgphiscl, & 321 & ln_sst_fp_indegs, ln_sstnight, & 322 & n2dintsurf, zavglamscl, zavgphiscl, & 323 & lfpindegs, llnightav ) 338 cobstypessurf(jtype) = 'sst' 339 clsurffiles(jtype,:) = cn_sstfbfiles 324 340 ENDIF 325 341 #if defined key_si3 || defined key_cice 326 342 IF( ln_sic ) THEN 327 343 jtype = jtype + 1 328 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sic ', & 329 & cn_sicfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 330 CALL obs_setinterpopts( nsurftypes, jtype, 'sic ', & 331 & nn_2dint, nn_2dint_sic, & 332 & rn_sic_avglamscl, rn_sic_avgphiscl, & 333 & ln_sic_fp_indegs, .FALSE., & 334 & n2dintsurf, zavglamscl, zavgphiscl, & 335 & lfpindegs, llnightav ) 344 cobstypessurf(jtype) = 'sic' 345 clsurffiles(jtype,:) = cn_sicfbfiles 336 346 ENDIF 337 347 #endif 338 348 IF( ln_sss ) THEN 339 349 jtype = jtype + 1 340 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sss ', & 341 & cn_sssfbfiles, ifilessurf, cobstypessurf, clsurffiles ) 342 CALL obs_setinterpopts( nsurftypes, jtype, 'sss ', & 343 & nn_2dint, nn_2dint_sss, & 344 & rn_sss_avglamscl, rn_sss_avgphiscl, & 345 & ln_sss_fp_indegs, .FALSE., & 346 & n2dintsurf, zavglamscl, zavgphiscl, & 347 & lfpindegs, llnightav ) 350 cobstypessurf(jtype) = 'sss' 351 clsurffiles(jtype,:) = cn_sssfbfiles 348 352 ENDIF 353 ! 354 CALL obs_settypefiles( nsurftypes, jpmaxnfiles, ifilessurf, cobstypessurf, clsurffiles ) 355 356 DO jtype = 1, nsurftypes 357 358 IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 359 IF ( nn_2dint_sla == -1 ) THEN 360 n2dint_type = nn_2dint_default 361 ELSE 362 n2dint_type = nn_2dint_sla 363 ENDIF 364 ztype_avglamscl = rn_sla_avglamscl 365 ztype_avgphiscl = rn_sla_avgphiscl 366 ltype_fp_indegs = ln_sla_fp_indegs 367 ltype_night = .FALSE. 368 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN 369 IF ( nn_2dint_sst == -1 ) THEN 370 n2dint_type = nn_2dint_default 371 ELSE 372 n2dint_type = nn_2dint_sst 373 ENDIF 374 ztype_avglamscl = rn_sst_avglamscl 375 ztype_avgphiscl = rn_sst_avgphiscl 376 ltype_fp_indegs = ln_sst_fp_indegs 377 ltype_night = ln_sstnight 378 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN 379 IF ( nn_2dint_sic == -1 ) THEN 380 n2dint_type = nn_2dint_default 381 ELSE 382 n2dint_type = nn_2dint_sic 383 ENDIF 384 ztype_avglamscl = rn_sic_avglamscl 385 ztype_avgphiscl = rn_sic_avgphiscl 386 ltype_fp_indegs = ln_sic_fp_indegs 387 ltype_night = .FALSE. 388 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN 389 IF ( nn_2dint_sss == -1 ) THEN 390 n2dint_type = nn_2dint_default 391 ELSE 392 n2dint_type = nn_2dint_sss 393 ENDIF 394 ztype_avglamscl = rn_sss_avglamscl 395 ztype_avgphiscl = rn_sss_avgphiscl 396 ltype_fp_indegs = ln_sss_fp_indegs 397 ltype_night = .FALSE. 398 ELSE 399 n2dint_type = nn_2dint_default 400 ztype_avglamscl = rn_default_avglamscl 401 ztype_avgphiscl = rn_default_avgphiscl 402 ltype_fp_indegs = ln_default_fp_indegs 403 ltype_night = .FALSE. 404 ENDIF 405 406 CALL obs_setinterpopts( nsurftypes, jtype, TRIM(cobstypessurf(jtype)), & 407 & nn_2dint_default, n2dint_type, & 408 & ztype_avglamscl, ztype_avgphiscl, & 409 & ltype_fp_indegs, ltype_night, & 410 & n2dintsurf, zavglamscl, zavgphiscl, & 411 & lfpindegs, llnightav ) 412 413 END DO 349 414 ! 350 415 ENDIF … … 368 433 ENDIF 369 434 ! 370 IF( nn_2dint < 0 .OR. nn_2dint > 6 ) THEN371 CALL ctl_stop('dia_obs_init: Choice of horizontal (2D) interpolation method is not available')435 IF( nn_2dint_default < 0 .OR. nn_2dint_default > 6 ) THEN 436 CALL ctl_stop('dia_obs_init: Choice of default horizontal (2D) interpolation method is not available') 372 437 ENDIF 373 438 ! … … 388 453 DO jtype = 1, nproftypes 389 454 ! 390 nvarsprof(jtype) = 2391 455 IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN 392 nextrprof(jtype) = 1 393 llvar1 = ln_t3d 394 llvar2 = ln_s3d 395 zglam1 = glamt 396 zgphi1 = gphit 397 zmask1 = tmask 398 zglam2 = glamt 399 zgphi2 = gphit 400 zmask2 = tmask 401 ENDIF 402 IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 456 nvarsprof(jtype) = 2 457 nextrprof(jtype) = 1 458 ALLOCATE( llvar (nvarsprof(jtype)) ) 459 ALLOCATE( clvars(nvarsprof(jtype)) ) 460 ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) 461 ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) 462 ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) 463 llvar(1) = ln_t3d 464 llvar(2) = ln_s3d 465 clvars(1) = 'POTM' 466 clvars(2) = 'PSAL' 467 zglam(:,:,1) = glamt(:,:) 468 zglam(:,:,2) = glamt(:,:) 469 zgphi(:,:,1) = gphit(:,:) 470 zgphi(:,:,2) = gphit(:,:) 471 zmask(:,:,:,1) = tmask(:,:,:) 472 zmask(:,:,:,2) = tmask(:,:,:) 473 ELSE IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 474 nvarsprof(jtype) = 2 403 475 nextrprof(jtype) = 2 404 llvar1 = ln_vel3d 405 llvar2 = ln_vel3d 406 zglam1 = glamu 407 zgphi1 = gphiu 408 zmask1 = umask 409 zglam2 = glamv 410 zgphi2 = gphiv 411 zmask2 = vmask 476 ALLOCATE( llvar (nvarsprof(jtype)) ) 477 ALLOCATE( clvars(nvarsprof(jtype)) ) 478 ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) 479 ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) 480 ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) 481 llvar(1) = ln_vel3d 482 llvar(2) = ln_vel3d 483 clvars(1) = 'UVEL' 484 clvars(2) = 'VVEL' 485 zglam(:,:,1) = glamu(:,:) 486 zglam(:,:,2) = glamv(:,:) 487 zgphi(:,:,1) = gphiu(:,:) 488 zgphi(:,:,2) = gphiv(:,:) 489 zmask(:,:,:,1) = umask(:,:,:) 490 zmask(:,:,:,2) = vmask(:,:,:) 491 ELSE 492 nvarsprof(jtype) = 1 493 nextrprof(jtype) = 0 494 ALLOCATE( llvar (nvarsprof(jtype)) ) 495 ALLOCATE( clvars(nvarsprof(jtype)) ) 496 ALLOCATE( zglam(jpi, jpj, nvarsprof(jtype)) ) 497 ALLOCATE( zgphi(jpi, jpj, nvarsprof(jtype)) ) 498 ALLOCATE( zmask(jpi, jpj, jpk, nvarsprof(jtype)) ) 499 llvar(1) = .TRUE. 500 zglam(:,:,1) = glamt(:,:) 501 zgphi(:,:,1) = gphit(:,:) 502 zmask(:,:,:,1) = tmask(:,:,:) 412 503 ENDIF 413 504 ! … … 416 507 & clproffiles(jtype,1:ifilesprof(jtype)), & 417 508 & nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & 418 & rn_dobsini, rn_dobsend, llvar 1, llvar2, &419 & ln_ignmis, ln_s_at_t, .FALSE., &509 & rn_dobsini, rn_dobsend, llvar, & 510 & ln_ignmis, ln_s_at_t, .FALSE., clvars, & 420 511 & kdailyavtypes = nn_profdavtypes ) 421 512 ! … … 425 516 ! 426 517 CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & 427 & llvar 1, llvar2, &518 & llvar, & 428 519 & jpi, jpj, jpk, & 429 & zmask 1, zglam1, zgphi1, zmask2, zglam2, zgphi2,&520 & zmask, zglam, zgphi, & 430 521 & ln_nea, ln_bound_reject, Kmm, & 431 522 & kdailyavtypes = nn_profdavtypes ) 523 ! 524 DEALLOCATE( llvar, clvars, zglam, zgphi, zmask ) 525 ! 432 526 END DO 433 527 ! … … 449 543 IF( TRIM(cobstypessurf(jtype)) == 'sst' ) llnightav(jtype) = ln_sstnight 450 544 ! 545 ALLOCATE( clvars( nvarssurf(jtype) ) ) 546 IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 547 clvars(1) = 'SLA' 548 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN 549 clvars(1) = 'SST' 550 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN 551 clvars(1) = 'ICECONC' 552 ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN 553 clvars(1) = 'SSS' 554 ENDIF 555 ! 451 556 ! Read in surface obs types 452 557 CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), & 453 558 & clsurffiles(jtype,1:ifilessurf(jtype)), & 454 559 & nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, & 455 & rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype) ) 560 & rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav(jtype), & 561 & clvars ) 456 562 ! 457 563 CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea, ln_bound_reject ) … … 473 579 & jnumsstbias , cn_sstbiasfiles(1:jnumsstbias) ) 474 580 ENDIF 581 ! 582 DEALLOCATE( clvars ) 475 583 END DO 476 584 ! … … 516 624 INTEGER :: jvar ! Variable number 517 625 INTEGER :: ji, jj ! Loop counters 518 REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 519 & zprofvar1, & ! Model values for 1st variable in a prof ob 520 & zprofvar2 ! Model values for 2nd variable in a prof ob 521 REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 522 & zprofmask1, & ! Mask associated with zprofvar1 523 & zprofmask2 ! Mask associated with zprofvar2 626 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 627 & zprofvar ! Model values for variables in a prof ob 628 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 629 & zprofmask ! Mask associated with zprofvar 524 630 REAL(wp), DIMENSION(jpi,jpj) :: & 525 631 & zsurfvar, & ! Model values equivalent to surface ob. 526 632 & zsurfmask ! Mask associated with surface variable 527 REAL(wp), DIMENSION(jpi,jpj) :: & 528 & zglam1, & ! Model longitudes for prof variable 1 529 & zglam2, & ! Model longitudes for prof variable 2 530 & zgphi1, & ! Model latitudes for prof variable 1 531 & zgphi2 ! Model latitudes for prof variable 2 633 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 634 & zglam, & ! Model longitudes for prof variables 635 & zgphi ! Model latitudes for prof variables 532 636 533 637 !----------------------------------------------------------------------- … … 549 653 DO jtype = 1, nproftypes 550 654 655 ! Allocate local work arrays 656 ALLOCATE( zprofvar (jpi, jpj, jpk, profdataqc(jtype)%nvar) ) 657 ALLOCATE( zprofmask(jpi, jpj, jpk, profdataqc(jtype)%nvar) ) 658 ALLOCATE( zglam (jpi, jpj, profdataqc(jtype)%nvar) ) 659 ALLOCATE( zgphi (jpi, jpj, profdataqc(jtype)%nvar) ) 660 661 ! Defaults which might change 662 DO jvar = 1, profdataqc(jtype)%nvar 663 zprofmask(:,:,:,jvar) = tmask(:,:,:) 664 zglam(:,:,jvar) = glamt(:,:) 665 zgphi(:,:,jvar) = gphit(:,:) 666 END DO 667 551 668 SELECT CASE ( TRIM(cobstypesprof(jtype)) ) 552 669 CASE('prof') 553 zprofvar1(:,:,:) = ts(:,:,:,jp_tem,Kmm) 554 zprofvar2(:,:,:) = ts(:,:,:,jp_sal,Kmm) 555 zprofmask1(:,:,:) = tmask(:,:,:) 556 zprofmask2(:,:,:) = tmask(:,:,:) 557 zglam1(:,:) = glamt(:,:) 558 zglam2(:,:) = glamt(:,:) 559 zgphi1(:,:) = gphit(:,:) 560 zgphi2(:,:) = gphit(:,:) 670 zprofvar(:,:,:,1) = ts(:,:,:,jp_tem,Kmm) 671 zprofvar(:,:,:,2) = ts(:,:,:,jp_sal,Kmm) 561 672 CASE('vel') 562 zprofvar 1(:,:,:) = uu(:,:,:,Kmm)563 zprofvar 2(:,:,:) = vv(:,:,:,Kmm)564 zprofmask 1(:,:,:) = umask(:,:,:)565 zprofmask 2(:,:,:) = vmask(:,:,:)566 zglam 1(:,:) = glamu(:,:)567 zglam 2(:,:) = glamv(:,:)568 zgphi 1(:,:) = gphiu(:,:)569 zgphi 2(:,:) = gphiv(:,:)673 zprofvar(:,:,:,1) = uu(:,:,:,Kmm) 674 zprofvar(:,:,:,2) = vv(:,:,:,Kmm) 675 zprofmask(:,:,:,1) = umask(:,:,:) 676 zprofmask(:,:,:,2) = vmask(:,:,:) 677 zglam(:,:,1) = glamu(:,:) 678 zglam(:,:,2) = glamv(:,:) 679 zgphi(:,:,1) = gphiu(:,:) 680 zgphi(:,:,2) = gphiv(:,:) 570 681 CASE DEFAULT 571 682 CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' ) 572 683 END SELECT 573 684 574 CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk, & 575 & nit000, idaystp, & 576 & zprofvar1, zprofvar2, & 577 & gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm), & 578 & zprofmask1, zprofmask2, & 579 & zglam1, zglam2, zgphi1, zgphi2, & 580 & nn_1dint, nn_2dint, & 581 & kdailyavtypes = nn_profdavtypes ) 685 DO jvar = 1, profdataqc(jtype)%nvar 686 CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk, & 687 & nit000, idaystp, jvar, & 688 & zprofvar(:,:,:,jvar), & 689 & gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm), & 690 & zprofmask(:,:,:,jvar), & 691 & zglam(:,:,jvar), zgphi(:,:,jvar), & 692 & nn_1dint, nn_2dint_default, & 693 & kdailyavtypes = nn_profdavtypes ) 694 END DO 695 696 DEALLOCATE( zprofvar, zprofmask, zglam, zgphi ) 582 697 583 698 END DO … … 680 795 & ) 681 796 682 CALL obs_rotvel( profdataqc(jtype), nn_2dint , zu, zv )797 CALL obs_rotvel( profdataqc(jtype), nn_2dint_default, zu, zv ) 683 798 684 799 DO jo = 1, profdataqc(jtype)%nprof … … 896 1011 END SUBROUTINE fin_date 897 1012 898 SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, jtype, ctypein, &899 & cfilestype, ifiles, cobstypes, cfiles ) 900 901 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types902 INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type903 INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs904 INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: &905 & ifiles ! Out appended number of files for this type906 907 CHARACTER(len=6), INTENT(IN) :: ctypein908 CHARACTER(len=128), DIMENSION(jpmaxnfiles), INTENT(IN) :: & 909 & cfilestype ! In list of files for this obs type910 CHARACTER(len=6), DIMENSION(ntypes), INTENT(INOUT) :: &911 & cobstypes ! Out appended list of obs types912 CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(INOUT) :: & 913 & cfiles ! Out appended list of files for alltypes914 915 !Local variables916 INTEGER :: jfile917 918 cfiles(jtype,:) = cfilestype(:)919 cobstypes(jtype) = ctypein920 ifiles(jtype) = 0 921 DO jfile = 1, jpmaxnfiles922 IF ( trim(cfiles(jtype,jfile)) /= '' )&923 ifiles(jtype) = ifiles(jtype) + 1924 END DO925 926 IF ( ifiles(jtype) == 0 ) THEN927 CALL ctl_stop( 'Logical for observation type '//TRIM(ctypein)// &928 & ' set to true but no files available to read')929 ENDIF930 931 IF(lwp) THEN932 WRITE(numout,*) ' '//cobstypes(jtype)//' input observation file names:' 933 DO jfile = 1, ifiles(jtype)934 WRITE(numout,*) ' '//TRIM(cfiles(jtype,jfile)) 935 END DO936 ENDIF 937 938 END SUBROUTINE obs_settypefiles939 940 SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein,&941 & n2dint_default, n2dint_type,&942 & zavglamscl_type, zavgphiscl_type, &943 & lfp_indegs_type, lavnight_type, & 944 & n2dint, zavglamscl, zavgphiscl, &945 & lfpindegs, lavnight )946 947 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types948 INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs949 INTEGER, INTENT(IN) :: n2dint_default ! Default option for interpolationtype950 INTEGER, INTENT(IN) :: n2dint_type ! Option for interpolationtype951 REAL(wp), INTENT(IN) :: &952 & zavglamscl_type, & !E/W diameter of obs footprint for this type953 & zavgphiscl_type !N/S diameter of obs footprint for this type954 LOGICAL, INTENT(IN) :: lfp_indegs_type !T=> footprint in degrees, F=> in metres 955 LOGICAL, INTENT(IN) :: lavnight_type !T=> obs represent night time average956 CHARACTER(len=6), INTENT(IN) :: ctypein957 958 INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: &959 & n2dint960 REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: &961 & zavglamscl, zavgphiscl 962 LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: &963 & lfpindegs, lavnight 964 965 lavnight(jtype) = lavnight_type966 967 IF ( (n2dint_type >= 1) .AND. (n2dint_type <= 6) ) THEN968 n2dint(jtype) = n2dint_type969 ELSE970 n2dint(jtype) = n2dint_default971 ENDIF972 973 ! For averaging observation footprints set options for size of footprint974 IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN975 IF ( zavglamscl_type > 0._wp ) THEN976 zavglamscl(jtype) = zavglamscl_type977 ELSE978 CALL ctl_stop( 'Incorrect value set for averaging footprint '// &979 'scale (zavglamscl) for observation type '//TRIM(ctypein) )980 ENDIF981 982 IF ( zavgphiscl_type > 0._wp ) THEN983 zavgphiscl(jtype) = zavgphiscl_type984 ELSE985 CALL ctl_stop( 'Incorrect value set for averaging footprint '// &986 'scale (zavgphiscl) for observation type '//TRIM(ctypein) )987 ENDIF988 989 lfpindegs(jtype) = lfp_indegs_type990 991 ENDIF992 993 ! Write out info994 IF(lwp) THEN995 IF ( n2dint(jtype) <= 4 ) THEN996 WRITE(numout,*) ' '//TRIM(ctypein)// &997 & ' model counterparts will be interpolated horizontally'998 ELSE IF ( n2dint(jtype) <= 6 ) THEN999 WRITE(numout,*) ' '//TRIM(ctypein)// &1000 & ' model counterparts will be averaged horizontally'1001 WRITE(numout,*) ' '//' with E/W scale: ',zavglamscl(jtype)1002 WRITE(numout,*) ' '//' with N/S scale: ',zavgphiscl(jtype)1003 IF ( lfpindegs(jtype) ) THEN1004 WRITE(numout,*) ' '//' (in degrees)'1005 ELSE1006 WRITE(numout,*) ' '//' (in metres)'1007 ENDIF1008 ENDIF1009 ENDIF1010 1011 1013 SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, ifiles, cobstypes, cfiles ) 1014 1015 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types 1016 INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type 1017 INTEGER, DIMENSION(ntypes), INTENT(OUT) :: & 1018 & ifiles ! Out number of files for each type 1019 CHARACTER(len=8), DIMENSION(ntypes), INTENT(IN) :: & 1020 & cobstypes ! List of obs types 1021 CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(IN) :: & 1022 & cfiles ! List of files for all types 1023 1024 !Local variables 1025 INTEGER :: jfile 1026 INTEGER :: jtype 1027 1028 DO jtype = 1, ntypes 1029 1030 ifiles(jtype) = 0 1031 DO jfile = 1, jpmaxnfiles 1032 IF ( trim(cfiles(jtype,jfile)) /= '' ) & 1033 ifiles(jtype) = ifiles(jtype) + 1 1034 END DO 1035 1036 IF ( ifiles(jtype) == 0 ) THEN 1037 CALL ctl_stop( 'Logical for observation type '//TRIM(cobstypes(jtype))// & 1038 & ' set to true but no files available to read' ) 1039 ENDIF 1040 1041 IF(lwp) THEN 1042 WRITE(numout,*) ' '//cobstypes(jtype)//' input observation file names:' 1043 DO jfile = 1, ifiles(jtype) 1044 WRITE(numout,*) ' '//TRIM(cfiles(jtype,jfile)) 1045 END DO 1046 ENDIF 1047 1048 END DO 1049 1050 END SUBROUTINE obs_settypefiles 1051 1052 SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein, & 1053 & n2dint_default, n2dint_type, & 1054 & ravglamscl_type, ravgphiscl_type, & 1055 & lfp_indegs_type, lavnight_type, & 1056 & n2dint, ravglamscl, ravgphiscl, & 1057 & lfpindegs, lavnight ) 1058 1059 INTEGER, INTENT(IN) :: ntypes ! Total number of obs types 1060 INTEGER, INTENT(IN) :: jtype ! Index of the current type of obs 1061 INTEGER, INTENT(IN) :: n2dint_default ! Default option for interpolation type 1062 INTEGER, INTENT(IN) :: n2dint_type ! Option for interpolation type 1063 REAL(wp), INTENT(IN) :: & 1064 & ravglamscl_type, & !E/W diameter of obs footprint for this type 1065 & ravgphiscl_type !N/S diameter of obs footprint for this type 1066 LOGICAL, INTENT(IN) :: lfp_indegs_type !T=> footprint in degrees, F=> in metres 1067 LOGICAL, INTENT(IN) :: lavnight_type !T=> obs represent night time average 1068 CHARACTER(len=8), INTENT(IN) :: ctypein 1069 1070 INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & 1071 & n2dint 1072 REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: & 1073 & ravglamscl, ravgphiscl 1074 LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: & 1075 & lfpindegs, lavnight 1076 1077 lavnight(jtype) = lavnight_type 1078 1079 IF ( (n2dint_type >= 0) .AND. (n2dint_type <= 6) ) THEN 1080 n2dint(jtype) = n2dint_type 1081 ELSE IF ( n2dint_type == -1 ) THEN 1082 n2dint(jtype) = n2dint_default 1083 ELSE 1084 CALL ctl_stop(' Choice of '//TRIM(ctypein)//' horizontal (2D) interpolation method', & 1085 & ' is not available') 1086 ENDIF 1087 1088 ! For averaging observation footprints set options for size of footprint 1089 IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN 1090 IF ( ravglamscl_type > 0._wp ) THEN 1091 ravglamscl(jtype) = ravglamscl_type 1092 ELSE 1093 CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 1094 'scale (ravglamscl) for observation type '//TRIM(ctypein) ) 1095 ENDIF 1096 1097 IF ( ravgphiscl_type > 0._wp ) THEN 1098 ravgphiscl(jtype) = ravgphiscl_type 1099 ELSE 1100 CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 1101 'scale (ravgphiscl) for observation type '//TRIM(ctypein) ) 1102 ENDIF 1103 1104 lfpindegs(jtype) = lfp_indegs_type 1105 1106 ENDIF 1107 1108 ! Write out info 1109 IF(lwp) THEN 1110 IF ( n2dint(jtype) <= 4 ) THEN 1111 WRITE(numout,*) ' '//TRIM(ctypein)// & 1112 & ' model counterparts will be interpolated horizontally' 1113 ELSE IF ( n2dint(jtype) <= 6 ) THEN 1114 WRITE(numout,*) ' '//TRIM(ctypein)// & 1115 & ' model counterparts will be averaged horizontally' 1116 WRITE(numout,*) ' '//' with E/W scale: ',ravglamscl(jtype) 1117 WRITE(numout,*) ' '//' with N/S scale: ',ravgphiscl(jtype) 1118 IF ( lfpindegs(jtype) ) THEN 1119 WRITE(numout,*) ' '//' (in degrees)' 1120 ELSE 1121 WRITE(numout,*) ' '//' (in metres)' 1122 ENDIF 1123 ENDIF 1124 ENDIF 1125 1126 END SUBROUTINE obs_setinterpopts 1012 1127 1013 1128 END MODULE diaobs -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/OBS/obs_oper.F90
r13295 r14058 40 40 CONTAINS 41 41 42 SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, 43 & kit000, kdaystp, 44 & pvar 1, pvar2, pgdept, pgdepw,&45 & pmask 1, pmask2, &46 & plam 1, plam2, pphi1, pphi2,&42 SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, & 43 & kit000, kdaystp, kvar, & 44 & pvar, pgdept, pgdepw, & 45 & pmask, & 46 & plam, pphi, & 47 47 & k1dint, k2dint, kdailyavtypes ) 48 48 !!----------------------------------------------------------------------- … … 105 105 INTEGER , INTENT(in ) :: k2dint ! Horizontal interpolation type (see header) 106 106 INTEGER , INTENT(in ) :: kdaystp ! Number of time steps per day 107 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pvar1 , pvar2 ! Model field 1 and 2 108 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pmask1, pmask2 ! Land-sea mask 1 and 2 109 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: plam1 , plam2 ! Model longitude 1 and 2 110 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: pphi1 , pphi2 ! Model latitudes 1 and 2 107 INTEGER , INTENT(in ) :: kvar ! Number of variables in prodatqc 108 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pvar ! Model field 109 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pmask ! Land-sea mask 110 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: plam ! Model longitude 111 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: pphi ! Model latitudes 111 112 REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pgdept, pgdepw ! depth of T and W levels 112 113 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: kdailyavtypes ! Types for daily averages … … 128 129 & idailyavtypes 129 130 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 130 & igrdi1, & 131 & igrdi2, & 132 & igrdj1, & 133 & igrdj2 131 & igrdi, & 132 & igrdj 134 133 INTEGER, ALLOCATABLE, DIMENSION(:) :: iv_indic 135 134 … … 138 137 REAL(KIND=wp) :: zdaystp 139 138 REAL(KIND=wp), DIMENSION(kpk) :: & 140 & zobsmask1, & 141 & zobsmask2, & 142 & zobsk, & 139 & zobsk, & 143 140 & zobs2k 144 141 REAL(KIND=wp), DIMENSION(2,2,1) :: & 145 142 & zweig1, & 146 & zweig2, &147 143 & zweig 148 144 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 149 & zmask1, & 150 & zmask2, & 151 & zint1, & 152 & zint2, & 153 & zinm1, & 154 & zinm2, & 145 & zmask, & 146 & zint, & 147 & zinm, & 155 148 & zgdept, & 156 149 & zgdepw 157 150 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 158 & zglam1, & 159 & zglam2, & 160 & zgphi1, & 161 & zgphi2 162 REAL(KIND=wp), DIMENSION(1) :: zmsk_1, zmsk_2 151 & zglam, & 152 & zgphi 153 REAL(KIND=wp), DIMENSION(1) :: zmsk 163 154 REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner 164 155 … … 190 181 IF ( idayend == 1 .OR. kt == 0 ) THEN 191 182 DO_3D( 1, 1, 1, 1, 1, jpk ) 192 prodatqc%vdmean(ji,jj,jk,1) = 0.0 193 prodatqc%vdmean(ji,jj,jk,2) = 0.0 183 prodatqc%vdmean(ji,jj,jk,kvar) = 0.0 194 184 END_3D 195 185 ENDIF … … 197 187 DO_3D( 1, 1, 1, 1, 1, jpk ) 198 188 ! Increment field 1 for computing daily mean 199 prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 200 & + pvar1(ji,jj,jk) 201 ! Increment field 2 for computing daily mean 202 prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 203 & + pvar2(ji,jj,jk) 189 prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & 190 & + pvar(ji,jj,jk) 204 191 END_3D 205 192 … … 210 197 CALL FLUSH(numout) 211 198 DO_3D( 1, 1, 1, 1, 1, jpk ) 212 prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 213 & * zdaystp 214 prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 215 & * zdaystp 199 prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & 200 & * zdaystp 216 201 END_3D 217 202 ENDIF … … 221 206 ! Get the data for interpolation 222 207 ALLOCATE( & 223 & igrdi1(2,2,ipro), & 224 & igrdi2(2,2,ipro), & 225 & igrdj1(2,2,ipro), & 226 & igrdj2(2,2,ipro), & 227 & zglam1(2,2,ipro), & 228 & zglam2(2,2,ipro), & 229 & zgphi1(2,2,ipro), & 230 & zgphi2(2,2,ipro), & 231 & zmask1(2,2,kpk,ipro), & 232 & zmask2(2,2,kpk,ipro), & 233 & zint1(2,2,kpk,ipro), & 234 & zint2(2,2,kpk,ipro), & 235 & zgdept(2,2,kpk,ipro), & 236 & zgdepw(2,2,kpk,ipro) & 208 & igrdi(2,2,ipro), & 209 & igrdj(2,2,ipro), & 210 & zglam(2,2,ipro), & 211 & zgphi(2,2,ipro), & 212 & zmask(2,2,kpk,ipro), & 213 & zint(2,2,kpk,ipro), & 214 & zgdept(2,2,kpk,ipro), & 215 & zgdepw(2,2,kpk,ipro) & 237 216 & ) 238 217 239 218 DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 240 219 iobs = jobs - prodatqc%nprofup 241 igrdi1(1,1,iobs) = prodatqc%mi(jobs,1)-1 242 igrdj1(1,1,iobs) = prodatqc%mj(jobs,1)-1 243 igrdi1(1,2,iobs) = prodatqc%mi(jobs,1)-1 244 igrdj1(1,2,iobs) = prodatqc%mj(jobs,1) 245 igrdi1(2,1,iobs) = prodatqc%mi(jobs,1) 246 igrdj1(2,1,iobs) = prodatqc%mj(jobs,1)-1 247 igrdi1(2,2,iobs) = prodatqc%mi(jobs,1) 248 igrdj1(2,2,iobs) = prodatqc%mj(jobs,1) 249 igrdi2(1,1,iobs) = prodatqc%mi(jobs,2)-1 250 igrdj2(1,1,iobs) = prodatqc%mj(jobs,2)-1 251 igrdi2(1,2,iobs) = prodatqc%mi(jobs,2)-1 252 igrdj2(1,2,iobs) = prodatqc%mj(jobs,2) 253 igrdi2(2,1,iobs) = prodatqc%mi(jobs,2) 254 igrdj2(2,1,iobs) = prodatqc%mj(jobs,2)-1 255 igrdi2(2,2,iobs) = prodatqc%mi(jobs,2) 256 igrdj2(2,2,iobs) = prodatqc%mj(jobs,2) 220 igrdi(1,1,iobs) = prodatqc%mi(jobs,kvar)-1 221 igrdj(1,1,iobs) = prodatqc%mj(jobs,kvar)-1 222 igrdi(1,2,iobs) = prodatqc%mi(jobs,kvar)-1 223 igrdj(1,2,iobs) = prodatqc%mj(jobs,kvar) 224 igrdi(2,1,iobs) = prodatqc%mi(jobs,kvar) 225 igrdj(2,1,iobs) = prodatqc%mj(jobs,kvar)-1 226 igrdi(2,2,iobs) = prodatqc%mi(jobs,kvar) 227 igrdj(2,2,iobs) = prodatqc%mj(jobs,kvar) 257 228 END DO 258 229 … … 261 232 zgdepw(:,:,:,:) = 0.0 262 233 263 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, plam1, zglam1 ) 264 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, pphi1, zgphi1 ) 265 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pmask1, zmask1 ) 266 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pvar1, zint1 ) 267 268 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, plam2, zglam2 ) 269 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, pphi2, zgphi2 ) 270 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pmask2, zmask2 ) 271 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pvar2, zint2 ) 272 273 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdept, zgdept ) 274 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdepw, zgdepw ) 234 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, plam, zglam ) 235 CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 236 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pmask, zmask ) 237 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pvar, zint ) 238 239 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdept, zgdept ) 240 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdepw, zgdepw ) 275 241 276 242 ! At the end of the day also get interpolated means 277 243 IF ( ld_dailyav .AND. idayend == 0 ) THEN 278 244 279 ALLOCATE( & 280 & zinm1(2,2,kpk,ipro), & 281 & zinm2(2,2,kpk,ipro) & 282 & ) 283 284 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, & 285 & prodatqc%vdmean(:,:,:,1), zinm1 ) 286 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, & 287 & prodatqc%vdmean(:,:,:,2), zinm2 ) 245 ALLOCATE( zinm(2,2,kpk,ipro) ) 246 247 CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, & 248 & prodatqc%vdmean(:,:,:,kvar), zinm ) 288 249 289 250 ENDIF … … 320 281 ! Horizontal weights 321 282 ! Masked values are calculated later. 322 IF ( prodatqc%npvend(jobs, 1) > 0 ) THEN283 IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN 323 284 324 285 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 325 & zglam1(:,:,iobs), zgphi1(:,:,iobs), & 326 & zmask1(:,:,1,iobs), zweig1, zmsk_1 ) 327 328 ENDIF 329 330 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 331 332 CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & 333 & zglam2(:,:,iobs), zgphi2(:,:,iobs), & 334 & zmask2(:,:,1,iobs), zweig2, zmsk_2) 335 336 ENDIF 337 338 IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 286 & zglam(:,:,iobs), zgphi(:,:,iobs), & 287 & zmask(:,:,1,iobs), zweig1, zmsk ) 288 289 ENDIF 290 291 IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN 339 292 340 293 zobsk(:) = obfillflt … … 346 299 347 300 ! vertically interpolate all 4 corners 348 ista = prodatqc%npvsta(jobs, 1)349 iend = prodatqc%npvend(jobs, 1)301 ista = prodatqc%npvsta(jobs,kvar) 302 iend = prodatqc%npvend(jobs,kvar) 350 303 inum_obs = iend - ista + 1 351 304 ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) … … 356 309 IF ( k1dint == 1 ) THEN 357 310 CALL obs_int_z1d_spl( kpk, & 358 & zinm 1(iin,ijn,:,iobs), &311 & zinm(iin,ijn,:,iobs), & 359 312 & zobs2k, zgdept(iin,ijn,:,iobs), & 360 & zmask 1(iin,ijn,:,iobs))313 & zmask(iin,ijn,:,iobs)) 361 314 ENDIF 362 315 363 316 CALL obs_level_search(kpk, & 364 317 & zgdept(iin,ijn,:,iobs), & 365 & inum_obs, prodatqc%var( 1)%vdep(ista:iend), &318 & inum_obs, prodatqc%var(kvar)%vdep(ista:iend), & 366 319 & iv_indic) 367 320 368 321 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 369 & prodatqc%var( 1)%vdep(ista:iend), &370 & zinm 1(iin,ijn,:,iobs), &322 & prodatqc%var(kvar)%vdep(ista:iend), & 323 & zinm(iin,ijn,:,iobs), & 371 324 & zobs2k, interp_corner(iin,ijn,:), & 372 325 & zgdept(iin,ijn,:,iobs), & 373 & zmask 1(iin,ijn,:,iobs))326 & zmask(iin,ijn,:,iobs)) 374 327 375 328 ENDDO … … 383 336 384 337 ! vertically interpolate all 4 corners 385 ista = prodatqc%npvsta(jobs, 1)386 iend = prodatqc%npvend(jobs, 1)338 ista = prodatqc%npvsta(jobs,kvar) 339 iend = prodatqc%npvend(jobs,kvar) 387 340 inum_obs = iend - ista + 1 388 341 ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) … … 392 345 IF ( k1dint == 1 ) THEN 393 346 CALL obs_int_z1d_spl( kpk, & 394 & zint 1(iin,ijn,:,iobs),&347 & zint(iin,ijn,:,iobs),& 395 348 & zobs2k, zgdept(iin,ijn,:,iobs), & 396 & zmask 1(iin,ijn,:,iobs))349 & zmask(iin,ijn,:,iobs)) 397 350 398 351 ENDIF … … 400 353 CALL obs_level_search(kpk, & 401 354 & zgdept(iin,ijn,:,iobs),& 402 & inum_obs, prodatqc%var( 1)%vdep(ista:iend), &355 & inum_obs, prodatqc%var(kvar)%vdep(ista:iend), & 403 356 & iv_indic) 404 357 405 358 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 406 & prodatqc%var( 1)%vdep(ista:iend), &407 & zint 1(iin,ijn,:,iobs), &359 & prodatqc%var(kvar)%vdep(ista:iend), & 360 & zint(iin,ijn,:,iobs), & 408 361 & zobs2k,interp_corner(iin,ijn,:), & 409 362 & zgdept(iin,ijn,:,iobs), & 410 & zmask 1(iin,ijn,:,iobs) )363 & zmask(iin,ijn,:,iobs) ) 411 364 412 365 ENDDO … … 432 385 DO ijn=1,2 433 386 434 depth_loop 1: DO ik=kpk,2,-1435 IF(zmask 1(iin,ijn,ik-1,iobs ) > 0.9 )THEN387 depth_loop: DO ik=kpk,2,-1 388 IF(zmask(iin,ijn,ik-1,iobs ) > 0.9 )THEN 436 389 437 390 zweig(iin,ijn,1) = & 438 391 & zweig1(iin,ijn,1) * & 439 392 & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & 440 & - prodatqc%var( 1)%vdep(iend)),0._wp)393 & - prodatqc%var(kvar)%vdep(iend)),0._wp) 441 394 442 EXIT depth_loop 1395 EXIT depth_loop 443 396 444 397 ENDIF 445 398 446 ENDDO depth_loop 1399 ENDDO depth_loop 447 400 448 401 ENDDO … … 450 403 451 404 CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & 452 & prodatqc%var( 1)%vmod(iend:iend) )405 & prodatqc%var(kvar)%vmod(iend:iend) ) 453 406 454 407 ! Set QC flag for any observations found below the bottom 455 408 ! needed as the check here is more strict than that in obs_prep 456 IF (sum(zweig) == 0.0_wp) prodatqc%var( 1)%nvqc(iend:iend)=4409 IF (sum(zweig) == 0.0_wp) prodatqc%var(kvar)%nvqc(iend:iend)=4 457 410 458 411 ENDDO … … 460 413 DEALLOCATE(interp_corner,iv_indic) 461 414 462 ENDIF 463 464 ! For the second variable 465 IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 466 467 zobsk(:) = obfillflt 468 469 IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 470 471 IF ( idayend == 0 ) THEN 472 ! Daily averaged data 473 474 ! vertically interpolate all 4 corners 475 ista = prodatqc%npvsta(jobs,2) 476 iend = prodatqc%npvend(jobs,2) 477 inum_obs = iend - ista + 1 478 ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs)) 479 480 DO iin=1,2 481 DO ijn=1,2 482 483 IF ( k1dint == 1 ) THEN 484 CALL obs_int_z1d_spl( kpk, & 485 & zinm2(iin,ijn,:,iobs), & 486 & zobs2k, zgdept(iin,ijn,:,iobs), & 487 & zmask2(iin,ijn,:,iobs)) 488 ENDIF 489 490 CALL obs_level_search(kpk, & 491 & zgdept(iin,ijn,:,iobs), & 492 & inum_obs, prodatqc%var(2)%vdep(ista:iend), & 493 & iv_indic) 494 495 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 496 & prodatqc%var(2)%vdep(ista:iend), & 497 & zinm2(iin,ijn,:,iobs), & 498 & zobs2k, interp_corner(iin,ijn,:), & 499 & zgdept(iin,ijn,:,iobs), & 500 & zmask2(iin,ijn,:,iobs)) 501 502 ENDDO 503 ENDDO 504 505 ENDIF !idayend 506 507 ELSE 508 509 ! Point data 510 511 ! vertically interpolate all 4 corners 512 ista = prodatqc%npvsta(jobs,2) 513 iend = prodatqc%npvend(jobs,2) 514 inum_obs = iend - ista + 1 515 ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs)) 516 DO iin=1,2 517 DO ijn=1,2 518 519 IF ( k1dint == 1 ) THEN 520 CALL obs_int_z1d_spl( kpk, & 521 & zint2(iin,ijn,:,iobs),& 522 & zobs2k, zgdept(iin,ijn,:,iobs), & 523 & zmask2(iin,ijn,:,iobs)) 524 525 ENDIF 526 527 CALL obs_level_search(kpk, & 528 & zgdept(iin,ijn,:,iobs),& 529 & inum_obs, prodatqc%var(2)%vdep(ista:iend), & 530 & iv_indic) 531 532 CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & 533 & prodatqc%var(2)%vdep(ista:iend), & 534 & zint2(iin,ijn,:,iobs), & 535 & zobs2k,interp_corner(iin,ijn,:), & 536 & zgdept(iin,ijn,:,iobs), & 537 & zmask2(iin,ijn,:,iobs) ) 538 539 ENDDO 540 ENDDO 541 542 ENDIF 543 544 !------------------------------------------------------------- 545 ! Compute the horizontal interpolation for every profile level 546 !------------------------------------------------------------- 547 548 DO ikn=1,inum_obs 549 iend=ista+ikn-1 550 551 zweig(:,:,1) = 0._wp 552 553 ! This code forces the horizontal weights to be 554 ! zero IF the observation is below the bottom of the 555 ! corners of the interpolation nodes, Or if it is in 556 ! the mask. This is important for observations near 557 ! steep bathymetry 558 DO iin=1,2 559 DO ijn=1,2 560 561 depth_loop2: DO ik=kpk,2,-1 562 IF(zmask2(iin,ijn,ik-1,iobs ) > 0.9 )THEN 563 564 zweig(iin,ijn,1) = & 565 & zweig2(iin,ijn,1) * & 566 & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & 567 & - prodatqc%var(2)%vdep(iend)),0._wp) 568 569 EXIT depth_loop2 570 571 ENDIF 572 573 ENDDO depth_loop2 574 575 ENDDO 576 ENDDO 577 578 CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & 579 & prodatqc%var(2)%vmod(iend:iend) ) 580 581 ! Set QC flag for any observations found below the bottom 582 ! needed as the check here is more strict than that in obs_prep 583 IF (sum(zweig) == 0.0_wp) prodatqc%var(2)%nvqc(iend:iend)=4 584 585 ENDDO 586 587 DEALLOCATE(interp_corner,iv_indic) 588 589 ENDIF 415 ENDIF 590 416 591 417 ENDDO 592 418 593 419 ! Deallocate the data for interpolation 594 DEALLOCATE( & 595 & igrdi1, & 596 & igrdi2, & 597 & igrdj1, & 598 & igrdj2, & 599 & zglam1, & 600 & zglam2, & 601 & zgphi1, & 602 & zgphi2, & 603 & zmask1, & 604 & zmask2, & 605 & zint1, & 606 & zint2, & 420 DEALLOCATE( & 421 & igrdi, & 422 & igrdj, & 423 & zglam, & 424 & zgphi, & 425 & zmask, & 426 & zint, & 607 427 & zgdept, & 608 428 & zgdepw & … … 611 431 ! At the end of the day also get interpolated means 612 432 IF ( ld_dailyav .AND. idayend == 0 ) THEN 613 DEALLOCATE( & 614 & zinm1, & 615 & zinm2 & 616 & ) 433 DEALLOCATE( zinm ) 617 434 ENDIF 618 435 619 prodatqc%nprofup = prodatqc%nprofup + ipro 436 IF ( kvar == prodatqc%nvar ) THEN 437 prodatqc%nprofup = prodatqc%nprofup + ipro 438 ENDIF 620 439 621 440 END SUBROUTINE obs_prof_opt -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/OBS/obs_prep.F90
r12489 r14058 241 241 242 242 243 SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var 1, ld_var2, &243 SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var, & 244 244 & kpi, kpj, kpk, & 245 & zmask 1, pglam1, pgphi1, zmask2, pglam2, pgphi2, &245 & zmask, pglam, pgphi, & 246 246 & ld_nea, ld_bound_reject, Kmm, kdailyavtypes, kqc_cutoff ) 247 247 … … 269 269 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 270 270 TYPE(obs_prof), INTENT(INOUT) :: prodatqc ! Subset of profile data not failing screening 271 LOGICAL, INTENT(IN) :: ld_var1 ! Observed variables switches272 LOGICAL, INTENT(IN) :: ld_var2271 LOGICAL, DIMENSION(profdata%nvar), INTENT(IN) :: & 272 & ld_var ! Observed variables switches 273 273 LOGICAL, INTENT(IN) :: ld_nea ! Switch for rejecting observation near land 274 274 LOGICAL, INTENT(IN) :: ld_bound_reject ! Switch for rejecting observations near the boundary … … 277 277 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 278 278 & kdailyavtypes ! Types for daily averages 279 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 280 & zmask1, & 281 & zmask2 282 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 283 & pglam1, & 284 & pglam2, & 285 & pgphi1, & 286 & pgphi2 279 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: & 280 & zmask 281 REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: & 282 & pglam, & 283 & pgphi 287 284 INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff ! cut off for QC value 288 285 … … 295 292 INTEGER :: imin0 296 293 INTEGER :: icycle ! Current assimilation cycle 297 ! Counters for observations that are 298 INTEGER :: iotdobs ! - outside time domain 299 INTEGER :: iosdv1obs ! - outside space domain (variable 1) 300 INTEGER :: iosdv2obs ! - outside space domain (variable 2) 301 INTEGER :: ilanv1obs ! - within a model land cell (variable 1) 302 INTEGER :: ilanv2obs ! - within a model land cell (variable 2) 303 INTEGER :: inlav1obs ! - close to land (variable 1) 304 INTEGER :: inlav2obs ! - close to land (variable 2) 305 INTEGER :: ibdyv1obs ! - boundary (variable 1) 306 INTEGER :: ibdyv2obs ! - boundary (variable 2) 307 INTEGER :: igrdobs ! - fail the grid search 308 INTEGER :: iuvchku ! - reject u if v rejected and vice versa 309 INTEGER :: iuvchkv ! 310 ! Global counters for observations that are 311 INTEGER :: iotdobsmpp ! - outside time domain 312 INTEGER :: iosdv1obsmpp ! - outside space domain (variable 1) 313 INTEGER :: iosdv2obsmpp ! - outside space domain (variable 2) 314 INTEGER :: ilanv1obsmpp ! - within a model land cell (variable 1) 315 INTEGER :: ilanv2obsmpp ! - within a model land cell (variable 2) 316 INTEGER :: inlav1obsmpp ! - close to land (variable 1) 317 INTEGER :: inlav2obsmpp ! - close to land (variable 2) 318 INTEGER :: ibdyv1obsmpp ! - boundary (variable 1) 319 INTEGER :: ibdyv2obsmpp ! - boundary (variable 2) 320 INTEGER :: igrdobsmpp ! - fail the grid search 321 INTEGER :: iuvchkumpp ! - reject var1 if var2 rejected and vice versa 322 INTEGER :: iuvchkvmpp ! 294 ! Counters for observations that are 295 INTEGER :: iotdobs ! - outside time domain 296 INTEGER, DIMENSION(profdata%nvar) :: iosdvobs ! - outside space domain 297 INTEGER, DIMENSION(profdata%nvar) :: ilanvobs ! - within a model land cell 298 INTEGER, DIMENSION(profdata%nvar) :: inlavobs ! - close to land 299 INTEGER, DIMENSION(profdata%nvar) :: ibdyvobs ! - boundary 300 INTEGER :: igrdobs ! - fail the grid search 301 INTEGER :: iuvchku ! - reject UVEL if VVEL rejected 302 INTEGER :: iuvchkv ! - reject VVEL if UVEL rejected 303 ! Global counters for observations that are 304 INTEGER :: iotdobsmpp ! - outside time domain 305 INTEGER, DIMENSION(profdata%nvar) :: iosdvobsmpp ! - outside space domain 306 INTEGER, DIMENSION(profdata%nvar) :: ilanvobsmpp ! - within a model land cell 307 INTEGER, DIMENSION(profdata%nvar) :: inlavobsmpp ! - close to land 308 INTEGER, DIMENSION(profdata%nvar) :: ibdyvobsmpp ! - boundary 309 INTEGER :: igrdobsmpp ! - fail the grid search 310 INTEGER :: iuvchkumpp ! - reject UVEL if VVEL rejected 311 INTEGER :: iuvchkvmpp ! - reject VVEL if UVEL rejected 323 312 TYPE(obs_prof_valid) :: llvalid ! Profile selection 324 313 TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 325 & llvvalid ! var 1,var2selection314 & llvvalid ! var selection 326 315 INTEGER :: jvar ! Variable loop variable 327 316 INTEGER :: jobs ! Obs. loop variable 328 317 INTEGER :: jstp ! Time loop variable 329 318 INTEGER :: inrc ! Time index variable 319 CHARACTER(LEN=256) :: cout1 ! Diagnostic output line 320 CHARACTER(LEN=256) :: cout2 ! Diagnostic output line 330 321 !!---------------------------------------------------------------------- 331 322 … … 342 333 icycle = nn_no ! Assimilation cycle 343 334 344 ! Diagnotics counters for various failures. 345 346 iotdobs = 0 347 igrdobs = 0 348 iosdv1obs = 0 349 iosdv2obs = 0 350 ilanv1obs = 0 351 ilanv2obs = 0 352 inlav1obs = 0 353 inlav2obs = 0 354 ibdyv1obs = 0 355 ibdyv2obs = 0 356 iuvchku = 0 357 iuvchkv = 0 335 ! Diagnostic counters for various failures. 336 337 iotdobs = 0 338 igrdobs = 0 339 iosdvobs(:) = 0 340 ilanvobs(:) = 0 341 inlavobs(:) = 0 342 ibdyvobs(:) = 0 343 iuvchku = 0 344 iuvchkv = 0 358 345 359 346 … … 388 375 ! ----------------------------------------------------------------------- 389 376 390 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,1), profdata%mj(:,1), &391 & profdata%nqc, igrdobs )392 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,2), profdata%mj(:,2), &393 & profdata%nqc, igrdobs )377 DO jvar = 1, profdata%nvar 378 CALL obs_coo_grd( profdata%nprof, profdata%mi(:,jvar), profdata%mj(:,jvar), & 379 & profdata%nqc, igrdobs ) 380 END DO 394 381 395 382 CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) … … 406 393 ! ----------------------------------------------------------------------- 407 394 408 ! Variable 1 409 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(1), & 410 & profdata%npvsta(:,1), profdata%npvend(:,1), & 411 & jpi, jpj, & 412 & jpk, & 413 & profdata%mi, profdata%mj, & 414 & profdata%var(1)%mvk, & 415 & profdata%rlam, profdata%rphi, & 416 & profdata%var(1)%vdep, & 417 & pglam1, pgphi1, & 418 & gdept_1d, zmask1, & 419 & profdata%nqc, profdata%var(1)%nvqc, & 420 & iosdv1obs, ilanv1obs, & 421 & inlav1obs, ld_nea, & 422 & ibdyv1obs, ld_bound_reject, & 423 & iqc_cutoff, Kmm ) 424 425 CALL obs_mpp_sum_integer( iosdv1obs, iosdv1obsmpp ) 426 CALL obs_mpp_sum_integer( ilanv1obs, ilanv1obsmpp ) 427 CALL obs_mpp_sum_integer( inlav1obs, inlav1obsmpp ) 428 CALL obs_mpp_sum_integer( ibdyv1obs, ibdyv1obsmpp ) 429 430 ! Variable 2 431 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(2), & 432 & profdata%npvsta(:,2), profdata%npvend(:,2), & 433 & jpi, jpj, & 434 & jpk, & 435 & profdata%mi, profdata%mj, & 436 & profdata%var(2)%mvk, & 437 & profdata%rlam, profdata%rphi, & 438 & profdata%var(2)%vdep, & 439 & pglam2, pgphi2, & 440 & gdept_1d, zmask2, & 441 & profdata%nqc, profdata%var(2)%nvqc, & 442 & iosdv2obs, ilanv2obs, & 443 & inlav2obs, ld_nea, & 444 & ibdyv2obs, ld_bound_reject, & 445 & iqc_cutoff, Kmm ) 446 447 CALL obs_mpp_sum_integer( iosdv2obs, iosdv2obsmpp ) 448 CALL obs_mpp_sum_integer( ilanv2obs, ilanv2obsmpp ) 449 CALL obs_mpp_sum_integer( inlav2obs, inlav2obsmpp ) 450 CALL obs_mpp_sum_integer( ibdyv2obs, ibdyv2obsmpp ) 395 DO jvar = 1, profdata%nvar 396 CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(jvar), & 397 & profdata%npvsta(:,jvar), profdata%npvend(:,jvar), & 398 & jpi, jpj, & 399 & jpk, & 400 & profdata%mi, profdata%mj, & 401 & profdata%var(jvar)%mvk, & 402 & profdata%rlam, profdata%rphi, & 403 & profdata%var(jvar)%vdep, & 404 & pglam(:,:,jvar), pgphi(:,:,jvar), & 405 & gdept_1d, zmask(:,:,:,jvar), & 406 & profdata%nqc, profdata%var(jvar)%nvqc, & 407 & iosdvobs(jvar), ilanvobs(jvar), & 408 & inlavobs(jvar), ld_nea, & 409 & ibdyvobs(jvar), ld_bound_reject, & 410 & iqc_cutoff, Kmm ) 411 412 CALL obs_mpp_sum_integer( iosdvobs(jvar), iosdvobsmpp(jvar) ) 413 CALL obs_mpp_sum_integer( ilanvobs(jvar), ilanvobsmpp(jvar) ) 414 CALL obs_mpp_sum_integer( inlavobs(jvar), inlavobsmpp(jvar) ) 415 CALL obs_mpp_sum_integer( ibdyvobs(jvar), ibdyvobsmpp(jvar) ) 416 END DO 451 417 452 418 ! ----------------------------------------------------------------------- … … 499 465 500 466 WRITE(numout,*) 501 WRITE(numout,*) ' Profiles outside time domain = ', &467 WRITE(numout,*) ' Profiles outside time domain = ', & 502 468 & iotdobsmpp 503 WRITE(numout,*) ' Remaining profiles that failed grid search = ', &469 WRITE(numout,*) ' Remaining profiles that failed grid search = ', & 504 470 & igrdobsmpp 505 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data outside space domain = ', & 506 & iosdv1obsmpp 507 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data at land points = ', & 508 & ilanv1obsmpp 509 IF (ld_nea) THEN 510 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (removed) = ',& 511 & inlav1obsmpp 512 ELSE 513 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (kept) = ',& 514 & inlav1obsmpp 515 ENDIF 516 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 517 WRITE(numout,*) ' U observation rejected since V rejected = ', & 518 & iuvchku 519 ENDIF 520 WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near open boundary (removed) = ',& 521 & ibdyv1obsmpp 522 WRITE(numout,*) ' '//prodatqc%cvars(1)//' data accepted = ', & 523 & prodatqc%nvprotmpp(1) 524 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data outside space domain = ', & 525 & iosdv2obsmpp 526 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data at land points = ', & 527 & ilanv2obsmpp 528 IF (ld_nea) THEN 529 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (removed) = ',& 530 & inlav2obsmpp 531 ELSE 532 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (kept) = ',& 533 & inlav2obsmpp 534 ENDIF 535 IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 536 WRITE(numout,*) ' V observation rejected since U rejected = ', & 537 & iuvchkv 538 ENDIF 539 WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near open boundary (removed) = ',& 540 & ibdyv2obsmpp 541 WRITE(numout,*) ' '//prodatqc%cvars(2)//' data accepted = ', & 542 & prodatqc%nvprotmpp(2) 471 DO jvar = 1, profdata%nvar 472 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data outside space domain = ', & 473 & iosdvobsmpp(jvar) 474 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data at land points = ', & 475 & ilanvobsmpp(jvar) 476 IF (ld_nea) THEN 477 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (removed) = ',& 478 & inlavobsmpp(jvar) 479 ELSE 480 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (kept) = ',& 481 & inlavobsmpp(jvar) 482 ENDIF 483 IF ( TRIM(profdata%cvars(jvar)) == 'UVEL' ) THEN 484 WRITE(numout,*) ' U observation rejected since V rejected = ', & 485 & iuvchku 486 ELSE IF ( TRIM(profdata%cvars(jvar)) == 'VVEL' ) THEN 487 WRITE(numout,*) ' V observation rejected since U rejected = ', & 488 & iuvchkv 489 ENDIF 490 WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near open boundary (removed) = ',& 491 & ibdyvobsmpp(jvar) 492 WRITE(numout,*) ' '//prodatqc%cvars(jvar)//' data accepted = ', & 493 & prodatqc%nvprotmpp(jvar) 494 END DO 543 495 544 496 WRITE(numout,*) 545 497 WRITE(numout,*) ' Number of observations per time step :' 546 498 WRITE(numout,*) 547 WRITE(numout,'(10X,A,5X,A,5X,A,A)')'Time step','Profiles', & 548 & ' '//prodatqc%cvars(1)//' ', & 549 & ' '//prodatqc%cvars(2)//' ' 550 WRITE(numout,998) 499 WRITE(cout1,'(10X,A9,5X,A8)') 'Time step', 'Profiles' 500 WRITE(cout2,'(10X,A9,5X,A8)') '---------', '--------' 501 DO jvar = 1, prodatqc%nvar 502 WRITE(cout1,'(A,5X,A11)') TRIM(cout1), TRIM(prodatqc%cvars(jvar)) 503 WRITE(cout2,'(A,5X,A11)') TRIM(cout2), '-----------' 504 END DO 505 WRITE(numout,*) cout1 506 WRITE(numout,*) cout2 551 507 ENDIF 552 508 … … 575 531 DO jstp = nit000 - 1, nitend 576 532 inrc = jstp - nit000 + 2 577 WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 578 & prodatqc%nvstpmpp(inrc,1), & 579 & prodatqc%nvstpmpp(inrc,2) 533 WRITE(cout1,'(10X,I9,5X,I8)') jstp, prodatqc%npstpmpp(inrc) 534 DO jvar = 1, prodatqc%nvar 535 WRITE(cout1,'(A,5X,I11)') TRIM(cout1), prodatqc%nvstpmpp(inrc,jvar) 536 END DO 537 WRITE(numout,*) cout1 580 538 END DO 581 539 ENDIF 582 583 998 FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------')584 999 FORMAT(10X,I9,5X,I8,5X,I11,5X,I8)585 540 586 541 END SUBROUTINE obs_pre_prof -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/OBS/obs_read_prof.F90
r13226 r14058 45 45 SUBROUTINE obs_rea_prof( profdata, knumfiles, cdfilenames, & 46 46 & kvars, kextr, kstp, ddobsini, ddobsend, & 47 & ldvar 1, ldvar2, ldignmis, ldsatt, &48 & ldmod, kdailyavtypes )47 & ldvar, ldignmis, ldsatt, & 48 & ldmod, cdvars, kdailyavtypes ) 49 49 !!--------------------------------------------------------------------- 50 50 !! … … 74 74 INTEGER, INTENT(IN) :: kextr ! Number of extra fields for each var 75 75 INTEGER, INTENT(IN) :: kstp ! Ocean time-step index 76 LOGICAL, INTENT(IN) :: ldvar1 ! Observed variables switches 77 LOGICAL, INTENT(IN) :: ldvar2 76 LOGICAL, DIMENSION(kvars), INTENT(IN) :: ldvar ! Observed variables switches 78 77 LOGICAL, INTENT(IN) :: ldignmis ! Ignore missing files 79 78 LOGICAL, INTENT(IN) :: ldsatt ! Compute salinity at all temperature points … … 81 80 REAL(dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS 82 81 REAL(dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS 82 CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars 83 83 INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 84 84 & kdailyavtypes ! Types of daily average observations … … 87 87 CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_prof' 88 88 CHARACTER(len=8) :: clrefdate 89 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars 89 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvarsin 90 90 INTEGER :: jvar 91 91 INTEGER :: ji … … 105 105 INTEGER :: iprof 106 106 INTEGER :: iproftot 107 INTEGER :: ivar1t0 108 INTEGER :: ivar2t0 109 INTEGER :: ivar1t 110 INTEGER :: ivar2t 107 INTEGER, DIMENSION(kvars) :: ivart0 108 INTEGER, DIMENSION(kvars) :: ivart 111 109 INTEGER :: ip3dt 112 110 INTEGER :: ios 113 111 INTEGER :: ioserrcount 114 INTEGER :: ivar1tmpp 115 INTEGER :: ivar2tmpp 112 INTEGER, DIMENSION(kvars) :: ivartmpp 116 113 INTEGER :: ip3dtmpp 117 114 INTEGER :: itype 118 115 INTEGER, DIMENSION(knumfiles) :: & 119 116 & irefdate 120 INTEGER, DIMENSION(ntyp1770+1) :: & 121 & itypvar1, & 122 & itypvar1mpp, & 123 & itypvar2, & 124 & itypvar2mpp 117 INTEGER, DIMENSION(ntyp1770+1,kvars) :: & 118 & itypvar, & 119 & itypvarmpp 120 INTEGER, DIMENSION(:,:), ALLOCATABLE :: & 121 & iobsi, & 122 & iobsj, & 123 & iproc 125 124 INTEGER, DIMENSION(:), ALLOCATABLE :: & 126 & iobsi1, &127 & iobsj1, &128 & iproc1, &129 & iobsi2, &130 & iobsj2, &131 & iproc2, &132 125 & iindx, & 133 126 & ifileidx, & … … 147 140 LOGICAL :: llvalprof 148 141 LOGICAL :: lldavtimset 142 LOGICAL :: llcycle 149 143 TYPE(obfbdata), POINTER, DIMENSION(:) :: & 150 144 & inpfiles … … 152 146 ! Local initialization 153 147 iprof = 0 154 ivar1t0 = 0 155 ivar2t0 = 0 148 ivart0(:) = 0 156 149 ip3dt = 0 157 150 … … 219 212 & ldgrid = .TRUE. ) 220 213 221 IF ( inpfiles(jj)%nvar < 2) THEN214 IF ( inpfiles(jj)%nvar /= kvars ) THEN 222 215 CALL ctl_stop( 'Feedback format error: ', & 223 & ' less than 2vars in profile file' )216 & ' unexpected number of vars in profile file' ) 224 217 ENDIF 225 218 … … 229 222 230 223 IF ( jj == 1 ) THEN 231 ALLOCATE( clvars ( inpfiles(jj)%nvar ) )224 ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) 232 225 DO ji = 1, inpfiles(jj)%nvar 233 clvars(ji) = inpfiles(jj)%cname(ji) 226 clvarsin(ji) = inpfiles(jj)%cname(ji) 227 IF ( clvarsin(ji) /= cdvars(ji) ) THEN 228 CALL ctl_stop( 'Feedback file variables do not match', & 229 & ' expected variable names for this type' ) 230 ENDIF 234 231 END DO 235 232 ELSE 236 233 DO ji = 1, inpfiles(jj)%nvar 237 IF ( inpfiles(jj)%cname(ji) /= clvars (ji) ) THEN234 IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN 238 235 CALL ctl_stop( 'Feedback file variables not consistent', & 239 236 & ' with previous files for this type' ) … … 308 305 DO ji = 1, inpfiles(jj)%nobs 309 306 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 310 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 311 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 307 llcycle = .TRUE. 308 DO jvar = 1, kvars 309 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 310 llcycle = .FALSE. 311 EXIT 312 ENDIF 313 END DO 314 IF ( llcycle ) CYCLE 312 315 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 313 316 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 317 320 ALLOCATE( zlam(inowin) ) 318 321 ALLOCATE( zphi(inowin) ) 319 ALLOCATE( iobsi1(inowin) ) 320 ALLOCATE( iobsj1(inowin) ) 321 ALLOCATE( iproc1(inowin) ) 322 ALLOCATE( iobsi2(inowin) ) 323 ALLOCATE( iobsj2(inowin) ) 324 ALLOCATE( iproc2(inowin) ) 322 ALLOCATE( iobsi(inowin,kvars) ) 323 ALLOCATE( iobsj(inowin,kvars) ) 324 ALLOCATE( iproc(inowin,kvars) ) 325 325 inowin = 0 326 326 DO ji = 1, inpfiles(jj)%nobs 327 327 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 328 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 329 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 328 llcycle = .TRUE. 329 DO jvar = 1, kvars 330 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 331 llcycle = .FALSE. 332 EXIT 333 ENDIF 334 END DO 335 IF ( llcycle ) CYCLE 330 336 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 331 337 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 336 342 END DO 337 343 338 IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN 339 CALL obs_grid_search( inowin, zlam, zphi, iobsi1, iobsj1, & 340 & iproc1, 'T' ) 341 iobsi2(:) = iobsi1(:) 342 iobsj2(:) = iobsj1(:) 343 iproc2(:) = iproc1(:) 344 ELSEIF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN 345 CALL obs_grid_search( inowin, zlam, zphi, iobsi1, iobsj1, & 346 & iproc1, 'U' ) 347 CALL obs_grid_search( inowin, zlam, zphi, iobsi2, iobsj2, & 348 & iproc2, 'V' ) 344 ! Assume anything other than velocity is on T grid 345 IF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN 346 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & 347 & iproc(:,1), 'U' ) 348 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,2), iobsj(:,2), & 349 & iproc(:,2), 'V' ) 350 ELSE 351 CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & 352 & iproc(:,1), 'T' ) 353 IF ( kvars > 1 ) THEN 354 DO jvar = 2, kvars 355 iobsi(:,jvar) = iobsi(:,1) 356 iobsj(:,jvar) = iobsj(:,1) 357 iproc(:,jvar) = iproc(:,1) 358 END DO 359 ENDIF 349 360 ENDIF 350 361 … … 352 363 DO ji = 1, inpfiles(jj)%nobs 353 364 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 354 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 355 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 365 llcycle = .TRUE. 366 DO jvar = 1, kvars 367 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 368 llcycle = .FALSE. 369 EXIT 370 ENDIF 371 END DO 372 IF ( llcycle ) CYCLE 356 373 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 357 374 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 358 375 inowin = inowin + 1 359 inpfiles(jj)%iproc(ji,1) = iproc1(inowin) 360 inpfiles(jj)%iobsi(ji,1) = iobsi1(inowin) 361 inpfiles(jj)%iobsj(ji,1) = iobsj1(inowin) 362 inpfiles(jj)%iproc(ji,2) = iproc2(inowin) 363 inpfiles(jj)%iobsi(ji,2) = iobsi2(inowin) 364 inpfiles(jj)%iobsj(ji,2) = iobsj2(inowin) 365 IF ( inpfiles(jj)%iproc(ji,1) /= & 366 & inpfiles(jj)%iproc(ji,2) ) THEN 367 CALL ctl_stop( 'Error in obs_read_prof:', & 368 & 'var1 and var2 observation on different processors') 376 DO jvar = 1, kvars 377 inpfiles(jj)%iproc(ji,jvar) = iproc(inowin,jvar) 378 inpfiles(jj)%iobsi(ji,jvar) = iobsi(inowin,jvar) 379 inpfiles(jj)%iobsj(ji,jvar) = iobsj(inowin,jvar) 380 END DO 381 IF ( kvars > 1 ) THEN 382 DO jvar = 2, kvars 383 IF ( inpfiles(jj)%iproc(ji,jvar) /= & 384 & inpfiles(jj)%iproc(ji,1) ) THEN 385 CALL ctl_stop( 'Error in obs_read_prof:', & 386 & 'observation on different processors for different vars') 387 ENDIF 388 END DO 369 389 ENDIF 370 390 ENDIF 371 391 END DO 372 DEALLOCATE( zlam, zphi, iobsi 1, iobsj1, iproc1, iobsi2, iobsj2, iproc2)392 DEALLOCATE( zlam, zphi, iobsi, iobsj, iproc ) 373 393 374 394 DO ji = 1, inpfiles(jj)%nobs 375 395 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 376 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 377 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 396 llcycle = .TRUE. 397 DO jvar = 1, kvars 398 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 399 llcycle = .FALSE. 400 EXIT 401 ENDIF 402 END DO 403 IF ( llcycle ) CYCLE 378 404 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 379 405 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 384 410 ENDIF 385 411 llvalprof = .FALSE. 386 IF ( ldvar1 ) THEN 387 loop_t_count : DO ij = 1,inpfiles(jj)%nlev 388 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 389 & CYCLE 390 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 391 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 392 ivar1t0 = ivar1t0 + 1 393 ENDIF 394 END DO loop_t_count 395 ENDIF 396 IF ( ldvar2 ) THEN 397 loop_s_count : DO ij = 1,inpfiles(jj)%nlev 398 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 399 & CYCLE 400 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 401 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 402 ivar2t0 = ivar2t0 + 1 403 ENDIF 404 END DO loop_s_count 405 ENDIF 406 loop_p_count : DO ij = 1,inpfiles(jj)%nlev 412 DO jvar = 1, kvars 413 IF ( ldvar(jvar) ) THEN 414 DO ij = 1,inpfiles(jj)%nlev 415 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 416 & CYCLE 417 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 418 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 419 ivart0(jvar) = ivart0(jvar) + 1 420 ENDIF 421 END DO 422 ENDIF 423 END DO 424 DO ij = 1,inpfiles(jj)%nlev 407 425 IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 408 426 & CYCLE 409 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. &410 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. &411 & ldvar1 ) .OR. &412 & ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. &413 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. &414 & ldvar2 ) ) THEN415 ip3dt = ip3dt + 1416 llvalprof = .TRUE.417 END IF418 END DO loop_p_count427 DO jvar = 1, kvars 428 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 429 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 430 & ldvar(jvar) ) ) THEN 431 ip3dt = ip3dt + 1 432 llvalprof = .TRUE. 433 EXIT 434 ENDIF 435 END DO 436 END DO 419 437 420 438 IF ( llvalprof ) iprof = iprof + 1 … … 438 456 DO ji = 1, inpfiles(jj)%nobs 439 457 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 440 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 441 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 458 llcycle = .TRUE. 459 DO jvar = 1, kvars 460 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 461 llcycle = .FALSE. 462 EXIT 463 ENDIF 464 END DO 465 IF ( llcycle ) CYCLE 442 466 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 443 467 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 453 477 DO ji = 1, inpfiles(jj)%nobs 454 478 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 455 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 456 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 479 llcycle = .TRUE. 480 DO jvar = 1, kvars 481 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 482 llcycle = .FALSE. 483 EXIT 484 ENDIF 485 END DO 486 IF ( llcycle ) CYCLE 457 487 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & 458 488 & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN … … 470 500 iv3dt(:) = -1 471 501 IF (ldsatt) THEN 472 iv3dt(1) = ip3dt 473 iv3dt(2) = ip3dt 502 iv3dt(:) = ip3dt 474 503 ELSE 475 iv3dt(1) = ivar1t0 476 iv3dt(2) = ivar2t0 504 iv3dt(:) = ivart0(:) 477 505 ENDIF 478 506 CALL obs_prof_alloc( profdata, kvars, kextr, iprof, iv3dt, & … … 483 511 profdata%nprof = 0 484 512 profdata%nvprot(:) = 0 485 profdata%cvars(:) = clvars (:)513 profdata%cvars(:) = clvarsin(:) 486 514 iprof = 0 487 515 488 516 ip3dt = 0 489 ivar1t = 0 490 ivar2t = 0 491 itypvar1 (:) = 0 492 itypvar1mpp(:) = 0 493 494 itypvar2 (:) = 0 495 itypvar2mpp(:) = 0 517 ivart(:) = 0 518 itypvar (:,:) = 0 519 itypvarmpp(:,:) = 0 496 520 497 521 ioserrcount = 0 … … 501 525 ji = iprofidx(iindx(jk)) 502 526 503 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 504 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 505 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 527 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 528 llcycle = .TRUE. 529 DO jvar = 1, kvars 530 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 531 llcycle = .FALSE. 532 EXIT 533 ENDIF 534 END DO 535 IF ( llcycle ) CYCLE 506 536 507 537 IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & … … 519 549 520 550 IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 521 IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & 522 & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE 551 llcycle = .TRUE. 552 DO jvar = 1, kvars 553 IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 554 llcycle = .FALSE. 555 EXIT 556 ENDIF 557 END DO 558 IF ( llcycle ) CYCLE 523 559 524 560 loop_prof : DO ij = 1, inpfiles(jj)%nlev … … 527 563 & CYCLE 528 564 529 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 530 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 531 532 llvalprof = .TRUE. 533 EXIT loop_prof 534 535 ENDIF 536 537 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 538 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 539 540 llvalprof = .TRUE. 541 EXIT loop_prof 542 543 ENDIF 565 DO jvar = 1, kvars 566 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 567 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 568 569 llvalprof = .TRUE. 570 EXIT loop_prof 571 572 ENDIF 573 END DO 544 574 545 575 END DO loop_prof … … 573 603 574 604 ! Coordinate search parameters 575 profdata%mi (iprof,1) = inpfiles(jj)%iobsi(ji,1)576 profdata%mj (iprof,1) = inpfiles(jj)%iobsj(ji,1)577 profdata%mi (iprof,2) = inpfiles(jj)%iobsi(ji,2)578 profdata%mj (iprof,2) = inpfiles(jj)%iobsj(ji,2)605 DO jvar = 1, kvars 606 profdata%mi (iprof,jvar) = inpfiles(jj)%iobsi(ji,jvar) 607 profdata%mj (iprof,jvar) = inpfiles(jj)%iobsj(ji,jvar) 608 END DO 579 609 580 610 ! Profile WMO number … … 616 646 IF (ldsatt) THEN 617 647 618 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 619 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 620 & ldvar1 ) .OR. & 621 & ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 622 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 623 & ldvar2 ) ) THEN 624 ip3dt = ip3dt + 1 625 ELSE 626 CYCLE 648 DO jvar = 1, kvars 649 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 650 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 651 & ldvar(jvar) ) ) THEN 652 ip3dt = ip3dt + 1 653 EXIT 654 ELSE IF ( jvar == kvars ) THEN 655 CYCLE loop_p 656 ENDIF 657 END DO 658 659 ENDIF 660 661 DO jvar = 1, kvars 662 663 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 664 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 665 & ldvar(jvar) ) .OR. ldsatt ) THEN 666 667 IF (ldsatt) THEN 668 669 ivart(jvar) = ip3dt 670 671 ELSE 672 673 ivart(jvar) = ivart(jvar) + 1 674 675 ENDIF 676 677 ! Depth of jvar observation 678 profdata%var(jvar)%vdep(ivart(jvar)) = & 679 & inpfiles(jj)%pdep(ij,ji) 680 681 ! Depth of jvar observation QC 682 profdata%var(jvar)%idqc(ivart(jvar)) = & 683 & inpfiles(jj)%idqc(ij,ji) 684 685 ! Depth of jvar observation QC flags 686 profdata%var(jvar)%idqcf(:,ivart(jvar)) = & 687 & inpfiles(jj)%idqcf(:,ij,ji) 688 689 ! Profile index 690 profdata%var(jvar)%nvpidx(ivart(jvar)) = iprof 691 692 ! Vertical index in original profile 693 profdata%var(jvar)%nvlidx(ivart(jvar)) = ij 694 695 ! Profile jvar value 696 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 697 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 698 profdata%var(jvar)%vobs(ivart(jvar)) = & 699 & inpfiles(jj)%pob(ij,ji,jvar) 700 IF ( ldmod ) THEN 701 profdata%var(jvar)%vmod(ivart(jvar)) = & 702 & inpfiles(jj)%padd(ij,ji,1,jvar) 703 ENDIF 704 ! Count number of profile var1 data as function of type 705 itypvar( profdata%ntyp(iprof) + 1, jvar ) = & 706 & itypvar( profdata%ntyp(iprof) + 1, jvar ) + 1 707 ELSE 708 profdata%var(jvar)%vobs(ivart(jvar)) = fbrmdi 709 ENDIF 710 711 ! Profile jvar qc 712 profdata%var(jvar)%nvqc(ivart(jvar)) = & 713 & inpfiles(jj)%ivlqc(ij,ji,jvar) 714 715 ! Profile jvar qc flags 716 profdata%var(jvar)%nvqcf(:,ivart(jvar)) = & 717 & inpfiles(jj)%ivlqcf(:,ij,ji,jvar) 718 719 ! Profile insitu T value 720 IF ( TRIM( inpfiles(jj)%cname(jvar) ) == 'POTM' ) THEN 721 profdata%var(jvar)%vext(ivart(jvar),1) = & 722 & inpfiles(jj)%pext(ij,ji,1) 723 ENDIF 724 627 725 ENDIF 628 629 ENDIF 630 631 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 632 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 633 & ldvar1 ) .OR. ldsatt ) THEN 634 635 IF (ldsatt) THEN 636 637 ivar1t = ip3dt 638 639 ELSE 640 641 ivar1t = ivar1t + 1 642 643 ENDIF 644 645 ! Depth of var1 observation 646 profdata%var(1)%vdep(ivar1t) = & 647 & inpfiles(jj)%pdep(ij,ji) 648 649 ! Depth of var1 observation QC 650 profdata%var(1)%idqc(ivar1t) = & 651 & inpfiles(jj)%idqc(ij,ji) 652 653 ! Depth of var1 observation QC flags 654 profdata%var(1)%idqcf(:,ivar1t) = & 655 & inpfiles(jj)%idqcf(:,ij,ji) 656 657 ! Profile index 658 profdata%var(1)%nvpidx(ivar1t) = iprof 659 660 ! Vertical index in original profile 661 profdata%var(1)%nvlidx(ivar1t) = ij 662 663 ! Profile var1 value 664 IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & 665 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 666 profdata%var(1)%vobs(ivar1t) = & 667 & inpfiles(jj)%pob(ij,ji,1) 668 IF ( ldmod ) THEN 669 profdata%var(1)%vmod(ivar1t) = & 670 & inpfiles(jj)%padd(ij,ji,1,1) 671 ENDIF 672 ! Count number of profile var1 data as function of type 673 itypvar1( profdata%ntyp(iprof) + 1 ) = & 674 & itypvar1( profdata%ntyp(iprof) + 1 ) + 1 675 ELSE 676 profdata%var(1)%vobs(ivar1t) = fbrmdi 677 ENDIF 678 679 ! Profile var1 qc 680 profdata%var(1)%nvqc(ivar1t) = & 681 & inpfiles(jj)%ivlqc(ij,ji,1) 682 683 ! Profile var1 qc flags 684 profdata%var(1)%nvqcf(:,ivar1t) = & 685 & inpfiles(jj)%ivlqcf(:,ij,ji,1) 686 687 ! Profile insitu T value 688 IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN 689 profdata%var(1)%vext(ivar1t,1) = & 690 & inpfiles(jj)%pext(ij,ji,1) 691 ENDIF 692 693 ENDIF 694 695 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & 696 & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 697 & ldvar2 ) .OR. ldsatt ) THEN 698 699 IF (ldsatt) THEN 700 701 ivar2t = ip3dt 702 703 ELSE 704 705 ivar2t = ivar2t + 1 706 707 ENDIF 708 709 ! Depth of var2 observation 710 profdata%var(2)%vdep(ivar2t) = & 711 & inpfiles(jj)%pdep(ij,ji) 712 713 ! Depth of var2 observation QC 714 profdata%var(2)%idqc(ivar2t) = & 715 & inpfiles(jj)%idqc(ij,ji) 716 717 ! Depth of var2 observation QC flags 718 profdata%var(2)%idqcf(:,ivar2t) = & 719 & inpfiles(jj)%idqcf(:,ij,ji) 720 721 ! Profile index 722 profdata%var(2)%nvpidx(ivar2t) = iprof 723 724 ! Vertical index in original profile 725 profdata%var(2)%nvlidx(ivar2t) = ij 726 727 ! Profile var2 value 728 IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) ) .AND. & 729 & ( .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) ) THEN 730 profdata%var(2)%vobs(ivar2t) = & 731 & inpfiles(jj)%pob(ij,ji,2) 732 IF ( ldmod ) THEN 733 profdata%var(2)%vmod(ivar2t) = & 734 & inpfiles(jj)%padd(ij,ji,1,2) 735 ENDIF 736 ! Count number of profile var2 data as function of type 737 itypvar2( profdata%ntyp(iprof) + 1 ) = & 738 & itypvar2( profdata%ntyp(iprof) + 1 ) + 1 739 ELSE 740 profdata%var(2)%vobs(ivar2t) = fbrmdi 741 ENDIF 742 743 ! Profile var2 qc 744 profdata%var(2)%nvqc(ivar2t) = & 745 & inpfiles(jj)%ivlqc(ij,ji,2) 746 747 ! Profile var2 qc flags 748 profdata%var(2)%nvqcf(:,ivar2t) = & 749 & inpfiles(jj)%ivlqcf(:,ij,ji,2) 750 751 ENDIF 726 727 END DO 752 728 753 729 END DO loop_p … … 763 739 !----------------------------------------------------------------------- 764 740 765 CALL obs_mpp_sum_integer ( ivar1t0, ivar1tmpp ) 766 CALL obs_mpp_sum_integer ( ivar2t0, ivar2tmpp ) 741 DO jvar = 1, kvars 742 CALL obs_mpp_sum_integer ( ivart0(jvar), ivartmpp(jvar) ) 743 END DO 767 744 CALL obs_mpp_sum_integer ( ip3dt, ip3dtmpp ) 768 745 769 CALL obs_mpp_sum_integers( itypvar1, itypvar1mpp, ntyp1770 + 1 ) 770 CALL obs_mpp_sum_integers( itypvar2, itypvar2mpp, ntyp1770 + 1 ) 746 DO jvar = 1, kvars 747 CALL obs_mpp_sum_integers( itypvar(:,jvar), itypvarmpp(:,jvar), ntyp1770 + 1 ) 748 END DO 771 749 772 750 !----------------------------------------------------------------------- … … 778 756 WRITE(numout,'(1X,A)') '------------' 779 757 WRITE(numout,*) 780 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(1) ) 781 WRITE(numout,'(1X,A)') '------------------------' 782 DO ji = 0, ntyp1770 783 IF ( itypvar1mpp(ji+1) > 0 ) THEN 784 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 785 & cwmonam1770(ji)(1:52),' = ', & 786 & itypvar1mpp(ji+1) 787 ENDIF 758 DO jvar = 1, kvars 759 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(jvar) ) 760 WRITE(numout,'(1X,A)') '------------------------' 761 DO ji = 0, ntyp1770 762 IF ( itypvarmpp(ji+1,jvar) > 0 ) THEN 763 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 764 & cwmonam1770(ji)(1:52),' = ', & 765 & itypvarmpp(ji+1,jvar) 766 ENDIF 767 END DO 768 WRITE(numout,'(1X,A)') & 769 & '---------------------------------------------------------------' 770 WRITE(numout,'(1X,A55,I8)') & 771 & 'Total profile data for variable '//TRIM( profdata%cvars(jvar) )// & 772 & ' = ', ivartmpp(jvar) 773 WRITE(numout,'(1X,A)') & 774 & '---------------------------------------------------------------' 775 WRITE(numout,*) 788 776 END DO 789 WRITE(numout,'(1X,A)') & 790 & '---------------------------------------------------------------' 791 WRITE(numout,'(1X,A55,I8)') & 792 & 'Total profile data for variable '//TRIM( profdata%cvars(1) )// & 793 & ' = ', ivar1tmpp 794 WRITE(numout,'(1X,A)') & 795 & '---------------------------------------------------------------' 796 WRITE(numout,*) 797 WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(2) ) 798 WRITE(numout,'(1X,A)') '------------------------' 799 DO ji = 0, ntyp1770 800 IF ( itypvar2mpp(ji+1) > 0 ) THEN 801 WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 802 & cwmonam1770(ji)(1:52),' = ', & 803 & itypvar2mpp(ji+1) 804 ENDIF 777 ENDIF 778 779 IF (ldsatt) THEN 780 profdata%nvprot(:) = ip3dt 781 profdata%nvprotmpp(:) = ip3dtmpp 782 ELSE 783 DO jvar = 1, kvars 784 profdata%nvprot(jvar) = ivart(jvar) 785 profdata%nvprotmpp(jvar) = ivartmpp(jvar) 805 786 END DO 806 WRITE(numout,'(1X,A)') &807 & '---------------------------------------------------------------'808 WRITE(numout,'(1X,A55,I8)') &809 & 'Total profile data for variable '//TRIM( profdata%cvars(2) )// &810 & ' = ', ivar2tmpp811 WRITE(numout,'(1X,A)') &812 & '---------------------------------------------------------------'813 WRITE(numout,*)814 ENDIF815 816 IF (ldsatt) THEN817 profdata%nvprot(1) = ip3dt818 profdata%nvprot(2) = ip3dt819 profdata%nvprotmpp(1) = ip3dtmpp820 profdata%nvprotmpp(2) = ip3dtmpp821 ELSE822 profdata%nvprot(1) = ivar1t823 profdata%nvprot(2) = ivar2t824 profdata%nvprotmpp(1) = ivar1tmpp825 profdata%nvprotmpp(2) = ivar2tmpp826 787 ENDIF 827 788 profdata%nprof = iprof … … 830 791 ! Model level search 831 792 !----------------------------------------------------------------------- 832 IF ( ldvar1 ) THEN 833 CALL obs_level_search( jpk, gdept_1d, & 834 & profdata%nvprot(1), profdata%var(1)%vdep, & 835 & profdata%var(1)%mvk ) 836 ENDIF 837 IF ( ldvar2 ) THEN 838 CALL obs_level_search( jpk, gdept_1d, & 839 & profdata%nvprot(2), profdata%var(2)%vdep, & 840 & profdata%var(2)%mvk ) 841 ENDIF 793 DO jvar = 1, kvars 794 IF ( ldvar(jvar) ) THEN 795 CALL obs_level_search( jpk, gdept_1d, & 796 & profdata%nvprot(jvar), profdata%var(jvar)%vdep, & 797 & profdata%var(jvar)%mvk ) 798 ENDIF 799 END DO 842 800 843 801 !----------------------------------------------------------------------- … … 852 810 ! Deallocate temporary data 853 811 !----------------------------------------------------------------------- 854 DEALLOCATE( ifileidx, iprofidx, zdat, clvars )812 DEALLOCATE( ifileidx, iprofidx, zdat, clvarsin ) 855 813 856 814 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/OBS/obs_read_surf.F90
r13226 r14058 40 40 SUBROUTINE obs_rea_surf( surfdata, knumfiles, cdfilenames, & 41 41 & kvars, kextr, kstp, ddobsini, ddobsend, & 42 & ldignmis, ldmod, ldnightav )42 & ldignmis, ldmod, ldnightav, cdvars ) 43 43 !!--------------------------------------------------------------------- 44 44 !! … … 73 73 REAL(dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS 74 74 REAL(dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS 75 CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars 75 76 76 77 !! * Local declarations 77 78 CHARACTER(LEN=11), PARAMETER :: cpname='obs_rea_surf' 78 79 CHARACTER(len=8) :: clrefdate 79 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars 80 CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvarsin 80 81 INTEGER :: ji 81 82 INTEGER :: jj … … 178 179 & ldgrid = .TRUE. ) 179 180 181 IF ( inpfiles(jj)%nvar /= kvars ) THEN 182 CALL ctl_stop( 'Feedback format error: ', & 183 & ' unexpected number of vars in feedback file' ) 184 ENDIF 185 180 186 IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 181 187 CALL ctl_stop( 'Model not in input data' ) … … 184 190 185 191 IF ( jj == 1 ) THEN 186 ALLOCATE( clvars ( inpfiles(jj)%nvar ) )192 ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) 187 193 DO ji = 1, inpfiles(jj)%nvar 188 clvars(ji) = inpfiles(jj)%cname(ji) 194 clvarsin(ji) = inpfiles(jj)%cname(ji) 195 IF ( clvarsin(ji) /= cdvars(ji) ) THEN 196 CALL ctl_stop( 'Feedback file variables do not match', & 197 & ' expected variable names for this type' ) 198 ENDIF 189 199 END DO 190 200 ELSE 191 201 DO ji = 1, inpfiles(jj)%nvar 192 IF ( inpfiles(jj)%cname(ji) /= clvars (ji) ) THEN202 IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN 193 203 CALL ctl_stop( 'Feedback file variables not consistent', & 194 204 & ' with previous files for this type' ) … … 347 357 iobs = 0 348 358 349 surfdata%cvars(:) = clvars (:)359 surfdata%cvars(:) = clvarsin(:) 350 360 351 361 ityp (:) = 0 … … 480 490 ! Deallocate temporary data 481 491 !----------------------------------------------------------------------- 482 DEALLOCATE( ifileidx, isurfidx, zdat, clvars )492 DEALLOCATE( ifileidx, isurfidx, zdat, clvarsin ) 483 493 484 494 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/OBS/obs_write.F90
r12933 r14058 86 86 CHARACTER(LEN=40) :: clfname 87 87 CHARACTER(LEN=10) :: clfiletype 88 CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable 89 CHARACTER(LEN=ilenunit) :: clunits ! Units of variable 90 CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable 88 91 CHARACTER(LEN=12) :: clfmt ! writing format 89 92 INTEGER :: idg ! number of digits … … 115 118 ! Find maximum level 116 119 ilevel = 0 117 DO jvar = 1, 2120 DO jvar = 1, profdata%nvar 118 121 ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 119 122 END DO … … 180 183 181 184 END SELECT 185 186 IF ( ( TRIM(profdata%cvars(1)) /= 'POTM' ) .AND. & 187 & ( TRIM(profdata%cvars(1)) /= 'UVEL' ) ) THEN 188 CALL alloc_obfbdata( fbdata, 1, profdata%nprof, ilevel, & 189 & 1 + iadd, iext, .TRUE. ) 190 fbdata%cname(1) = profdata%cvars(1) 191 fbdata%coblong(1) = cllongname 192 fbdata%cobunit(1) = clunits 193 fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(cllongname) 194 fbdata%caddunit(1,1) = clunits 195 fbdata%cgrid(:) = clgrid 196 DO je = 1, iext 197 fbdata%cextname(je) = pext%cdname(je) 198 fbdata%cextlong(je) = pext%cdlong(je,1) 199 fbdata%cextunit(je) = pext%cdunit(je,1) 200 END DO 201 DO ja = 1, iadd 202 fbdata%caddname(1+ja) = padd%cdname(ja) 203 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 204 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 205 END DO 206 ENDIF 182 207 183 208 fbdata%caddname(1) = 'Hx' … … 234 259 & krefdate = 19500101 ) 235 260 ! Reform the profiles arrays for output 236 DO jvar = 1, 2261 DO jvar = 1, profdata%nvar 237 262 DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) 238 263 ik = profdata%var(jvar)%nvlidx(jk) … … 329 354 CHARACTER(LEN=40) :: clfname ! netCDF filename 330 355 CHARACTER(LEN=10) :: clfiletype 356 CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable 357 CHARACTER(LEN=ilenunit) :: clunits ! Units of variable 358 CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable 331 359 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' 332 360 CHARACTER(LEN=12) :: clfmt ! writing format … … 354 382 SELECT CASE ( TRIM(surfdata%cvars(1)) ) 355 383 CASE('SLA') 384 385 ! SLA needs special treatment because of MDT, so is all done here 386 ! Other variables are done more generically 387 ! No climatology for SLA, MDT is our best estimate of that and is already output. 356 388 357 389 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & … … 384 416 CASE('SST') 385 417 418 clfiletype = 'sstfb' 419 cllongname = 'Sea surface temperature' 420 clunits = 'Degree centigrade' 421 clgrid = 'T' 422 423 CASE('ICECONC') 424 425 clfiletype = 'sicfb' 426 cllongname = 'Sea ice concentration' 427 clunits = 'Fraction' 428 clgrid = 'T' 429 430 CASE('SSS') 431 432 clfiletype = 'sssfb' 433 cllongname = 'Sea surface salinity' 434 clunits = 'psu' 435 clgrid = 'T' 436 437 CASE DEFAULT 438 439 CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) 440 441 END SELECT 442 443 ! SLA needs special treatment because of MDT, so is done above 444 ! Remaining variables treated more generically 445 446 IF ( TRIM(surfdata%cvars(1)) /= 'SLA' ) THEN 447 386 448 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 387 449 & 1 + iadd, iext, .TRUE. ) 388 450 389 clfiletype = 'sstfb'390 451 fbdata%cname(1) = surfdata%cvars(1) 391 fbdata%coblong(1) = 'Sea surface temperature'392 fbdata%cobunit(1) = 'Degree centigrade'452 fbdata%coblong(1) = cllongname 453 fbdata%cobunit(1) = clunits 393 454 DO je = 1, iext 394 455 fbdata%cextname(je) = pext%cdname(je) 395 456 fbdata%cextlong(je) = pext%cdlong(je,1) 396 457 fbdata%cextunit(je) = pext%cdunit(je,1) 397 END DO 398 fbdata%caddlong(1,1) = 'Model interpolated SST' 399 fbdata%caddunit(1,1) = 'Degree centigrade' 400 fbdata%cgrid(1) = 'T' 458 END DO 459 IF ( TRIM(surfdata%cvars(1)) == 'ICECONC' ) THEN 460 fbdata%caddlong(1,1) = 'Model interpolated ICE' 461 ELSE 462 fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(surfdata%cvars(1)) 463 ENDIF 464 fbdata%caddunit(1,1) = clunits 465 fbdata%cgrid(1) = clgrid 401 466 DO ja = 1, iadd 402 467 fbdata%caddname(1+ja) = padd%cdname(ja) … … 404 469 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 405 470 END DO 406 407 CASE('ICECONC') 408 409 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 410 & 1 + iadd, iext, .TRUE. ) 411 412 clfiletype = 'sicfb' 413 fbdata%cname(1) = surfdata%cvars(1) 414 fbdata%coblong(1) = 'Sea ice' 415 fbdata%cobunit(1) = 'Fraction' 416 DO je = 1, iext 417 fbdata%cextname(je) = pext%cdname(je) 418 fbdata%cextlong(je) = pext%cdlong(je,1) 419 fbdata%cextunit(je) = pext%cdunit(je,1) 420 END DO 421 fbdata%caddlong(1,1) = 'Model interpolated ICE' 422 fbdata%caddunit(1,1) = 'Fraction' 423 fbdata%cgrid(1) = 'T' 424 DO ja = 1, iadd 425 fbdata%caddname(1+ja) = padd%cdname(ja) 426 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 427 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 428 END DO 429 430 CASE('SSS') 431 432 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 433 & 1 + iadd, iext, .TRUE. ) 434 435 clfiletype = 'sssfb' 436 fbdata%cname(1) = surfdata%cvars(1) 437 fbdata%coblong(1) = 'Sea surface salinity' 438 fbdata%cobunit(1) = 'psu' 439 DO je = 1, iext 440 fbdata%cextname(je) = pext%cdname(je) 441 fbdata%cextlong(je) = pext%cdlong(je,1) 442 fbdata%cextunit(je) = pext%cdunit(je,1) 443 END DO 444 fbdata%caddlong(1,1) = 'Model interpolated SSS' 445 fbdata%caddunit(1,1) = 'psu' 446 fbdata%cgrid(1) = 'T' 447 DO ja = 1, iadd 448 fbdata%caddname(1+ja) = padd%cdname(ja) 449 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 450 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 451 END DO 452 453 CASE DEFAULT 454 455 CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) 456 457 END SELECT 471 ENDIF 458 472 459 473 fbdata%caddname(1) = 'Hx' -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/sbcapr.F90
r14046 r14058 148 148 ! ! ---------------------------------------- ! 149 149 ! !* Restart: read in restart file 150 IF( ln_rstart .AND. iom_varid( numror, 'ssh_ibb', ldstop = .FALSE. ) > 0) THEN150 IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN 151 151 IF(lwp) WRITE(numout,*) 'sbc_apr: ssh_ibb read in the restart file' 152 152 CALL iom_get( numror, jpdom_auto, 'ssh_ibb', ssh_ibb ) ! before inv. barometer ssh -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/sbcice_cice.F90
r13295 r14058 12 12 USE oce ! ocean dynamics and tracers 13 13 USE dom_oce ! ocean space and time domain 14 # if !defined key_qco15 USE dom vvl14 # if defined key_qco 15 USE domqco ! Variable volume 16 16 # else 17 USE dom qco17 USE domvvl ! Variable volume 18 18 # endif 19 19 USE phycst, only : rcp, rho0, r1_rho0, rhos, rhoi … … 238 238 !!gm especially here it is assumed zstar coordinate, but it can be ztilde.... 239 239 #if defined key_qco 240 IF( .NOT.ln_linssh ) CALL dom_qco_zgr( Kbb, Kmm , Kaa) ! interpolation scale factor, depth and water column240 IF( .NOT.ln_linssh ) CALL dom_qco_zgr( Kbb, Kmm ) ! interpolation scale factor, depth and water column 241 241 #else 242 242 IF( .NOT.ln_linssh ) THEN -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/sbcmod.F90
r14047 r14058 523 523 IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! 524 524 ! ! ---------------------------------------- ! 525 IF( ln_rstart .AND. & !* Restart: read in restart file 526 & iom_varid( numror, 'utau_b', ldstop = .FALSE. ) > 0 ) THEN 527 IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields red in the restart file' 528 CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b ) ! before i-stress (U-point) 529 CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b ) ! before j-stress (V-point) 530 CALL iom_get( numror, jpdom_auto, 'qns_b', qns_b ) ! before non solar heat flux (T-point) 531 ! The 3D heat content due to qsr forcing is treated in traqsr 532 ! CALL iom_get( numror, jpdom_auto, 'qsr_b' , qsr_b ) ! before solar heat flux (T-point) 533 CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b ) ! before freshwater flux (T-point) 525 IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN !* Restart: read in restart file 526 IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields read in the restart file' 527 CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b ) ! i-stress 528 CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b ) ! j-stress 529 CALL iom_get( numror, jpdom_auto, 'qns_b', qns_b ) ! non solar heat flux 530 CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b ) ! freshwater flux 531 ! NB: The 3D heat content due to qsr forcing (qsr_hc_b) is treated in traqsr 534 532 ! To ensure restart capability with 3.3x/3.4 restart files !! to be removed in v3.6 535 533 IF( iom_varid( numror, 'sfx_b', ldstop = .FALSE. ) > 0 ) THEN … … 566 564 ! ! ---------------------------------------- ! 567 565 IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 568 CALL iom_put( "empmr" , emp 569 CALL iom_put( "empbmr" , emp_b 570 CALL iom_put( "saltflx", sfx )! downward salt flux (includes virtual salt flux beneath ice in linear free surface case)571 CALL iom_put( "fmmflx" , fmmflx )! Freezing-melting water flux572 CALL iom_put( "qt" , qns + qsr )! total heat flux573 CALL iom_put( "qns" , qns )! solar heat flux574 CALL iom_put( "qsr" , qsr )! solar heat flux566 CALL iom_put( "empmr" , emp - rnf ) ! upward water flux 567 CALL iom_put( "empbmr" , emp_b - rnf ) ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) 568 CALL iom_put( "saltflx", sfx ) ! downward salt flux (includes virtual salt flux beneath ice in linear free surface case) 569 CALL iom_put( "fmmflx" , fmmflx ) ! Freezing-melting water flux 570 CALL iom_put( "qt" , qns + qsr ) ! total heat flux 571 CALL iom_put( "qns" , qns ) ! solar heat flux 572 CALL iom_put( "qsr" , qsr ) ! solar heat flux 575 573 IF( nn_ice > 0 .OR. ll_opa ) CALL iom_put( "ice_cover", fr_i ) ! ice fraction 576 CALL iom_put( "taum" , taum )! wind stress module577 CALL iom_put( "wspd" , wndm )! wind speed module over free ocean or leads in presence of sea-ice578 CALL iom_put( "qrp" , qrp )! heat flux damping579 CALL iom_put( "erp" , erp )! freshwater flux damping574 CALL iom_put( "taum" , taum ) ! wind stress module 575 CALL iom_put( "wspd" , wndm ) ! wind speed module over free ocean or leads in presence of sea-ice 576 CALL iom_put( "qrp" , qrp ) ! heat flux damping 577 CALL iom_put( "erp" , erp ) ! freshwater flux damping 580 578 ENDIF 581 579 ! 582 580 IF(sn_cfctl%l_prtctl) THEN ! print mean trends (used for debugging) 583 CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask )584 CALL prt_ctl(tab2d_1=(emp-rnf) , clinfo1=' emp-rnf - : ', mask1=tmask )585 CALL prt_ctl(tab2d_1=(sfx-rnf) , clinfo1=' sfx-rnf - : ', mask1=tmask )586 CALL prt_ctl(tab2d_1=qns , clinfo1=' qns - : ', mask1=tmask )587 CALL prt_ctl(tab2d_1=qsr , clinfo1=' qsr - : ', mask1=tmask )588 CALL prt_ctl(tab3d_1=tmask , clinfo1=' tmask - : ', mask1=tmask, kdim=jpk )581 CALL prt_ctl(tab2d_1=fr_i , clinfo1=' fr_i - : ', mask1=tmask ) 582 CALL prt_ctl(tab2d_1=(emp-rnf) , clinfo1=' emp-rnf - : ', mask1=tmask ) 583 CALL prt_ctl(tab2d_1=(sfx-rnf) , clinfo1=' sfx-rnf - : ', mask1=tmask ) 584 CALL prt_ctl(tab2d_1=qns , clinfo1=' qns - : ', mask1=tmask ) 585 CALL prt_ctl(tab2d_1=qsr , clinfo1=' qsr - : ', mask1=tmask ) 586 CALL prt_ctl(tab3d_1=tmask , clinfo1=' tmask - : ', mask1=tmask, kdim=jpk ) 589 587 CALL prt_ctl(tab3d_1=ts(:,:,:,jp_tem,Kmm), clinfo1=' sst - : ', mask1=tmask, kdim=1 ) 590 588 CALL prt_ctl(tab3d_1=ts(:,:,:,jp_sal,Kmm), clinfo1=' sss - : ', mask1=tmask, kdim=1 ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/sbcrnf.F90
r14047 r14058 157 157 IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! 158 158 ! ! ---------------------------------------- ! 159 IF( ln_rstart .AND. & !* Restart: read in restart file 160 & iom_varid( numror, 'rnf_b', ldstop = .FALSE. ) > 0 ) THEN 159 IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN !* Restart: read in restart file 161 160 IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields red in the restart file', lrxios 162 CALL iom_get( numror, jpdom_auto, 'rnf_b' , rnf_b )! before runoff161 CALL iom_get( numror, jpdom_auto, 'rnf_b' , rnf_b ) ! before runoff 163 162 CALL iom_get( numror, jpdom_auto, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem) ) ! before heat content of runoff 164 163 CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal) ) ! before salinity content of runoff 165 ELSE 164 ELSE !* no restart: set from nit000 values 166 165 IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields set to nit000' 167 166 rnf_b (:,: ) = rnf (:,: ) … … 176 175 & 'at it= ', kt,' date= ', ndastp 177 176 IF(lwp) WRITE(numout,*) '~~~~' 178 CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf)177 CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf ) 179 178 CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem) ) 180 179 CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal) ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traatf_qco.F90
r14046 r14058 1 MODULE traatf qco1 MODULE traatf_qco 2 2 !!====================================================================== 3 !! *** MODULE traatf qco ***3 !! *** MODULE traatf_qco *** 4 4 !! Ocean active tracers: Asselin time filtering for temperature and salinity 5 5 !!====================================================================== … … 45 45 USE prtctl ! Print control 46 46 USE timing ! Timing 47 #if defined key_agrif48 USE agrif_oce_interp49 #endif50 47 51 48 IMPLICIT NONE … … 149 146 ENDIF 150 147 ! 151 CALL lbc_lnk_multi( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1. , pts(:,:,:,jp_sal,Kmm) , 'T', 1.)152 148 CALL lbc_lnk_multi( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1._wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1._wp ) 149 ! 153 150 ENDIF 154 151 ! … … 370 367 371 368 !!====================================================================== 372 END MODULE traatf qco369 END MODULE traatf_qco -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traqsr.F90
r14046 r14058 144 144 145 145 IF( kt == nit000 ) THEN !== 1st time step ==! 146 IF( ln_rstart .AND. iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 .AND..NOT.l_1st_euler ) THEN ! read in restart146 IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN ! read in restart 147 147 z1_2 = 0.5_wp 148 148 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile … … 150 150 CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b ) ! before heat content trend due to Qsr flux 151 151 ENDIF 152 ELSE ! No restart or restart not found: Euler forward time stepping152 ELSE ! No restart or Euler forward at 1st time step 153 153 z1_2 = 1._wp 154 154 DO_3D( isj, iej, isi, iei, 1, jpk ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/trasbc.F90
r14046 r14058 72 72 !! - send trends to trdtra module for further diagnostics(l_trdtra=T) 73 73 !!---------------------------------------------------------------------- 74 INTEGER, INTENT(in ) :: kt ! ocean time-step index75 INTEGER, INTENT(in ) :: Kmm, Krhs ! time level indices76 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation74 INTEGER, INTENT(in ) :: kt ! ocean time-step index 75 INTEGER, INTENT(in ) :: Kmm, Krhs ! time level indices 76 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer Eq. 77 77 ! 78 78 INTEGER :: ji, jj, jk, jn ! dummy loop indices … … 117 117 ! !== Set before sbc tracer content fields ==! 118 118 IF( kt == nit000 ) THEN !* 1st time-step 119 IF( ln_rstart .AND. & ! Restart: read in restart file 120 & iom_varid( numror, 'sbc_hc_b', ldstop = .FALSE. ) > 0 ) THEN 119 IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN ! Restart: read in restart file 121 120 zfact = 0.5_wp 122 121 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile … … 126 125 CALL iom_get( numror, jpdom_auto, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal) ) ! before salt content sbc trend 127 126 ENDIF 128 ELSE ! No restart or restart not found: Euler forward time stepping127 ELSE ! No restart or restart not found: Euler forward time stepping 129 128 zfact = 1._wp 130 129 DO_2D( isj, iej, isi, iei ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/USR/usrdef_istate.F90
r13497 r14058 7 7 !! User defined : set the initial state of a user configuration 8 8 !!====================================================================== 9 !! History : 4.0 ! 2016-03 (S. Flavoni) Original code 9 !! History : 4.0 ! 2016-03 (S. Flavoni) Original code 10 !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh 10 11 !!---------------------------------------------------------------------- 11 12 … … 22 23 PRIVATE 23 24 24 PUBLIC usr_def_istate ! called in istate.F90 25 PUBLIC usr_def_istate ! called in istate.F90 26 PUBLIC usr_def_istate_ssh ! called by domqco.F90 25 27 26 28 !! * Substitutions … … 33 35 CONTAINS 34 36 35 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh)37 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 36 38 !!---------------------------------------------------------------------- 37 39 !! *** ROUTINE usr_def_istate *** … … 48 50 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 49 51 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 50 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height51 52 ! 52 53 INTEGER :: ji, jj, jk ! dummy loop indices … … 59 60 pu (:,:,:) = 0._wp ! ocean at rest 60 61 pv (:,:,:) = 0._wp 61 pssh(:,:) = 0._wp62 62 ! 63 63 DO_3D( 1, 1, 1, 1, 1, jpk ) ! horizontally uniform T & S profiles … … 80 80 END SUBROUTINE usr_def_istate 81 81 82 83 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 84 !!---------------------------------------------------------------------- 85 !! *** ROUTINE usr_def_istate_ssh *** 86 !! 87 !! ** Purpose : Initialization of ssh 88 !! 89 !! ** Method : Set ssh as null, ptmask is required for test cases 90 !!---------------------------------------------------------------------- 91 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 92 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] 93 !!---------------------------------------------------------------------- 94 ! 95 IF(lwp) WRITE(numout,*) 96 IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : GYRE configuration, analytical definition of initial state' 97 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~~ Ocean at rest, ssh is zero' 98 ! 99 ! Sea level: 100 pssh(:,:) = 0._wp 101 ! 102 END SUBROUTINE usr_def_istate_ssh 103 82 104 !!====================================================================== 83 105 END MODULE usrdef_istate -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ZDF/zdfddm.F90
r13497 r14058 31 31 !! * Substitutions 32 32 # include "do_loop_substitute.h90" 33 # include "domzgr_substitute.h90" 33 34 !!---------------------------------------------------------------------- 34 35 !! NEMO/OCE 4.0 , NEMO Consortium (2018) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ZDF/zdftke.F90
r14046 r14058 242 242 ! 243 243 DO_2D( 0, 0, 0, 0 ) 244 en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1)244 en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) 245 245 zdiag(ji,jj,1) = 1._wp/en(ji,jj,1) 246 246 zd_lw(ji,jj,1) = 1._wp -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/nemogcm.F90
r14047 r14058 42 42 !!---------------------------------------------------------------------- 43 43 USE step_oce ! module used in the ocean time stepping module (step.F90) 44 ! 44 45 USE phycst ! physical constant (par_cst routine) 45 46 USE domain ! domain initialization (dom_init & dom_cfg routines) 46 USE closea ! treatment of closed seas (for ln_closea)47 USE usrdef_nam ! user defined configuration 48 USE tide_mod, ONLY : tide_init ! tidal components initialization (tide_init routine)49 USE bdyini 47 USE wet_dry ! Wetting and drying setting (wad_init routine) 48 USE usrdef_nam ! user defined configuration namelist 49 USE tide_mod, ONLY : tide_init ! tidal components initialization (tide_init routine) 50 USE bdyini , ONLY : bdy_init ! open boundary cond. setting (bdy_init routine) 50 51 USE istate ! initial state setting (istate_init routine) 51 USE ldfdyn ! lateral viscosity setting (ldfdyn_init routine)52 USE ldftra ! lateral diffusivity setting (ldftra_init routine)53 52 USE trdini ! dyn/tra trends initialization (trd_init routine) 54 USE asminc ! assimilation increments 55 USE asmbkg ! writing out state trajectory 56 USE diadct ! sections transports (dia_dct_init routine) 57 USE diaobs ! Observation diagnostics (dia_obs_init routine) 58 USE diacfl ! CFL diagnostics (dia_cfl_init routine) 59 USE diamlr ! IOM context management for multiple-linear-regression analysis 53 USE icbini ! handle bergs, initialisation 54 USE icbstp , ONLY : icb_end ! handle bergs, close iceberg files 55 USE cpl_oasis3 ! OASIS3 coupling 56 USE dyndmp ! Momentum damping (C1D only) 57 USE step_diu ! diurnal bulk SST timestepping (called from here if run offline) 58 USE crsini ! initialise grid coarsening utility 59 USE dia25h , ONLY : dia_25h_init ! 25h mean output (initialisation) 60 USE c1d ! 1D configuration 61 USE step_c1d ! Time stepping loop for the 1D configuration 62 #if defined key_top 63 USE trcini ! passive tracer initialisation 64 #endif 65 #if defined key_nemocice_decomp 66 USE ice_domain_size, only: nx_global, ny_global 67 #endif 60 68 #if defined key_qco 61 USE st epMLF! NEMO time-stepping (stp_MLF routine)69 USE stpmlf ! NEMO time-stepping (stp_MLF routine) 62 70 #else 63 71 USE step ! NEMO time-stepping (stp routine) 64 72 #endif 65 USE isfstp ! ice shelf (isf_stp_init routine)66 USE icbini ! handle bergs, initialisation67 USE icbstp ! handle bergs, calving, themodynamics and transport68 USE cpl_oasis3 ! OASIS3 coupling69 USE c1d ! 1D configuration70 USE step_c1d ! Time stepping loop for the 1D configuration71 USE dyndmp ! Momentum damping72 USE stopar ! Stochastic param.: ???73 USE stopts ! Stochastic param.: ???74 USE diu_layers ! diurnal bulk SST and coolskin75 USE step_diu ! diurnal bulk SST timestepping (called from here if run offline)76 USE crsini ! initialise grid coarsening utility77 USE dia25h ! 25h mean output78 USE diadetide ! Weights computation for daily detiding of model diagnostics79 USE sbc_oce , ONLY : lk_oasis80 USE wet_dry ! Wetting and drying setting (wad_init routine)81 #if defined key_top82 USE trcini ! passive tracer initialisation83 #endif84 #if defined key_nemocice_decomp85 USE ice_domain_size, only: nx_global, ny_global86 #endif87 73 ! 88 USE prtctl ! Print control89 USE in_out_manager ! I/O manager90 74 USE lib_mpp ! distributed memory computing 91 75 USE mppini ! shared/distributed memory setting (mpp_init routine) 92 76 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 93 77 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 94 #if defined key_iomput 95 USE xios ! xIOserver 96 #endif 97 #if defined key_agrif 98 USE agrif_all_update ! Master Agrif update 99 #endif 100 USE halo_mng 78 USE halo_mng ! Halo manager 101 79 102 80 IMPLICIT NONE … … 182 160 ! 183 161 DO WHILE( istp <= nitend .AND. nstop == 0 ) 184 # if defined key_qco162 # if defined key_qco 185 163 CALL stp_MLF 186 # else164 # else 187 165 CALL stp 188 # endif166 # endif 189 167 istp = istp + 1 190 168 END DO … … 195 173 ! 196 174 DO WHILE( istp <= nitend .AND. nstop == 0 ) 197 175 ! 198 176 ncom_stp = istp 199 177 IF( ln_timing ) THEN … … 202 180 IF ( istp == nitend ) elapsed_time = zstptiming - elapsed_time 203 181 ENDIF 204 205 # if defined key_qco182 ! 183 # if defined key_qco 206 184 CALL stp_MLF ( istp ) 207 # else185 # else 208 186 CALL stp ( istp ) 209 # endif187 # endif 210 188 istp = istp + 1 211 189 ! 212 190 IF( lwp .AND. ln_timing ) WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming 213 191 ! 214 192 END DO 215 193 ! … … 279 257 INTEGER :: ios, ilocal_comm ! local integers 280 258 !! 281 NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, 282 & nn_isplt, nn_jsplt, nn_ictls, nn_ictle, nn_jctls, nn_jctle259 NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, nn_isplt, nn_jsplt , nn_ictls, & 260 & nn_ictle, nn_jctls , nn_jctle 283 261 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr 284 262 !!---------------------------------------------------------------------- … … 350 328 IF(lwp) THEN ! open listing units 351 329 ! 352 IF( .NOT. 330 IF( .NOT.lwm ) & ! alreay opened for narea == 1 353 331 & CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) 354 332 ! … … 357 335 WRITE(numout,*) ' NEMO team' 358 336 WRITE(numout,*) ' Ocean General Circulation Model' 359 WRITE(numout,*) ' NEMO version 4.0 (20 19) '337 WRITE(numout,*) ' NEMO version 4.0 (2020) ' 360 338 WRITE(numout,*) 361 339 WRITE(numout,*) " ._ ._ ._ ._ ._ " … … 373 351 WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 374 352 WRITE(numout,*) 375 376 ! Print the working precision to ocean.output 377 IF (wp == dp) THEN 378 WRITE(numout,*) "Working precision = double-precision" 379 ELSE 380 WRITE(numout,*) "Working precision = single-precision" 353 ! 354 WRITE(numout,cform_aaa) ! Flag AAAAAAA 355 ! 356 ! ! Control print of the working precision 357 WRITE(numout,*) 358 IF( wp == dp ) THEN ; WRITE(numout,*) "par_kind : wp = Working precision = dp = double-precision" 359 ELSE ; WRITE(numout,*) "par_kind : wp = Working precision = sp = single-precision" 381 360 ENDIF 382 WRITE(numout,*) 383 ! 384 WRITE(numout,cform_aaa) ! Flag AAAAAAA 361 WRITE(numout,*) "~~~~~~~~ ****************" 362 WRITE(numout,*) 385 363 ! 386 364 ENDIF … … 415 393 416 394 ! Initialise time level indices 417 Nbb = 1 ; Nnn = 2; Naa = 3;Nrhs = Naa395 Nbb = 1 ; Nnn = 2 ; Naa = 3 ; Nrhs = Naa 418 396 #if defined key_agrif 419 Kbb_a = Nbb ; Kmm_a = Nnn;Krhs_a = Nrhs ! agrif_oce module copies of time level indices397 Kbb_a = Nbb ; Kmm_a = Nnn ; Krhs_a = Nrhs ! agrif_oce module copies of time level indices 420 398 #endif 421 399 ! !-------------------------------! … … 423 401 ! !-------------------------------! 424 402 425 CALL nemo_ctl ! Control prints 403 CALL nemo_ctl ! Control prints of namctl and namcfg 426 404 ! 427 405 ! ! General initialization … … 437 415 CALL Agrif_Declare_Var_ini ! " " " " " DOM 438 416 #endif 439 CALL dom_init( Nbb, Nnn, Naa ) ! Domain440 IF( ln_crs ) CALL crs_init( Nnn )! coarsened grid: domain initialization417 CALL dom_init( Nbb, Nnn, Naa ) ! Domain 418 IF( ln_crs ) CALL crs_init( Nnn ) ! coarsened grid: domain initialization 441 419 IF( sn_cfctl%l_prtctl ) & 442 420 & CALL prt_ctl_init ! Print control -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/oce.F90
r13237 r14058 16 16 PRIVATE 17 17 18 PUBLIC oce_alloc ! routine called by nemo_init in nemogcm.F90 18 PUBLIC oce_alloc ! routine called by nemo_init in nemogcm.F90 19 PUBLIC oce_SWE_alloc ! routine called by nemo_init in SWE/nemogcm.F90 (Shallow Water Eq. case) 19 20 20 21 !! dynamics and tracer fields … … 68 69 INTEGER, PUBLIC, DIMENSION(2) :: noce_array !: unused array but seems to be needed to prevent agrif from creating an empty module 69 70 71 !! Shallow Water Eq. case (SWE) 72 LOGICAL, PUBLIC :: lk_SWE = .FALSE. !: shallow water flag =T in SWE configurations only 73 74 !! Stand-Alone Surface module (SAS) 75 LOGICAL, PUBLIC :: l_SAS = .FALSE. !: SAS flag =T in SAS configurations only 76 77 70 78 !!---------------------------------------------------------------------- 71 79 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 115 123 END FUNCTION oce_alloc 116 124 125 126 INTEGER FUNCTION oce_SWE_alloc() 127 !!---------------------------------------------------------------------- 128 !! *** FUNCTION oce_SWE_alloc *** 129 !!---------------------------------------------------------------------- 130 INTEGER :: ierr(2) 131 !!---------------------------------------------------------------------- 132 ! 133 lk_SWE = .TRUE. ! =T SWE case 134 ! 135 ierr(:) = 0 136 ALLOCATE( uu(jpi,jpj,jpk,jpt) , vv (jpi,jpj,jpk,jpt) , & 137 & ww(jpi,jpj,jpk) , hdiv(jpi,jpj,jpk) , ssh(jpi,jpj,jpt) , STAT=ierr(1) ) 138 ! 139 ALLOCATE( ts(jpi,jpj,jpk,jpts,jpt) , fraqsr_1lev(jpi,jpj) , & 140 & uu_b(jpi,jpj,jpt) , vv_b(jpi,jpj,jpt) , rn2(jpi,jpj,jpk) , STAT=ierr(2) ) 141 ! 142 oce_SWE_alloc = MAXVAL( ierr ) 143 IF( oce_SWE_alloc /= 0 ) CALL ctl_stop( 'STOP', 'oce_SWE_alloc: failed to allocate arrays' ) 144 ! 145 END FUNCTION oce_SWE_alloc 146 117 147 !!====================================================================== 118 148 END MODULE oce -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/step.F90
r14046 r14058 42 42 !!---------------------------------------------------------------------- 43 43 USE step_oce ! time stepping definition modules 44 !45 USE iom ! xIOs server46 44 47 45 IMPLICIT NONE -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/step_oce.F90
r14046 r14058 3 3 !! *** MODULE step_oce *** 4 4 !! Ocean time-stepping : module used in both initialisation phase and time stepping 5 !! (i.e. nemo_init and stp or stp_MLF routines) 5 6 !!====================================================================== 6 7 !! History : 3.3 ! 2010-08 (C. Ethe) Original code - reorganisation of the initial phase … … 9 10 USE oce ! ocean dynamics and tracers variables 10 11 USE dom_oce ! ocean space and time domain variables 11 USE domain, ONLY : dom_tile 12 USE zdf_oce ! ocean vertical physics variables 13 USE zdfdrg , ONLY : ln_drgimp ! implicit top/bottom friction 12 USE domain , ONLY : dom_tile 14 13 15 14 USE daymod ! calendar (day routine) … … 20 19 USE sbccpl ! surface boundary condition: coupled formulation (call send at end of step) 21 20 USE sbcapr ! surface boundary condition: atmospheric pressure 22 USE tide_mod, ONLY : ln_tide, tide_update23 21 USE sbcwave ! Wave intialisation 22 USE tide_mod ! tides 23 24 USE bdy_oce , ONLY : ln_bdy 25 USE bdydta ! open boundary condition data (bdy_dta routine) 26 USE bdytra ! bdy cond. for tracers (bdy_tra routine) 27 USE bdydyn3d ! bdy cond. for baroclinic vel. (bdy_dyn3d routine) 24 28 25 29 USE isf_oce ! ice shelf boundary condition 26 30 USE isfstp ! ice shelf boundary condition (isf_stp routine) 31 32 USE sshwzv ! vertical velocity and ssh (ssh_nxt routine) 33 ! (ssh_swp routine) 34 ! (wzv routine) 35 USE domvvl ! variable vertical scale factors (dom_vvl_sf_nxt routine) 36 ! (dom_vvl_sf_swp routine) 37 38 USE divhor ! horizontal divergence (div_hor routine) 39 USE dynadv ! advection (dyn_adv routine) 40 USE dynvor ! vorticity term (dyn_vor routine) 41 USE dynhpg ! hydrostatic pressure grad. (dyn_hpg routine) 42 USE dynldf ! lateral momentum diffusion (dyn_ldf routine) 43 USE dynzdf ! vertical diffusion (dyn_zdf routine) 44 USE dynspg ! surface pressure gradient (dyn_spg routine) 45 USE dynatf ! time-filtering (dyn_atf routine) 27 46 28 47 USE traqsr ! solar radiation penetration (tra_qsr routine) … … 40 59 USE eosbn2 ! equation of state (eos_bn2 routine) 41 60 42 USE divhor ! horizontal divergence (div_hor routine)43 USE dynadv ! advection (dyn_adv routine)44 USE dynvor ! vorticity term (dyn_vor routine)45 USE dynhpg ! hydrostatic pressure grad. (dyn_hpg routine)46 USE dynldf ! lateral momentum diffusion (dyn_ldf routine)47 USE dynzdf ! vertical diffusion (dyn_zdf routine)48 USE dynspg ! surface pressure gradient (dyn_spg routine)49 50 USE dynatf ! time-filtering (dyn_atf routine)51 52 61 USE stopar ! Stochastic parametrization (sto_par routine) 53 62 USE stopts 54 55 USE bdy_oce , ONLY : ln_bdy56 USE bdydta ! open boundary condition data (bdy_dta routine)57 USE bdytra ! bdy cond. for tracers (bdy_tra routine)58 USE bdydyn3d ! bdy cond. for baroclinic vel. (bdy_dyn3d routine)59 60 USE sshwzv ! vertical velocity and ssh (ssh_nxt routine)61 ! (ssh_swp routine)62 ! (wzv routine)63 USE domvvl ! variable vertical scale factors (dom_vvl_sf_nxt routine)64 ! (dom_vvl_sf_swp routine)65 63 66 64 USE ldfslp ! iso-neutral slopes (ldf_slp routine) … … 68 66 USE ldftra ! lateral eddy diffusive coef. (ldf_tra routine) 69 67 68 USE zdf_oce ! ocean vertical physics variables 70 69 USE zdfphy ! vertical physics manager (zdf_phy_init routine) 71 USE zdfosm , ONLY : osm_rst, dyn_osm, tra_osm ! OSMOSIS routines used in step.F90 70 USE zdfdrg , ONLY : ln_drgimp ! implicit top/bottom friction 71 USE zdfosm , ONLY : osm_rst, dyn_osm, tra_osm ! OSMOSIS routines used in step.F90 72 72 USE zdfmfc ! Mass FLux Convection routine used in step.F90 73 73 … … 83 83 USE diahth ! thermocline depth (dia_hth routine) 84 84 USE diahsb ! heat, salt and volume budgets (dia_hsb routine) 85 USE diacfl 86 USE diaobs ! Observation operator 85 USE diacfl ! CFL diagnostics (dia_cfl routine) 86 USE diaobs ! Observation operator (dia_obs routine) 87 87 USE diadetide ! Weights computation for daily detiding of model diagnostics 88 88 USE diamlr ! IOM context management for multiple-linear-regression analysis … … 94 94 USE asminc ! assimilation increments (tra_asm_inc routine) 95 95 ! (dyn_asm_inc routine) 96 USE asmbkg 96 USE asmbkg ! writing out state trajectory 97 97 USE stpctl ! time stepping control (stp_ctl routine) 98 98 USE restart ! ocean restart (rst_wri routine) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/stpctl.F90
r13616 r14058 26 26 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 27 27 USE lib_mpp ! distributed memory computing 28 !29 28 USE netcdf ! NetCDF library 29 30 30 IMPLICIT NONE 31 31 PRIVATE … … 71 71 CHARACTER(len=20) :: clname 72 72 !!---------------------------------------------------------------------- 73 ! 73 74 IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid 74 75 ! … … 179 180 END DO 180 181 IF( kt == nitend ) istatus = NF90_CLOSE(nrunid) 181 END 182 ENDIF 182 183 ! !== error handling ==! 183 184 ! !== done by all processes at every time step ==! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OFF/dtadyn.F90
r14046 r14058 23 23 USE c1d ! 1D configuration: lk_c1d 24 24 USE dom_oce ! ocean domain: variables 25 #if !defined key_qco26 USE dom vvl! variable volume25 #if defined key_qco 26 USE domqco ! variable volume 27 27 #else 28 USE dom qco28 USE domvvl 29 29 #endif 30 30 USE zdf_oce ! ocean vertical physics: variables … … 97 97 !! * Substitutions 98 98 # include "do_loop_substitute.h90" 99 # include "domzgr_substitute.h90" 100 99 101 !!---------------------------------------------------------------------- 100 102 !! NEMO/OFF 4.0 , NEMO Consortium (2018) … … 388 390 gdepw(:,:,:,Kbb) = gdepw(:,:,:,Kmm) 389 391 ! 390 ENDIF391 392 #endif 393 ENDIF 392 394 ! 393 395 IF( ln_dynrnf .AND. ln_dynrnf_depth ) THEN ! read depht over which runoffs are distributed … … 412 414 ENDIF 413 415 END_2D 416 ! 414 417 DO_2D( 1, 1, 1, 1 ) ! set the associated depth 415 418 h_rnf(ji,jj) = 0._wp -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OFF/nemogcm.F90
r14046 r14058 64 64 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 65 65 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 66 USE step, ONLY : Nbb, Nnn, Naa, Nrhs ! time level indices 66 #if defined key_qco 67 USE stpmlf , ONLY : Nbb, Nnn, Naa, Nrhs ! time level indices 68 #else 69 USE step , ONLY : Nbb, Nnn, Naa, Nrhs ! time level indices 70 #endif 67 71 USE halo_mng 68 72 … … 143 147 CALL dta_dyn_atf( istp, Nbb, Nnn, Naa ) ! time filter of sea surface height and vertical scale factors 144 148 # if defined key_qco 145 CALL dom_qco_r3c( ssh(:,:, Kmm), r3t_f, r3u_f, r3v_f )149 CALL dom_qco_r3c( ssh(:,:,Nnn), r3t_f, r3u_f, r3v_f ) 146 150 # endif 147 151 ENDIF 148 152 CALL trc_stp ( istp, Nbb, Nnn, Nrhs, Naa ) ! time-stepping 149 153 # if defined key_qco 150 !r3t(:,:, Kmm) = r3t_f(:,:) ! update ssh to h0 ratio151 !r3u(:,:, Kmm) = r3u_f(:,:)152 !r3v(:,:, Kmm) = r3v_f(:,:)154 !r3t(:,:,Nnn) = r3t_f(:,:) ! update ssh to h0 ratio 155 !r3u(:,:,Nnn) = r3u_f(:,:) 156 !r3v(:,:,Nnn) = r3v_f(:,:) 153 157 # endif 154 158 #endif … … 160 164 ! 161 165 #if ! defined key_qco 162 # if ! defined key_sed_off166 # if ! defined key_sed_off 163 167 IF( .NOT.ln_linssh ) CALL dta_dyn_sf_interp( istp, Nnn ) ! calculate now grid parameters 164 # endif168 # endif 165 169 #endif 166 170 CALL stp_ctl ( istp ) ! Time loop: control and print -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/SAS/nemogcm.F90
r14047 r14058 216 216 !!---------------------------------------------------------------------- 217 217 ! 218 IF( lk_oasis ) THEN ; cxios_context = 'sas' 219 ELSE ; cxios_context = 'nemo' 218 IF( lk_oasis ) THEN ; cxios_context = 'sas' ! when coupling SAS to OCE 219 ELSE ; cxios_context = 'nemo' ! 220 220 ENDIF 221 221 nn_hls = 1 222 ! 223 l_SAS = .TRUE. ! used in domain:dom_nam 222 224 ! 223 225 ! !-------------------------------------------------! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/SWE/domzgr_substitute.h90
r12983 r14058 16 16 # define e3v(i,j,k,t) (e3v_0(i,j,k)*(1._wp+r3v(i,j,t))) 17 17 # define e3f(i,j,k) (e3f_0(i,j,k)*(1._wp+r3f(i,j))) 18 # define e3f_vor(i,j,k) (e3f_0vor(i,j,k)*(1._wp+r3f(i,j))) 18 19 # define e3w(i,j,k,t) (e3w_0(i,j,k)*(1._wp+r3t(i,j,t))) 19 20 # define e3uw(i,j,k,t) (e3uw_0(i,j,k)*(1._wp+r3u(i,j,t))) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/SWE/nemogcm.F90
r14046 r14058 4 4 !! Ocean system : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice) 5 5 !!====================================================================== 6 !! History : OPA ! 1990-10 (C. Levy, G. Madec) Original code 7 !! 7.0 ! 1991-11 (M. Imbard, C. Levy, G. Madec) 8 !! 7.1 ! 1993-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar, 9 !! P. Delecluse, C. Perigaud, G. Caniaux, B. Colot, C. Maes) release 7.1 10 !! - ! 1992-06 (L.Terray) coupling implementation 11 !! - ! 1993-11 (M.A. Filiberti) IGLOO sea-ice 12 !! 8.0 ! 1996-03 (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar, 13 !! P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0 14 !! 8.1 ! 1997-06 (M. Imbard, G. Madec) 15 !! 8.2 ! 1999-11 (M. Imbard, H. Goosse) sea-ice model 16 !! ! 1999-12 (V. Thierry, A-M. Treguier, M. Imbard, M-A. Foujols) OPEN-MP 17 !! ! 2000-07 (J-M Molines, M. Imbard) Open Boundary Conditions (CLIPPER) 18 !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and modules 19 !! - ! 2004-06 (R. Redler, NEC CCRLE, Germany) add OASIS[3/4] coupled interfaces 20 !! - ! 2004-08 (C. Talandier) New trends organization 21 !! - ! 2005-06 (C. Ethe) Add the 1D configuration possibility 22 !! - ! 2005-11 (V. Garnier) Surface pressure gradient organization 23 !! - ! 2006-03 (L. Debreu, C. Mazauric) Agrif implementation 24 !! - ! 2006-04 (G. Madec, R. Benshila) Step reorganization 25 !! - ! 2007-07 (J. Chanut, A. Sellar) Unstructured open boundaries (BDY) 26 !! 3.2 ! 2009-08 (S. Masson) open/write in the listing file in mpp 27 !! 3.3 ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface 28 !! - ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase 29 !! 3.3.1! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation 30 !! - ! 2011-11 (C. Harris) decomposition changes for running with CICE 31 !! 3.6 ! 2012-05 (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening 32 !! - ! 2014-12 (G. Madec) remove KPP scheme and cross-land advection (cla) 33 !! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface 6 !! History : 4.0 ! 2020-05 (A. Nasser, G. Madec) Original code from 4.0.2 7 !! - ! 2020-10 (S. Techene, G. Madec) cleanning 34 8 !!---------------------------------------------------------------------- 35 9 … … 42 16 !!---------------------------------------------------------------------- 43 17 USE step_oce ! module used in the ocean time stepping module (step.F90) 18 ! 44 19 USE phycst ! physical constant (par_cst routine) 45 20 USE domain ! domain initialization (dom_init & dom_cfg routines) 46 USE closea ! treatment of closed seas (for ln_closea)47 21 USE usrdef_nam ! user defined configuration 48 USE tide_mod, ONLY : tide_init ! tidal components initialization (tide_init routine)49 USE bdy_oce, ONLY : ln_bdy50 22 USE bdyini ! open boundary cond. setting (bdy_init routine) 51 23 USE istate ! initial state setting (istate_init routine) 52 USE ldfdyn ! lateral viscosity setting (ldfdyn_init routine) 53 USE ldftra ! lateral diffusivity setting (ldftra_init routine) 54 USE trdini ! dyn/tra trends initialization (trd_init routine) 55 USE asminc ! assimilation increments 56 USE asmbkg ! writing out state trajectory 57 USE diaptr ! poleward transports (dia_ptr_init routine) 58 USE diadct ! sections transports (dia_dct_init routine) 59 USE diaobs ! Observation diagnostics (dia_obs_init routine) 60 USE diacfl ! CFL diagnostics (dia_cfl_init routine) 61 USE diamlr ! IOM context management for multiple-linear-regression analysis 24 USE trd_oce , ONLY : l_trddyn ! dynamical trend logical 62 25 #if defined key_RK3 63 USE stpRK3 64 #elif defined key_qco 65 USE stpLF 26 USE stprk3 ! NEMO time-stepping (stp_RK3 routine) 66 27 #else 67 USE step ! NEMO time-stepping (stp routine) 68 #endif 69 USE isfstp ! ice shelf (isf_stp_init routine) 70 USE icbini ! handle bergs, initialisation 71 USE icbstp ! handle bergs, calving, themodynamics and transport 72 USE cpl_oasis3 ! OASIS3 coupling 73 USE c1d ! 1D configuration 74 USE step_c1d ! Time stepping loop for the 1D configuration 75 USE dyndmp ! Momentum damping 76 USE stopar ! Stochastic param.: ??? 77 USE stopts ! Stochastic param.: ??? 78 USE diu_layers ! diurnal bulk SST and coolskin 79 USE crsini ! initialise grid coarsening utility 80 USE dia25h ! 25h mean output 81 USE diadetide ! Weights computation for daily detiding of model diagnostics 82 USE sbc_oce , ONLY : lk_oasis 83 USE wet_dry ! Wetting and drying setting (wad_init routine) 84 #if defined key_top 85 USE trcini ! passive tracer initialisation 86 #endif 87 #if defined key_nemocice_decomp 88 USE ice_domain_size, only: nx_global, ny_global 28 USE stpmlf ! NEMO time-stepping (stp_MLF routine) 89 29 #endif 90 30 ! 91 31 USE lib_mpp ! distributed memory computing 92 32 USE mppini ! shared/distributed memory setting (mpp_init routine) 93 USE lbcnfd , ONLY : isendto, nsndto , nfsloop, nfeloop! Setup of north fold exchanges33 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 94 34 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 95 #if defined key_iomput 96 USE xios ! xIOserver 97 #endif 98 #if defined key_agrif 99 USE agrif_all_update ! Master Agrif update 100 #endif 35 USE halo_mng ! Halo manager 101 36 102 37 IMPLICIT NONE … … 139 74 !!---------------------------------------------------------------------- 140 75 ! 141 #if defined key_agrif142 CALL Agrif_Init_Grids() ! AGRIF: set the meshes143 #endif144 76 ! !-----------------------! 145 77 CALL nemo_init !== Initialisations ==! 146 78 ! !-----------------------! 147 148 #if defined key_agrif149 Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices150 CALL Agrif_Declare_Var_dom ! AGRIF: set the meshes for DOM151 CALL Agrif_Declare_Var ! " " " " " DYN/TRA152 # if defined key_top153 CALL Agrif_Declare_Var_top ! " " " " " TOP154 # endif155 # if defined key_si3156 CALL Agrif_Declare_Var_ice ! " " " " " Sea ice157 # endif158 #endif159 79 ! check that all process are still there... If some process have an error, 160 80 ! they will never enter in step and other processes will wait until the end of the cpu time! 81 ! 82 ! ! SWE case: only with key_qco 83 #if ! defined key_qco 84 CALL ctl_stop( 'nemo_gcm (SWE): shallow water model requires key_qco' ) 85 #endif 86 ! 161 87 CALL mpp_max( 'nemogcm', nstop ) 162 88 … … 174 100 ! 175 101 DO WHILE( istp <= nitend .AND. nstop == 0 ) 176 102 ! 177 103 ncom_stp = istp 178 104 IF( ln_timing ) THEN … … 181 107 IF ( istp == nitend ) elapsed_time = zstptiming - elapsed_time 182 108 ENDIF 109 ! 183 110 #if defined key_RK3 184 111 CALL stp_RK3 ( istp ) 185 #elif defined key_qco186 CALL stp_LF ( istp )187 112 #else 188 CALL stp 113 CALL stp_MLF ( istp ) 189 114 #endif 190 115 istp = istp + 1 191 116 ! 192 117 IF( lwp .AND. ln_timing ) WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming 193 118 ! 194 119 END DO 195 120 ! … … 232 157 INTEGER :: ios, ilocal_comm ! local integers 233 158 !! 234 NAMELIST/namctl/ sn_cfctl, nn_print, nn_ictls, nn_ictle, & 235 & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, & 236 & ln_timing, ln_diacfl 159 NAMELIST/namctl/ sn_cfctl, ln_timing, ln_diacfl, nn_isplt, nn_jsplt , nn_ictls, & 160 & nn_ictle, nn_jctls , nn_jctle 237 161 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr 238 162 !!---------------------------------------------------------------------- … … 246 170 ! 247 171 #if defined key_iomput 248 IF( Agrif_Root() ) THEN 249 IF( lk_oasis ) THEN 250 CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis 251 CALL xios_initialize( "not used" , local_comm =ilocal_comm ) ! send nemo communicator to xios 252 ELSE 253 CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm ) ! nemo local communicator given by xios 254 ENDIF 255 ENDIF 172 CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm ) ! nemo local communicator given by xios 256 173 CALL mpp_start( ilocal_comm ) 257 174 #else 258 IF( lk_oasis ) THEN 259 IF( Agrif_Root() ) THEN 260 CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis 261 ENDIF 262 CALL mpp_start( ilocal_comm ) 263 ELSE 264 CALL mpp_start( ) 265 ENDIF 175 CALL mpp_start( ) 266 176 #endif 267 177 ! … … 292 202 ! 293 203 ! finalize the definition of namctl variables 294 IF( sn_cfctl%l_allon ) THEN 295 ! Turn on all options. 296 CALL nemo_set_cfctl( sn_cfctl, .TRUE., .TRUE. ) 297 ! Ensure all processors are active 298 sn_cfctl%procmin = 0 ; sn_cfctl%procmax = 1000000 ; sn_cfctl%procincr = 1 299 ELSEIF( sn_cfctl%l_config ) THEN 300 ! Activate finer control of report outputs 301 ! optionally switch off output from selected areas (note this only 302 ! applies to output which does not involve global communications) 303 IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax ) .OR. & 304 & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) ) & 305 & CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. ) 306 ELSE 307 ! turn off all options. 308 CALL nemo_set_cfctl( sn_cfctl, .FALSE., .TRUE. ) 309 ENDIF 204 IF( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax .OR. MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) & 205 & CALL nemo_set_cfctl( sn_cfctl, .FALSE. ) 310 206 ! 311 207 lwp = (narea == 1) .OR. sn_cfctl%l_oceout ! control of all listing output print … … 336 232 WRITE(numout,*) " ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 337 233 WRITE(numout,*) 234 235 ! Print the working precision to ocean.output 236 IF (wp == dp) THEN 237 WRITE(numout,*) "Working precision = double-precision" 238 ELSE 239 WRITE(numout,*) "Working precision = single-precision" 240 ENDIF 241 WRITE(numout,*) 338 242 ! 339 243 WRITE(numout,cform_aaa) ! Flag AAAAAAA … … 353 257 ! 354 258 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 355 CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )259 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 356 260 ELSE ! user-defined namelist 357 CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )261 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 358 262 ENDIF 359 263 ! … … 365 269 CALL mpp_init 366 270 271 CALL halo_mng_init() 367 272 ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 368 273 CALL nemo_alloc() 369 274 370 275 ! Initialise time level indices 371 Nbb = 1 ; Nnn = 2; Naa = 3;Nrhs = Naa372 276 Nbb = 1 ; Nnn = 2 ; Naa = 3 ; Nrhs = Naa 277 373 278 ! !-------------------------------! 374 279 ! ! NEMO general initialization ! … … 382 287 ! 383 288 CALL phy_cst ! Physical constants 384 289 ! 290 ! ! SWE: Set rho0 and associated variables (eosbn2 not used) 291 rho0 = 1026._wp !: volumic mass of reference [kg/m3] 292 rcp = 3991.86795711963_wp !: heat capacity [J/K] 293 rho0_rcp = rho0 * rcp 294 r1_rho0 = 1._wp / rho0 295 r1_rcp = 1._wp / rcp 296 r1_rho0_rcp = 1._wp / rho0_rcp 297 ! 385 298 CALL dom_init( Nbb, Nnn, Naa ) ! Domain 386 299 … … 391 304 392 305 ! ! external forcing 393 CALL tide_init ! tidal harmonics394 395 306 CALL sbc_init( Nbb, Nnn, Naa ) ! surface boundary conditions (including sea-ice) 396 397 307 398 308 ! ! Ocean physics … … 400 310 CALL ldf_dyn_init ! Lateral ocean momentum physics 401 311 402 403 312 ! ! Dynamics 404 313 CALL dyn_adv_init ! advection (vector or flux form) 405 406 314 CALL dyn_vor_init ! vorticity term including Coriolis 407 408 315 CALL dyn_ldf_init ! lateral mixing 409 316 410 CALL dyn_spg_init ! surface pressure gradient411 412 317 ! ! Diagnostics 413 CALL flo_init( Nnn ) ! drifting Floats414 415 318 IF( ln_diacfl ) CALL dia_cfl_init ! Initialise CFL diagnostics 416 417 CALL trd_init( Nnn ) ! Mixed-layer/Vorticity/Integral constraints trends 418 319 ! ! Trends diag: switched off 320 l_trddyn = .FALSE. ! No trend diagnostics 419 321 420 322 IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA … … 422 324 IF( ln_timing ) CALL timing_stop( 'nemo_init') 423 325 ! 424 425 326 END SUBROUTINE nemo_init 426 327 … … 440 341 WRITE(numout,*) '~~~~~~~~' 441 342 WRITE(numout,*) ' Namelist namctl' 442 WRITE(numout,*) ' sn_cfctl%l_glochk = ', sn_cfctl%l_glochk443 WRITE(numout,*) ' sn_cfctl%l_allon = ', sn_cfctl%l_allon444 WRITE(numout,*) ' finer control over o/p sn_cfctl%l_config = ', sn_cfctl%l_config445 343 WRITE(numout,*) ' sn_cfctl%l_runstat = ', sn_cfctl%l_runstat 446 344 WRITE(numout,*) ' sn_cfctl%l_trcstat = ', sn_cfctl%l_trcstat … … 454 352 WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr 455 353 WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr 456 WRITE(numout,*) ' level of print nn_print = ', nn_print457 WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls458 WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle459 WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls460 WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle461 WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt462 WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt463 354 WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing 464 355 WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl 465 356 ENDIF 466 357 ! 467 nprint = nn_print ! convert DOCTOR namelist names into OLD names 468 nictls = nn_ictls 469 nictle = nn_ictle 470 njctls = nn_jctls 471 njctle = nn_jctle 472 isplt = nn_isplt 473 jsplt = nn_jsplt 474 358 IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file 475 359 IF(lwp) THEN ! control print 476 360 WRITE(numout,*) … … 482 366 WRITE(numout,*) ' filename to be written cn_domcfg_out = ', TRIM(cn_domcfg_out) 483 367 WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr 484 ENDIF485 IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file486 !487 ! ! Parameter control488 !489 IF( sn_cfctl%l_prtctl .OR. sn_cfctl%l_prttrc ) THEN ! sub-domain area indices for the control prints490 IF( lk_mpp .AND. jpnij > 1 ) THEN491 isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain492 ELSE493 IF( isplt == 1 .AND. jsplt == 1 ) THEN494 CALL ctl_warn( ' - isplt & jsplt are equal to 1', &495 & ' - the print control will be done over the whole domain' )496 ENDIF497 ijsplt = isplt * jsplt ! total number of processors ijsplt498 ENDIF499 IF(lwp) WRITE(numout,*)' - The total number of processors over which the'500 IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt501 !502 ! ! indices used for the SUM control503 IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area504 lsp_area = .FALSE.505 ELSE ! print control done over a specific area506 lsp_area = .TRUE.507 IF( nictls < 1 .OR. nictls > jpiglo ) THEN508 CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )509 nictls = 1510 ENDIF511 IF( nictle < 1 .OR. nictle > jpiglo ) THEN512 CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )513 nictle = jpiglo514 ENDIF515 IF( njctls < 1 .OR. njctls > jpjglo ) THEN516 CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )517 njctls = 1518 ENDIF519 IF( njctle < 1 .OR. njctle > jpjglo ) THEN520 CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )521 njctle = jpjglo522 ENDIF523 ENDIF524 368 ENDIF 525 369 ! … … 571 415 USE diawri , ONLY : dia_wri_alloc 572 416 USE dom_oce , ONLY : dom_oce_alloc 573 USE trc_oce , ONLY : trc_oce_alloc574 USE bdy_oce , ONLY : bdy_oce_alloc575 417 ! 576 418 INTEGER :: ierr 577 419 !!---------------------------------------------------------------------- 578 420 ! 579 ierr = oce_ alloc() ! ocean421 ierr = oce_SWE_alloc() ! ocean 580 422 ierr = ierr + dia_wri_alloc() 581 423 ierr = ierr + dom_oce_alloc() ! ocean domain 582 424 ierr = ierr + zdf_oce_alloc() ! ocean vertical physics 583 ierr = ierr + trc_oce_alloc() ! shared TRC / TRA arrays584 ierr = ierr + bdy_oce_alloc() ! bdy masks (incl. initialization)585 425 ! 586 426 CALL mpp_sum( 'nemogcm', ierr ) … … 590 430 591 431 592 SUBROUTINE nemo_set_cfctl(sn_cfctl, setto , for_all)432 SUBROUTINE nemo_set_cfctl(sn_cfctl, setto ) 593 433 !!---------------------------------------------------------------------- 594 434 !! *** ROUTINE nemo_set_cfctl *** 595 435 !! 596 436 !! ** Purpose : Set elements of the output control structure to setto. 597 !! for_all should be .false. unless all areas are to be598 !! treated identically.599 437 !! 600 438 !! ** Method : Note this routine can be used to switch on/off some 601 !! types of output for selected areas but any output types 602 !! that involve global communications (e.g. mpp_max, glob_sum) 603 !! should be protected from selective switching by the 604 !! for_all argument 605 !!---------------------------------------------------------------------- 606 LOGICAL :: setto, for_all 607 TYPE(sn_ctl) :: sn_cfctl 608 !!---------------------------------------------------------------------- 609 IF( for_all ) THEN 610 sn_cfctl%l_runstat = setto 611 sn_cfctl%l_trcstat = setto 612 ENDIF 439 !! types of output for selected areas. 440 !!---------------------------------------------------------------------- 441 TYPE(sn_ctl), INTENT(inout) :: sn_cfctl 442 LOGICAL , INTENT(in ) :: setto 443 !!---------------------------------------------------------------------- 444 sn_cfctl%l_runstat = setto 445 sn_cfctl%l_trcstat = setto 613 446 sn_cfctl%l_oceout = setto 614 447 sn_cfctl%l_layout = setto … … 620 453 !!====================================================================== 621 454 END MODULE nemogcm 622 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/SWE/stpctl.F90
r13458 r14058 3 3 !! *** MODULE stpctl *** 4 4 !! Ocean run control : gross check of the ocean time stepping 5 !! *** Shallow Water Equation (SWE) case *** 6 !! ( No test on temperature and salinity ) 5 7 !!====================================================================== 6 !! History : OPA ! 1991-03 (G. Madec) Original code 7 !! 6.0 ! 1992-06 (M. Imbard) 8 !! 8.0 ! 1997-06 (A.M. Treguier) 9 !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module 10 !! 2.0 ! 2009-07 (G. Madec) Add statistic for time-spliting 11 !! 3.7 ! 2016-09 (G. Madec) Remove solver 12 !! 4.0 ! 2017-04 (G. Madec) regroup global communications 8 !! History : SWE ! 2020-09 (A. Nasser, S. Techene ) OCE/stpctl adaptated to SWE 13 9 !!---------------------------------------------------------------------- 14 10 … … 21 17 USE zdf_oce , ONLY : ln_zad_Aimp ! ocean vertical physics variables 22 18 USE wet_dry, ONLY : ll_wd, ssh_ref ! reference depth for negative bathy 23 ! 19 ! 24 20 USE diawri ! Standard run outputs (dia_wri_state routine) 25 21 USE in_out_manager ! I/O manager 26 22 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 27 23 USE lib_mpp ! distributed memory computing 28 !29 24 USE netcdf ! NetCDF library 25 30 26 IMPLICIT NONE 31 27 PRIVATE … … 35 31 INTEGER :: nrunid ! netcdf file id 36 32 INTEGER, DIMENSION(2) :: nvarid ! netcdf variable id 33 34 # include "domzgr_substitute.h90" 37 35 !!---------------------------------------------------------------------- 38 36 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 49 47 !! 50 48 !! ** Method : - Save the time step in numstp 49 !! - Print it each 50 time steps 51 50 !! - Stop the run IF problem encountered by setting nstop > 0 52 !! Problems checked: negative sea surface height51 !! Problems checked: e3t0+ssh minimum smaller that 0 53 52 !! |U| maximum larger than 10 m/s 53 !! ( not for SWE : negative sea surface salinity ) 54 54 !! 55 55 !! ** Actions : "time.step" file = last ocean time-step … … 63 63 INTEGER :: idtime, istatus 64 64 INTEGER , DIMENSION(3) :: iareasum, iareamin, iareamax 65 INTEGER , DIMENSION(3, 2) :: iloc ! min/max loc indices65 INTEGER , DIMENSION(3,4) :: iloc ! min/max loc indices 66 66 REAL(wp) :: zzz ! local real 67 67 REAL(wp), DIMENSION(3) :: zmax, zmaxlocal … … 70 70 CHARACTER(len=20) :: clname 71 71 !!---------------------------------------------------------------------- 72 IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid 73 ! 72 74 IF( nstop > 0 .AND. ngrdstop > -1 ) RETURN ! stpctl was already called by a child grid 73 75 ! … … 109 111 ! !== test of local extrema ==! 110 112 ! !== done by all processes at every time step ==! 111 !112 llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region113 llmsk(Nie1: jpi,:,:) = .FALSE.114 llmsk(:, 1:Njs1,:) = .FALSE.115 llmsk(:,Nje1: jpj,:) = .FALSE.116 ! 113 zmax(1) = MINVAL( e3t_0(:,:,1)+ssh(:,:,Kmm) ) ! e3t_Kmm min 114 llmsk(:,:,:) = umask(:,:,:) == 1._wp 115 zmax(2) = MAXVAL( ABS( uu(:,:,:,Kmm) ), mask = llmsk ) ! velocity max (zonal only) 116 zmax(3) = REAL( nstop , wp ) ! stop indicator 117 ! !== get global extrema ==! 118 ! !== done by all processes if writting run.stat ==! 117 119 llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! define only the inner domain 118 120 zmax(1) = MAXVAL( -e3t(:,:,1,Kmm) ), mask = llmsk(:,:,1) ) ! ssh max … … 131 133 IF( ll_wrtruns ) THEN 132 134 WRITE(numrun,9500) kt, zmax(1), zmax(2) 133 istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ -zmax(1)/), (/kt/), (/1/) )134 istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ 135 istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ zmax(1)/), (/kt/), (/1/) ) 136 istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ zmax(2)/), (/kt/), (/1/) ) 135 137 IF( kt == nitend ) istatus = NF90_CLOSE(nrunid) 136 END 138 ENDIF 137 139 ! !== error handling ==! 138 140 ! !== done by all processes at every time step ==! 139 141 ! 140 IF( zmax(1) > 0._wp .OR. & ! negative sea surface height 141 & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s) 142 !!SWE specific : start 143 IF( zmax(1) <= 0._wp .OR. & ! negative e3t_Kmm 144 & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s) 142 145 & ISNAN( zmax(1) + zmax(2) ) .OR. & ! NaN encounter in the tests 143 146 & ABS( zmax(1) + zmax(2) ) > HUGE(1._wp) ) THEN ! Infinity encounter in the tests … … 148 151 IF( lwm .AND. kt /= nitend ) istatus = NF90_CLOSE(nrunid) 149 152 ! get global loc on the min/max 150 llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! define only the inner domain 151 CALL mpp_maxloc( 'stpctl', -e3t(:,:,1,Kmm) , llmsk(:,:,1), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F 152 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 153 CALL mpp_maxloc( 'stpctl', ABS(uu(:,:,:,Kmm)), llmsk(:,:,:), zzz, iloc(1:3,2) ) 153 CALL mpp_minloc( 'stpctl', e3t_0(:,:,1) + ssh(:,:,Kmm), ssmask(:,: ), zzz, iloc(1:2,1) ) ! mpp_maxloc ok if mask = F 154 CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:,Kmm)) , umask(:,:,:), zzz, iloc(1:3,2) ) 154 155 ! find which subdomain has the max. 155 156 iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 … … 164 165 ELSE ! find local min and max locations: 165 166 ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 166 llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! define only the inner domain 167 iloc(1:2,1) = MAXLOC( -e3t(:,:,1,Kmm) , mask = llmsk(:,:,1) ) 168 llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain 169 iloc(1:3,2) = MAXLOC( ABS(uu(:,:,:,Kmm)), mask = llmsk(:,:,:) ) 170 DO ji = 1, 2 ! local domain indices ==> global domain indices, excluding halos 171 iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /) 172 END DO 167 iloc(1:2,1) = MINLOC( e3t_0(:,:,1) + ssh(:,:,Kmm), mask = ssmask(:,: ) == 1._wp ) + (/ nimpp - 1, njmpp - 1 /) 168 iloc(1:3,2) = MAXLOC( ABS( uu(:,:,:, Kmm)), mask = umask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 173 169 iareamin(:) = narea ; iareamax(:) = narea ; iareasum(:) = 1 ! this is local information 174 170 ENDIF 175 171 ! 176 WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m or |U| > 10 m/s or S <= 0 or S >= 100or NaN encounter in the tests'177 CALL wrt_line( ctmp2, kt, ' |e3t| min', -zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) )178 CALL wrt_line( ctmp3, kt, '|U| max' , zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) )172 WRITE(ctmp1,*) ' stp_ctl: e3t0+ssh < 0 m or |U| > 10 m/s or NaN encounter in the tests' 173 CALL wrt_line( ctmp2, kt, 'e3t0+ssh min', zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 174 CALL wrt_line( ctmp3, kt, '|U| max' , zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 179 175 IF( Agrif_Root() ) THEN 180 176 WRITE(ctmp6,*) ' ===> output of last computed fields in output.abort* files' … … 194 190 ! 195 191 ENDIF 192 !!SWE specific : end 196 193 ! 197 194 IF( nstop > 0 ) THEN ! an error was detected and we did not abort yet... … … 200 197 ENDIF 201 198 ! 202 9500 FORMAT(' it :', i8, ' |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16)199 9500 FORMAT(' it :', i8, ' e3t_min: ', D23.16, ' |U|_max: ', D23.16) 203 200 ! 204 201 END SUBROUTINE stp_ctl -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/TOP/PISCES/SED/oce_sed.F90
r13237 r14058 13 13 USE dom_oce , ONLY : glamt => glamt !: longitude of t-point (degre) 14 14 USE dom_oce , ONLY : gphit => gphit !: latitude of t-point (degre) 15 !!st15 16 16 #if ! defined key_qco 17 17 USE dom_oce , ONLY : e3t => e3t !: latitude of t-point (degre) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/TOP/TRP/trcatf.F90
r13295 r14058 32 32 USE trdtra 33 33 # if defined key_qco 34 USE traatf qco34 USE traatf_qco 35 35 # else 36 36 USE traatf -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/BENCH/EXPREF/namelist_cfg_orca025_like
r13461 r14058 178 178 !----------------------------------------------------------------------- 179 179 ln_dynvor_een = .true. ! energy & enstrophy scheme 180 nn_een_e3f = 0! =0 e3f = mi(mj(e3t))/4181 !! =1 e3f = mi(mj(e3t))/mi(mj( tmask))180 nn_e3f_typ = 0 ! =0 e3f = mi(mj(e3t))/4 181 ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) 182 182 / 183 183 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/BENCH/EXPREF/namelist_cfg_orca12_like
r13461 r14058 177 177 !----------------------------------------------------------------------- 178 178 ln_dynvor_een = .true. ! energy & enstrophy scheme 179 nn_e en_e3f= 0 ! =0 e3f = mi(mj(e3t))/4179 nn_e3f_typ = 0 ! =0 e3f = mi(mj(e3t))/4 180 180 ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) 181 181 / -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/BENCH/MY_SRC/usrdef_istate.F90
r13295 r14058 26 26 PRIVATE 27 27 28 PUBLIC usr_def_istate ! called by istate.F90 28 PUBLIC usr_def_istate ! called by istate.F90 29 PUBLIC usr_def_istate_ssh ! called by domqco.F90 29 30 30 31 !! * Substitutions … … 37 38 CONTAINS 38 39 39 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh )40 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) !!st, pssh ) 40 41 !!---------------------------------------------------------------------- 41 42 !! *** ROUTINE usr_def_istate *** … … 52 53 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 53 54 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 54 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height55 !!st REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height 55 56 ! 56 57 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace … … 79 80 ! 80 81 ! sea level: 81 pssh(:,:) = z2d(:,:) ! +/- 0.05 m82 !!st pssh(:,:) = z2d(:,:) ! +/- 0.05 m 82 83 ! 83 84 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) … … 95 96 pv( :,:,jpk ) = 0._wp 96 97 ! 97 CALL lbc_lnk('usrdef_istate', pssh, 'T', 1. ) ! apply boundary conditions98 !!st CALL lbc_lnk('usrdef_istate', pssh, 'T', 1. ) ! apply boundary conditions 98 99 CALL lbc_lnk('usrdef_istate', pts, 'T', 1. ) ! apply boundary conditions 99 100 CALL lbc_lnk('usrdef_istate', pu, 'U', -1. ) ! apply boundary conditions … … 102 103 END SUBROUTINE usr_def_istate 103 104 105 106 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 107 !!---------------------------------------------------------------------- 108 !! *** ROUTINE usr_def_istate_ssh *** 109 !! 110 !! ** Purpose : Initialization of ssh 111 !! Here BENCH configuration 112 !! 113 !! ** Method : Set ssh 114 !!---------------------------------------------------------------------- 115 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 116 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] 117 ! 118 INTEGER :: ji, jj 119 INTEGER :: igloi, igloj ! to be removed in the future, see usr_def_istate comment 120 !!---------------------------------------------------------------------- 121 ! 122 IF(lwp) WRITE(numout,*) 123 IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : BENCH configuration, analytical definition of initial ssh' 124 ! 125 igloi = Ni0glo + 2 * COUNT( (/ jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 /) ) 126 igloj = Nj0glo + 2 * COUNT( (/ jperio == 2 .OR. jperio == 7 /) ) + 1 * COUNT( (/ jperio >= 4 .AND. jperio <= 6 /) ) 127 ! sea level: +/- 0.05 m 128 DO_2D( 0, 0, 0, 0 ) 129 pssh(ji,jj) = 0.1 * ( 0.5 - REAL( mig0_oldcmp(ji) + (mjg0_oldcmp(jj)-1) * igloi, wp ) / REAL( igloi * igloj, wp ) ) 130 END_2D 131 ! 132 CALL lbc_lnk('usrdef_istate', pssh, 'T', 1. ) ! apply boundary conditions 133 ! 134 END SUBROUTINE usr_def_istate_ssh 135 104 136 !!====================================================================== 105 137 END MODULE usrdef_istate -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/CANAL/EXPREF/namelist_cfg
r13558 r14058 235 235 ln_dynvor_mix = .false. ! mixed scheme 236 236 ln_dynvor_een = .false. ! energy & enstrophy scheme 237 ln_dynvor_enT = .false. ! energy conserving scheme (T-point)237 r_enT = .false. ! energy conserving scheme (T-point) 238 238 ln_dynvor_eeT = .true. ! energy conserving scheme (een using e3t) 239 nn_e en_e3f= 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)239 nn_e3f_typ = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) 240 240 / 241 241 !----------------------------------------------------------------------- … … 319 319 !! namdiu Cool skin and warm layer models (default: OFF) 320 320 !! namdiu Cool skin and warm layer models (default: OFF) 321 <<<<<<< .working322 !! namflo float parameters (default: OFF)323 !! nam_diadct transports through some sections (default: OFF)324 ||||||| .merge-left.r13465325 !! namflo float parameters (default: OFF)326 !! nam_diaharm Harmonic analysis of tidal constituents (default: OFF)327 !! nam_diadct transports through some sections (default: OFF)328 =======329 321 !! namflo float parameters ("key_float") 330 322 !! nam_diaharm Harmonic analysis of tidal constituents ("key_diaharm") 331 323 !! namdct transports through some sections ("key_diadct") 332 324 !! nam_diatmb Top Middle Bottom Output (default: OFF) 333 >>>>>>> .merge-right.r13470334 325 !! nam_dia25h 25h Mean Output (default: OFF) 335 326 !! namnc4 netcdf4 chunking and compression settings ("key_netcdf4") -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/CANAL/MY_SRC/usrdef_istate.F90
r13472 r14058 26 26 PRIVATE 27 27 28 PUBLIC usr_def_istate ! called by istate.F90 28 PUBLIC usr_def_istate ! called by istate.F90 29 PUBLIC usr_def_istate_ssh ! called by sshwzv.F90 29 30 30 31 !! * Substitutions … … 37 38 CONTAINS 38 39 39 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh)40 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 40 41 !!---------------------------------------------------------------------- 41 42 !! *** ROUTINE usr_def_istate *** … … 52 53 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 53 54 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 54 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height55 55 ! 56 56 INTEGER :: ji, jj, jk, jl ! dummy loop indices … … 87 87 88 88 CASE(0) ! rest 89 90 ! sea level: 91 pssh(:,:) = 0. 89 ! 92 90 ! temperature: 93 91 pts(:,:,:,jp_tem) = 10._wp … … 99 97 100 98 CASE(1) ! geostrophic zonal jet from -zjety to +zjety 101 102 ! sea level: 103 SELECT CASE( nn_fcase ) 104 CASE(0) ! f = f0 105 ! sea level: ssh = - fuy / g 106 WHERE( ABS(gphit) <= zjety ) 107 pssh(:,:) = - ff_t(:,:) * rn_uzonal * gphit(:,:) * 1.e3 / grav 108 ELSEWHERE 109 pssh(:,:) = - ff_t(:,:) * rn_uzonal * SIGN(zjety, gphit(:,:)) * 1.e3 / grav 110 END WHERE 111 CASE(1) ! f = f0 + beta*y 112 ! sea level: ssh = - u / g * ( fy + 0.5 * beta * y^2 ) 113 zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra 114 WHERE( ABS(gphit) <= zjety ) 115 pssh(:,:) = - rn_uzonal / grav * ( zf0 * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 ) 116 ELSEWHERE 117 pssh(:,:) = - rn_uzonal / grav * ( zf0 * SIGN(zjety, gphit(:,:)) * 1.e3 & 118 & + 0.5 * zbeta * zjety * zjety * 1.e6 ) 119 END WHERE 120 END SELECT 99 ! 121 100 ! temperature: 122 101 pts(:,:,:,jp_tem) = 10._wp … … 139 118 ! 140 119 CASE(2) ! geostrophic zonal current shear 141 142 ! sea level: 143 SELECT CASE( nn_fcase ) 144 CASE(0) ! f = f0 145 ! sea level: ssh = - fuy / g 146 WHERE( ABS(gphit) <= zjety ) 147 pssh(:,:) = - ff_t(:,:) * rn_uzonal * ABS(gphit(:,:)) * 1.e3 / grav 148 ELSEWHERE 149 pssh(:,:) = - ff_t(:,:) * rn_uzonal * zjety * 1.e3 / grav 150 END WHERE 151 CASE(1) ! f = f0 + beta*y 152 ! sea level: ssh = - u / g * ( fy + 0.5 * beta * y^2 ) 153 zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra 154 WHERE( ABS(gphit) <= zjety ) 155 pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav & 156 & * ( zf0 * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 ) 157 ELSEWHERE 158 pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav & 159 & * ( zf0 * SIGN(zjety, gphit(:,:)) * 1.e3 + 0.5 * zbeta * zjety * zjety * 1.e6 ) 160 END WHERE 161 END SELECT 120 ! 162 121 ! temperature: 163 122 pts(:,:,:,jp_tem) = 10._wp … … 176 135 ! 177 136 CASE(3) ! gaussian zonal currant 178 137 ! 179 138 ! zonal current 180 139 DO jk=1, jpkm1 … … 182 141 pu(:,:,jk) = rn_uzonal * EXP( - 0.5 * gphit(:,:)**2 / rn_lambda**2 ) 183 142 END DO 184 185 ! sea level:186 pssh(:,1) = - ff_t(:,1) / grav * pu(:,1,1) * e2t(:,1)187 DO jl=1, jpnj188 DO_2D( 0, 0, 0, 0 )189 pssh(ji,jj) = pssh(ji,jj-1) - ff_t(ji,jj) / grav * pu(ji,jj,1) * e2t(ji,jj)190 END_2D191 CALL lbc_lnk( 'usrdef_istate', pssh, 'T', 1. )192 END DO193 194 143 ! temperature: 195 144 pts(:,:,:,jp_tem) = 10._wp … … 202 151 ! 203 152 CASE(4) ! geostrophic zonal pulse 204 153 ! 205 154 DO_2D( 1, 1, 1, 1 ) 206 155 IF ( ABS(glamt(ji,jj)) <= zjetx ) THEN … … 210 159 ELSE 211 160 zdu = 0. 212 END 161 ENDIF 213 162 IF ( ABS(gphit(ji,jj)) <= zjety ) THEN 214 pssh(ji,jj) = - ff_t(ji,jj) * zdu * gphit(ji,jj) * 1.e3 / grav215 163 pu(ji,jj,:) = zdu 216 164 pts(ji,jj,:,jp_sal) = zdu / rn_uzonal + 1. 217 165 ELSE 218 pssh(ji,jj) = - ff_t(ji,jj) * zdu * SIGN(zjety,gphit(ji,jj)) * 1.e3 / grav219 166 pu(ji,jj,:) = 0. 220 167 pts(ji,jj,:,jp_sal) = 1. 221 END 222 END_2D 223 168 ENDIF 169 END_2D 170 ! 224 171 ! temperature: 225 172 pts(:,:,:,jp_tem) = 10._wp * ptmask(:,:,:) 226 173 pv(:,:,:) = 0. 227 228 229 174 ! 175 CASE(5) ! vortex 176 ! 230 177 zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) 231 zumax = rn_vtxmax * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic178 zumax = rn_vtxmax * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic 232 179 zlambda = SQRT(2._wp)*rn_lambda*1.e3 ! Horizontal scale in meters 233 180 zn2 = 3.e-3**2 … … 242 189 ! Surface pressure: P(x,y,z) = F(z) * Psurf(x,y) 243 190 zpsurf = zP0 * EXP(-(zx**2+zy**2)*zr_lambda2) - rho0 * ff_t(ji,jj) * rn_uzonal * zy 244 ! Sea level:245 pssh(ji,jj) = 0.246 DO jl=1,5247 zdt = pssh(ji,jj)248 zdzF = (1._wp - EXP(zdt-zH)) / (zH - 1._wp + EXP(-zH)) ! F'(z)249 zrho1 = rho0 * (1._wp + zn2*zdt/grav) - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y)250 pssh(ji,jj) = zpsurf / (zrho1*grav) * ptmask(ji,jj,1) ! ssh = Psurf / (Rho*g)251 END DO252 191 ! temperature: 253 192 DO jk=1,jpk … … 299 238 ! 300 239 END SELECT 301 240 ! 241 CALL lbc_lnk( 'usrdef_istate', pts , 'T', 1. ) 242 CALL lbc_lnk_multi( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. ) 243 244 END SUBROUTINE usr_def_istate 245 246 247 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 248 !!---------------------------------------------------------------------- 249 !! *** ROUTINE usr_def_istate_ssh *** 250 !! 251 !! ** Purpose : Initialization of the dynamics and tracers 252 !! Here CANAL configuration 253 !! 254 !! ** Method : Set ssh 255 !!---------------------------------------------------------------------- 256 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 257 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height 258 ! 259 INTEGER :: ji, jj, jk, jl ! dummy loop indices 260 REAL(wp) :: zx, zy, zP0, zumax, zlambda, zr_lambda2, zn2, zf0, zH, zrho1, za, zf, zdzF 261 REAL(wp) :: zpsurf, zdyPs, zdxPs 262 REAL(wp) :: zdt, zdu, zdv 263 REAL(wp) :: zjetx, zjety, zbeta 264 REAL(wp), DIMENSION(jpi,jpj) :: zrandom 265 !!---------------------------------------------------------------------- 266 ! 267 IF(lwp) WRITE(numout,*) 268 IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : CANAL configuration, analytical definition of initial state' 269 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ ' 270 ! 271 IF (ln_sshnoise) CALL RANDOM_NUMBER(zrandom) 272 zjetx = ABS(rn_ujetszx)/2. 273 zjety = ABS(rn_ujetszy)/2. 274 ! 275 SELECT CASE(nn_initcase) 276 CASE(0) !== rest ==! 277 ! 278 pssh(:,:) = 0. 279 ! 280 CASE(1) !== geostrophic zonal jet from -zjety to +zjety ==! 281 ! 282 SELECT CASE( nn_fcase ) 283 CASE(0) !* f = f0 : ssh = - fuy / g 284 WHERE( ABS(gphit) <= zjety ) 285 pssh(:,:) = - ff_t(:,:) * rn_uzonal * gphit(:,:) * 1.e3 / grav 286 ELSEWHERE 287 pssh(:,:) = - ff_t(:,:) * rn_uzonal * SIGN(zjety, gphit(:,:)) * 1.e3 / grav 288 END WHERE 289 CASE(1) !* f = f0 + beta*y : ssh = - u / g * ( fy + 0.5 * beta * y^2 ) 290 zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra 291 WHERE( ABS(gphit) <= zjety ) 292 pssh(:,:) = - rn_uzonal / grav * ( ff_t(:,:) * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 ) 293 ELSEWHERE 294 pssh(:,:) = - rn_uzonal / grav * ( ff_t(:,:) * SIGN(zjety, gphit(:,:)) * 1.e3 & 295 & + 0.5 * zbeta * zjety * zjety * 1.e6 ) 296 END WHERE 297 END SELECT 298 ! 299 CASE(2) !== geostrophic zonal current shear ==! 300 ! 301 SELECT CASE( nn_fcase ) 302 CASE(0) !* f = f0 : ssh = - fuy / g 303 WHERE( ABS(gphit) <= zjety ) 304 pssh(:,:) = - ff_t(:,:) * rn_uzonal * ABS(gphit(:,:)) * 1.e3 / grav 305 ELSEWHERE 306 pssh(:,:) = - ff_t(:,:) * rn_uzonal * zjety * 1.e3 / grav 307 END WHERE 308 CASE(1) !* f = f0 + beta*y : ssh = - u / g * ( fy + 0.5 * beta * y^2 ) 309 zbeta = 2._wp * omega * COS( rad * rn_ppgphi0 ) / ra 310 WHERE( ABS(gphit) <= zjety ) 311 pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav & 312 & * ( ff_t(:,:) * gphit(:,:) * 1.e3 + 0.5 * zbeta * gphit(:,:) * gphit(:,:) * 1.e6 ) 313 ELSEWHERE 314 pssh(:,:) = - SIGN(rn_uzonal, gphit(:,:)) / grav & 315 & * ( ff_t(:,:) * SIGN(zjety, gphit(:,:)) * 1.e3 + 0.5 * zbeta * zjety * zjety * 1.e6 ) 316 END WHERE 317 END SELECT 318 ! 319 CASE(3) !== gaussian zonal currant ==! 320 ! 321 pssh(:,1) = - ff_t(:,1) / grav * e2t(:,1) * rn_uzonal * EXP( - 0.5 * gphit(:,1)**2 / rn_lambda**2 ) 322 DO jl=1, jpnj 323 DO_2D( 0, 0, 0, 0 ) 324 pssh(ji,jj) = pssh(ji,jj-1) - ff_t(ji,jj) / grav * rn_uzonal * EXP( - 0.5 * gphit(ji,jj)**2 / rn_lambda**2 ) * e2t(ji,jj) 325 END_2D 326 CALL lbc_lnk( 'usrdef_istate_ssh', pssh, 'T', 1. ) 327 END DO 328 ! 329 CASE(4) !== geostrophic zonal pulse !!st need to implement a way to separate ssh properly ==! 330 ! 331 DO_2D( 1, 1, 1, 1 ) 332 IF ( ABS(glamt(ji,jj)) <= zjetx ) THEN 333 zdu = rn_uzonal 334 ELSEIF ( ABS(glamt(ji,jj)) <= zjetx + 100. ) THEN 335 zdu = rn_uzonal * ( ( zjetx-ABS(glamt(ji,jj)) )/100. + 1. ) 336 ELSE 337 zdu = 0. 338 ENDIF 339 IF ( ABS(gphit(ji,jj)) <= zjety ) THEN 340 pssh(ji,jj) = - ff_t(ji,jj) * zdu * gphit(ji,jj) * 1.e3 / grav 341 ELSE 342 pssh(ji,jj) = - ff_t(ji,jj) * zdu * SIGN(zjety,gphit(ji,jj)) * 1.e3 / grav 343 ENDIF 344 END_2D 345 ! 346 CASE(5) !== vortex ==! 347 ! 348 zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) 349 zumax = rn_vtxmax * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic 350 zlambda = SQRT(2._wp)*rn_lambda ! Horizontal scale in meters 351 zn2 = 3.e-3**2 352 zH = 0.5_wp * 5000._wp 353 ! 354 zr_lambda2 = 1._wp / zlambda**2 355 zP0 = rho0 * zf0 * zumax * zlambda * SQRT(EXP(1._wp)/2._wp) 356 ! 357 DO_2D( 1, 1, 1, 1 ) 358 zx = glamt(ji,jj) * 1.e3 359 zy = gphit(ji,jj) * 1.e3 360 ! ! Surface pressure: P(x,y,z) = F(z) * Psurf(x,y) 361 zpsurf = zP0 * EXP(-(zx**2+zy**2)*zr_lambda2) - rho0 * ff_t(ji,jj) * rn_uzonal * zy 362 pssh(ji,jj) = 0. 363 DO jl=1,5 364 zdt = pssh(ji,jj) 365 zdzF = (1._wp - EXP(zdt-zH)) / (zH - 1._wp + EXP(-zH)) ! F'(z) 366 zrho1 = rho0 * (1._wp + zn2*zdt/grav) - zdzF * zpsurf / grav ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) 367 pssh(ji,jj) = zpsurf / (zrho1*grav) * ptmask(ji,jj,1) ! ssh = Psurf / (Rho*g) 368 END DO 369 END_2D 370 ! 371 END SELECT 372 ! !== add noise ==! 302 373 IF (ln_sshnoise) THEN 303 374 CALL RANDOM_SEED() 304 375 CALL RANDOM_NUMBER(zrandom) 305 376 pssh(:,:) = pssh(:,:) + ( 0.1 * zrandom(:,:) - 0.05 ) 306 END IF 307 CALL lbc_lnk( 'usrdef_istate', pssh, 'T', 1. ) 308 CALL lbc_lnk( 'usrdef_istate', pts , 'T', 1. ) 309 CALL lbc_lnk_multi( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. ) 310 311 END SUBROUTINE usr_def_istate 312 377 ENDIF 378 CALL lbc_lnk( 'usrdef_istate_ssh', pssh, 'T', 1. ) 379 ! 380 END SUBROUTINE usr_def_istate_ssh 381 313 382 !!====================================================================== 314 383 END MODULE usrdef_istate -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/CPL_OASIS/EXPREF/namelist_cfg
r13558 r14058 367 367 !----------------------------------------------------------------------- 368 368 ln_dynvor_een = .true. ! energy & enstrophy scheme 369 nn_een_e3f = 0 ! =0 e3f = mean masked e3t divided by 4370 369 / 371 370 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/ISOMIP+/MY_SRC/istate.F90
r13583 r14058 117 117 CALL dta_tsd( nit000, 'ini', ts(:,:,:,:,Kbb) ) ! read 3D T and S data at nit000 118 118 ! 119 ssh(:,:,Kbb) = 0._wp ! set the ocean at rest 120 uu (:,:,:,Kbb) = 0._wp 121 vv (:,:,:,Kbb) = 0._wp 119 uu (:,:,:,Kbb) = 0._wp 120 vv (:,:,:,Kbb) = 0._wp 122 121 ! 123 IF( ll_wd ) THEN124 ssh(:,:,Kbb) = -ssh_ref ! Added in 30 here for bathy that adds 30 as Iterative test CEOD125 !126 ! Apply minimum wetdepth criterion127 !128 DO_2D( 1, 1, 1, 1 )129 IF( ht_0(ji,jj) + ssh(ji,jj,Kbb) < rn_wdmin1 ) THEN130 ssh(ji,jj,Kbb) = tmask(ji,jj,1)*( rn_wdmin1 - (ht_0(ji,jj)) )131 ENDIF132 END_2D133 ENDIF134 !135 122 ELSE ! user defined initial T and S 136 123 DO jk = 1, jpk 137 124 zgdept(:,:,jk) = gdept(:,:,jk,Kbb) 138 125 END DO 139 CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb) , ssh(:,:,Kbb))126 CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb) ) 140 127 ENDIF 141 128 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones 142 ssh (:,:,Kmm) = ssh(:,:,Kbb)143 129 uu (:,:,:,Kmm) = uu (:,:,:,Kbb) 144 130 vv (:,:,:,Kmm) = vv (:,:,:,Kbb) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/ISOMIP/MY_SRC/usrdef_istate.F90
r10074 r14058 9 9 !! History : NEMO ! 2016-11 (S. Flavoni) Original code 10 10 !! ! 2017-02 (P. Mathiot, S. Flavoni) Adapt code to ISOMIP case 11 !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh 11 12 !!---------------------------------------------------------------------- 12 13 … … 24 25 PRIVATE 25 26 26 PUBLIC usr_def_istate ! called by istate.F90 27 PUBLIC usr_def_istate ! called by istate.F90 28 PUBLIC usr_def_istate_ssh ! called by domqco.F90 27 29 28 30 !!---------------------------------------------------------------------- … … 33 35 CONTAINS 34 36 35 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh)37 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 36 38 !!---------------------------------------------------------------------- 37 39 !! *** ROUTINE usr_def_istate *** … … 48 50 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 49 51 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 50 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height51 !52 INTEGER :: jk ! dummy loop indices53 52 !!---------------------------------------------------------------------- 54 53 ! … … 58 57 pu (:,:,:) = 0._wp ! ocean at rest 59 58 pv (:,:,:) = 0._wp 60 pssh(:,:) = 0._wp61 !62 59 ! ! T & S profiles 63 60 pts(:,:,:,jp_tem) = - 1.9 * ptmask(:,:,:) ! ISOMIP configuration : start from constant T+S fields … … 66 63 END SUBROUTINE usr_def_istate 67 64 65 66 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 67 !!---------------------------------------------------------------------- 68 !! *** ROUTINE usr_def_istate_ssh *** 69 !! 70 !! ** Purpose : Initialization of ssh 71 !! Here ISOMIP configuration 72 !! 73 !! ** Method : set ssh to 0 74 !!---------------------------------------------------------------------- 75 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 76 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] 77 !!---------------------------------------------------------------------- 78 ! 79 IF(lwp) WRITE(numout,*) 80 IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : ISOMIP configuration, analytical definition of initial state' 81 ! 82 pssh(:,:) = 0._wp 83 ! 84 END SUBROUTINE usr_def_istate_ssh 85 68 86 !!====================================================================== 69 87 END MODULE usrdef_istate -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_flux_ubs_cfg
r13558 r14058 201 201 ln_dynvor_mix = .false. ! mixed scheme 202 202 ln_dynvor_een = .false. ! energy & enstrophy scheme 203 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)204 203 / 205 204 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/LOCK_EXCHANGE/EXPREF/namelist_FCT2_vect_ens_cfg
r13476 r14058 129 129 ln_dynvor_mix = .false. ! mixed scheme 130 130 ln_dynvor_een = .false. ! energy & enstrophy scheme 131 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)132 131 / 133 132 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/LOCK_EXCHANGE/MY_SRC/usrdef_istate.F90
r12489 r14058 8 8 !!====================================================================== 9 9 !! History : NEMO ! 2016-03 (S. Flavoni, G. Madec) Original code 10 !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh 10 11 !!---------------------------------------------------------------------- 11 12 … … 23 24 PRIVATE 24 25 25 PUBLIC usr_def_istate ! called by istate.F90 26 PUBLIC usr_def_istate ! called by istate.F90 27 PUBLIC usr_def_istate_ssh ! called by domqco.F90 26 28 27 29 !!---------------------------------------------------------------------- … … 32 34 CONTAINS 33 35 34 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh)36 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 35 37 !!---------------------------------------------------------------------- 36 38 !! *** ROUTINE usr_def_istate *** … … 47 49 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 48 50 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 49 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height50 51 ! 51 52 INTEGER :: jk ! dummy loop indices … … 65 66 pu (:,:,:) = 0._wp ! ocean at rest 66 67 pv (:,:,:) = 0._wp 67 pssh(:,:) = 0._wp68 68 ! 69 69 ! ! T & S profiles … … 78 78 END SUBROUTINE usr_def_istate 79 79 80 81 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 82 !!---------------------------------------------------------------------- 83 !! *** ROUTINE usr_def_istate_ssh *** 84 !! 85 !! ** Purpose : Initialization of ssh 86 !! Here LOCK_EXCHANGE configuration 87 !! 88 !! ** Method : set ssh to 0 89 !!---------------------------------------------------------------------- 90 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 91 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] 92 !!---------------------------------------------------------------------- 93 ! 94 IF(lwp) WRITE(numout,*) 95 IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : LOCK_EXCHANGE configuration, analytical definition of initial state' 96 ! 97 pssh(:,:) = 0._wp 98 ! 99 END SUBROUTINE usr_def_istate_ssh 100 80 101 !!====================================================================== 81 102 END MODULE usrdef_istate -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_cen-ahm1000_cfg
r13558 r14058 139 139 ln_dynvor_mix = .false. ! mixed scheme 140 140 ln_dynvor_een = .false. ! energy & enstrophy scheme 141 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)142 141 / 143 142 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/OVERFLOW/EXPREF/namelist_sco_FCT2_flux_ubs_cfg
r13558 r14058 139 139 ln_dynvor_mix = .false. ! mixed scheme 140 140 ln_dynvor_een = .false. ! energy & enstrophy scheme 141 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)142 141 / 143 142 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_cen-ahm1000_cfg
r13558 r14058 139 139 ln_dynvor_mix = .false. ! mixed scheme 140 140 ln_dynvor_een = .false. ! energy & enstrophy scheme 141 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)142 141 / 143 142 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/OVERFLOW/EXPREF/namelist_sco_FCT4_flux_ubs_cfg
r13558 r14058 139 139 ln_dynvor_mix = .false. ! mixed scheme 140 140 ln_dynvor_een = .false. ! energy & enstrophy scheme 141 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)142 141 / 143 142 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/OVERFLOW/EXPREF/namelist_zps_FCT2_flux_ubs_cfg
r13558 r14058 139 139 ln_dynvor_mix = .false. ! mixed scheme 140 140 ln_dynvor_een = .false. ! energy & enstrophy scheme 141 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)142 141 / 143 142 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_flux_ubs_cfg
r13558 r14058 201 201 ln_dynvor_mix = .false. ! mixed scheme 202 202 ln_dynvor_een = .false. ! energy & enstrophy scheme 203 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)204 203 / 205 204 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/OVERFLOW/EXPREF/namelist_zps_FCT4_vect_een_cfg
r13558 r14058 139 139 ln_dynvor_mix = .false. ! mixed scheme 140 140 ln_dynvor_een = .true. ! energy & enstrophy scheme 141 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)142 141 / 143 142 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/OVERFLOW/MY_SRC/usrdef_istate.F90
r12489 r14058 8 8 !!============================================================================== 9 9 !! History : NEMO ! 2016-03 (S. Flavoni, G. Madec) Original code 10 !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh 10 11 !!---------------------------------------------------------------------- 11 12 … … 23 24 PRIVATE 24 25 25 PUBLIC usr_def_istate ! called by istate.F90 26 26 PUBLIC usr_def_istate ! called by istate.F90 27 PUBLIC usr_def_istate_ssh ! called by domqco.F90 28 27 29 !!---------------------------------------------------------------------- 28 30 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 32 34 CONTAINS 33 35 34 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh)36 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 35 37 !!---------------------------------------------------------------------- 36 38 !! *** ROUTINE usr_def_istate *** … … 47 49 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 48 50 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 49 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height50 51 ! 51 52 INTEGER :: jk ! dummy loop indices … … 65 66 pu (:,:,:) = 0._wp ! ocean at rest 66 67 pv (:,:,:) = 0._wp 67 pssh(:,:) = 0._wp68 68 ! 69 69 ! ! T & S profiles … … 78 78 END SUBROUTINE usr_def_istate 79 79 80 81 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 82 !!---------------------------------------------------------------------- 83 !! *** ROUTINE usr_def_istate_ssh *** 84 !! 85 !! ** Purpose : Initialization of the ssh 86 !! Here OVERFLOW configuration 87 !! 88 !! ** Method : set ssh to 0 89 !!---------------------------------------------------------------------- 90 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 91 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] 92 !!---------------------------------------------------------------------- 93 ! 94 IF(lwp) WRITE(numout,*) 95 IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : OVERFLOW configuration, analytical definition of initial state' 96 ! 97 pssh(:,:) = 0._wp 98 ! 99 END SUBROUTINE usr_def_istate_ssh 100 80 101 !!====================================================================== 81 102 END MODULE usrdef_istate -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90
r13295 r14058 193 193 pdept(ji,jj,ik+1) = pdepw(ji,jj,ik+1) + pe3t (ji,jj,ik+1) * 0.5_wp 194 194 pe3w (ji,jj,ik+1) = pdept(ji,jj,ik+1) - pdept(ji,jj,ik) ! = pe3t (ji,jj,ik ) 195 pe3w (ji,jj,ik ) = pdept(ji,jj,ik ) - pdept(ji,jj,ik-1) ! st caution ik > 1 195 196 END_2D 196 197 ! ! bottom scale factors and depth at U-, V-, UW and VW-points -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/VORTEX/EXPREF/1_namelist_cfg
r13558 r14058 195 195 ln_dynvor_mix = .false. ! mixed scheme 196 196 ln_dynvor_een = .true. ! energy & enstrophy scheme 197 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)198 197 / 199 198 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/VORTEX/EXPREF/namelist_cfg
r13558 r14058 188 188 ln_dynvor_mix = .false. ! mixed scheme 189 189 ln_dynvor_een = .true. ! energy & enstrophy scheme 190 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)191 190 / 192 191 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/VORTEX/MY_SRC/usrdef_istate.F90
r13295 r14058 8 8 !!====================================================================== 9 9 !! History : NEMO ! 2017-11 (J. Chanut) Original code 10 !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh 10 11 !!---------------------------------------------------------------------- 11 12 … … 26 27 PRIVATE 27 28 28 PUBLIC usr_def_istate ! called by istate.F90 29 PUBLIC usr_def_istate ! called by istate.F90 30 PUBLIC usr_def_istate_ssh ! called by domqco.F90 29 31 30 32 !! * Substitutions … … 37 39 CONTAINS 38 40 39 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv , pssh)41 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 40 42 !!---------------------------------------------------------------------- 41 43 !! *** ROUTINE usr_def_istate *** … … 52 54 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 53 55 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 54 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height55 56 ! 56 57 INTEGER :: ji, jj, jk ! dummy loop indices … … 67 68 zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) 68 69 zumax = 1._wp * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic 69 zlambda = SQRT(2._wp)*60.e3 ! Horizontal scale in meters 70 zlambda = SQRT(2._wp)*60.e3 ! Horizontal scale in meters 70 71 zn2 = 3.e-3**2 71 72 zH = 0.5_wp * 5000._wp 72 73 ! 73 74 zP0 = rho0 * zf0 * zumax * zlambda * SQRT(EXP(1._wp)/2._wp) 74 !75 ! Sea level:76 za = -zP0 * (1._wp-EXP(-zH)) / (grav*(zH-1._wp + EXP(-zH)))77 DO_2D( 1, 1, 1, 1 )78 zx = glamt(ji,jj) * 1.e379 zy = gphit(ji,jj) * 1.e380 zrho1 = rho0 + za * EXP(-(zx**2+zy**2)/zlambda**2)81 pssh(ji,jj) = zP0 * EXP(-(zx**2+zy**2)/zlambda**2)/(zrho1*grav) * ptmask(ji,jj,1)82 END_2D83 75 ! 84 76 ! temperature: … … 134 126 END SUBROUTINE usr_def_istate 135 127 128 129 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 130 !!---------------------------------------------------------------------- 131 !! *** ROUTINE usr_def_istate *** 132 !! 133 !! ** Purpose : Initialization of ssh 134 !! Here VORTEX configuration 135 !! 136 !! ** Method : Set ssh according to a gaussian anomaly of pressure and associated 137 !! geostrophic velocities 138 !!---------------------------------------------------------------------- 139 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 140 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height [m] 141 ! 142 INTEGER :: ji, jj ! dummy loop indices 143 REAL(wp) :: zx, zy, zP0, zumax, zlambda, zf0, zH, zrho1, za 144 !!---------------------------------------------------------------------- 145 ! 146 IF(lwp) WRITE(numout,*) 147 IF(lwp) WRITE(numout,*) 'usr_def_istate_ssh : VORTEX configuration, analytical definition of initial state' 148 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ ' 149 ! 150 ! 151 ! 152 zf0 = 2._wp * omega * SIN( rad * rn_ppgphi0 ) 153 zumax = 1._wp * SIGN(1._wp, zf0) ! Here Anticyclonic: set zumax=-1 for cyclonic 154 zlambda = SQRT(2._wp)*60.e3 ! Horizontal scale in meters 155 zH = 0.5_wp * 5000._wp 156 ! 157 zP0 = rho0 * zf0 * zumax * zlambda * SQRT(EXP(1._wp)/2._wp) 158 ! 159 ! Sea level: 160 za = -zP0 * (1._wp-EXP(-zH)) / (grav*(zH-1._wp + EXP(-zH))) 161 DO_2D( 1, 1, 1, 1 ) 162 zx = glamt(ji,jj) * 1.e3 163 zy = gphit(ji,jj) * 1.e3 164 zrho1 = rho0 + za * EXP(-(zx**2+zy**2)/zlambda**2) 165 pssh(ji,jj) = zP0 * EXP(-(zx**2+zy**2)/zlambda**2)/(zrho1*grav) * ptmask(ji,jj,1) 166 END_2D 167 168 END SUBROUTINE usr_def_istate_ssh 169 136 170 !!====================================================================== 137 171 END MODULE usrdef_istate -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/VORTEX/cpp_VORTEX.fcm
r12208 r14058 1 bld::tool::fppkeys key_iomput key_mpp_mpi key_agrif 1 bld::tool::fppkeys key_iomput key_mpp_mpi key_agrif -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/WAD/EXPREF/namelist_cfg
r13558 r14058 330 330 ln_dynvor_mix = .false. ! mixed scheme 331 331 ln_dynvor_een = .true. ! energy & enstrophy scheme 332 nn_een_e3f = 0 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1)333 332 / 334 333 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/WAD/MY_SRC/usrdef_istate.F90
r13295 r14058 7 7 !! User defined : set the initial state of a user configuration 8 8 !!====================================================================== 9 !! History : 4.0 ! 2016-03 (S. Flavoni) Original code 9 !! History : 4.0 ! 2016-03 (S. Flavoni) Original code 10 !! ! 2020-11 (S. Techene, G. Madec) separate tsuv from ssh 10 11 !!---------------------------------------------------------------------- 11 12 … … 24 25 PRIVATE 25 26 26 PUBLIC usr_def_istate ! called in istate.F90 27 PUBLIC usr_def_istate ! called in istate.F90 28 PUBLIC usr_def_istate_ssh ! called in sshwzv.F90 27 29 28 30 !! * Substitutions … … 34 36 !!---------------------------------------------------------------------- 35 37 CONTAINS 36 37 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) 38 39 40 SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv ) 38 41 !!---------------------------------------------------------------------- 39 42 !! *** ROUTINE usr_def_istate *** … … 42 45 !! Here WAD_TEST_CASES configuration 43 46 !! 44 !! ** Method : - set temprature field47 q !! ** Method : - set temprature field 45 48 !! - set salinity field 46 49 !!---------------------------------------------------------------------- … … 50 53 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pu ! i-component of the velocity [m/s] 51 54 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] 52 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height53 55 INTEGER :: ji, jj ! dummy loop indices 54 56 REAL(wp) :: zi, zj … … 66 68 pu (:,:,:) = 0._wp ! ocean at rest 67 69 pv (:,:,:) = 0._wp 68 pssh(:,:) = 0._wp69 !70 70 ! ! T & S profiles 71 71 pts(:,:,:,jp_tem) = 10._wp * ptmask(:,:,:) … … 83 83 CASE ( 1 ) ! WAD 1 configuration 84 84 ! ! ==================== 85 !86 85 IF(lwp) WRITE(numout,*) 87 86 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Closed box with EW linear bottom slope' 88 87 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 89 !90 do ji = 1,jpi91 pssh(ji,:) = ( -5.5_wp + 7.4_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1)92 end do93 88 ! ! ==================== 94 89 CASE ( 2, 8 ) ! WAD 2 configuration 95 90 ! ! ==================== 96 !97 91 IF(lwp) WRITE(numout,*) 98 92 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel, mid-range initial ssh slope' 99 93 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 100 !101 do ji = 1,jpi102 pssh(ji,:) = ( -1.5_wp + 5.0_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1)103 end do104 94 ! ! ==================== 105 95 CASE ( 3 ) ! WAD 3 configuration 106 96 ! ! ==================== 107 !108 97 IF(lwp) WRITE(numout,*) 109 98 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel, extreme initial ssh slope' 110 99 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 111 ! 112 do ji = 1,jpi 113 pssh(ji,:) = ( -4.5_wp + 6.8_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 114 end do 100 ! ! ==================== 101 CASE ( 4 ) ! WAD 4 configuration 102 ! ! ==================== 103 IF(lwp) WRITE(numout,*) 104 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic bowl, mid-range initial ssh slope' 105 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 106 ! ! =========================== 107 CASE ( 5, 7 ) ! WAD 5 and 7 configurations 108 ! ! =========================== 109 IF(lwp) WRITE(numout,*) 110 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Double slope with shelf' 111 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 112 ! ! ==================== 113 CASE ( 6 ) ! WAD 6 configuration 114 ! ! ==================== 115 IF(lwp) WRITE(numout,*) 116 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel with gaussian ridge' 117 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 118 ! 119 DO ji = mi0(jpiglo/2), mi0(jpiglo) 120 pts(ji,:,:,jp_sal) = 30._wp 121 END DO 122 ! 123 ! 124 ! ! =========================== 125 CASE DEFAULT ! NONE existing configuration 126 ! ! =========================== 127 WRITE(ctmp1,*) 'WAD test with a ', nn_cfg,' option is not coded' 128 ! 129 CALL ctl_stop( ctmp1 ) 130 ! 131 END SELECT 132 ! 133 END SUBROUTINE usr_def_istate 134 135 136 SUBROUTINE usr_def_istate_ssh( ptmask, pssh ) 137 !!---------------------------------------------------------------------- 138 !! *** ROUTINE usr_def_istate_ssh *** 139 !! 140 !! ** Purpose : Initialization of the dynamics and tracers 141 !! Here WAD_TEST_CASES configuration 142 !! 143 !! ** Method : - set ssh 144 !!---------------------------------------------------------------------- 145 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: ptmask ! t-point ocean mask [m] 146 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height 147 INTEGER :: ji, jj ! dummy loop indices 148 REAL(wp) :: zi, zj 149 ! 150 INTEGER :: jk ! dummy loop indices 151 REAL(wp) :: zdam ! location of dam [Km] 152 !!---------------------------------------------------------------------- 153 ! 154 ! 155 SELECT CASE ( nn_cfg ) 156 ! ! ==================== 157 CASE ( 1 ) ! WAD 1 configuration 158 ! ! ==================== 159 ! 160 IF(lwp) WRITE(numout,*) 161 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Closed box with EW linear bottom slope' 162 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 163 ! 164 DO ji = 1,jpi 165 pssh(ji,:) = ( -5.5_wp + 7.4_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 166 END DO 167 ! ! ==================== 168 CASE ( 2, 8 ) ! WAD 2 configuration 169 ! ! ==================== 170 ! 171 IF(lwp) WRITE(numout,*) 172 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel, mid-range initial ssh slope' 173 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 174 ! 175 DO ji = 1,jpi 176 pssh(ji,:) = ( -1.5_wp + 5.0_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 177 END DO 178 ! ! ==================== 179 CASE ( 3 ) ! WAD 3 configuration 180 ! ! ==================== 181 ! 182 IF(lwp) WRITE(numout,*) 183 IF(lwp) WRITE(numout,*) 'usr_def_istate : WAD Parobolic EW channel, extreme initial ssh slope' 184 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 185 ! 186 DO ji = 1,jpi 187 pssh(ji,:) = ( -4.5_wp + 6.8_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 188 END DO 115 189 116 190 ! … … 140 214 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 141 215 ! 142 doji = 1,jpi143 pssh(ji,:) = ( -2.5_wp + 5.5_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1)144 end do216 DO ji = 1,jpi 217 pssh(ji,:) = ( -2.5_wp + 5.5_wp*glamt(ji,1)/50._wp)*ptmask(ji,:,1) 218 END DO 145 219 146 220 ! … … 153 227 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 154 228 ! 155 do ji = 1,jpi 156 pssh(ji,:) = ( -2.5_wp + 5.5_wp*(50._wp-glamt(ji,1))/50._wp)*ptmask(ji,:,1) 157 end do 158 ! 159 do ji = mi0(jpiglo/2), mi0(jpiglo) 160 pts(ji,:,:,jp_sal) = 30._wp 161 pssh(ji,:) = -0.1*ptmask(ji,:,1) 162 end do 229 DO ji = 1,jpi 230 pssh(ji,:) = ( -2.5_wp + 5.5_wp*(50._wp-glamt(ji,1))/50._wp)*ptmask(ji,:,1) 231 END DO 232 ! 233 DO ji = mi0(jpiglo/2), mi0(jpiglo) 234 pssh(ji,:) = -0.1*ptmask(ji,:,1) 235 END DO 163 236 ! 164 237 ! … … 182 255 END_2D 183 256 ! 184 END SUBROUTINE usr_def_istate 257 END SUBROUTINE usr_def_istate_ssh 185 258 186 259 !!====================================================================== -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/tests/demo_cfgs.txt
r14046 r14058 12 12 STATION_ASF OCE 13 13 CPL_OASIS OCE TOP ICE NST 14 SWG OCE SWE 14 15 C1D_ASICS OCE 15 16 ICE_RHEO OCE SAS ICE
Note: See TracChangeset
for help on using the changeset viewer.