- Timestamp:
- 2020-12-03T13:07:08+01:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes
- Files:
-
- 127 edited
- 7 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes
- Property svn:externals
-
old new 8 8 9 9 # SETTE 10 ^/utils/CI/sette @13559sette10 ^/utils/CI/sette_wave@13990 sette
-
- Property svn:externals
-
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/ice.F90
r13641 r14046 150 150 ! 151 151 ! !!** ice-rheology namelist (namdyn_rhg) ** 152 ! -- evp 153 LOGICAL , PUBLIC :: ln_rhg_EVP ! EVP rheology switch, used for rdgrft and rheology 154 LOGICAL , PUBLIC :: ln_rhg_EAP ! EAP rheology switch, used for rdgrft and rheology 152 155 LOGICAL , PUBLIC :: ln_aEVP !: using adaptive EVP (T or F) 153 REAL(wp), PUBLIC :: rn_creepl !: creep limit : has to be under 1.0e-9156 REAL(wp), PUBLIC :: rn_creepl !: creep limit (has to be low enough, circa 10-9 m/s, depending on rheology) 154 157 REAL(wp), PUBLIC :: rn_ecc !: eccentricity of the elliptical yield curve 155 158 INTEGER , PUBLIC :: nn_nevp !: number of iterations for subcycling 156 159 REAL(wp), PUBLIC :: rn_relast !: ratio => telast/rDt_ice (1/3 or 1/9 depending on nb of subcycling nevp) 157 160 INTEGER , PUBLIC :: nn_rhg_chkcvg !: check ice rheology convergence 161 ! -- vp 162 LOGICAL , PUBLIC :: ln_rhg_VP !: VP rheology 163 INTEGER , PUBLIC :: nn_vp_nout !: Number of outer iterations 164 INTEGER , PUBLIC :: nn_vp_ninn !: Number of inner iterations (linear system solver) 165 INTEGER , PUBLIC :: nn_vp_chkcvg !: Number of iterations every each convergence is checked 158 166 ! 159 167 ! !!** ice-advection namelist (namdyn_adv) ** … … 208 216 ! !!** ice-ponds namelist (namthd_pnd) 209 217 LOGICAL , PUBLIC :: ln_pnd !: Melt ponds (T) or not (F) 210 LOGICAL , PUBLIC :: ln_pnd_LEV !: Melt ponds scheme from Holland et al (2012), Flocco et al (2007, 2010) 211 REAL(wp), PUBLIC :: rn_apnd_min !: Minimum ice fraction that contributes to melt ponds 212 REAL(wp), PUBLIC :: rn_apnd_max !: Maximum ice fraction that contributes to melt ponds 218 LOGICAL , PUBLIC :: ln_pnd_TOPO !: Topographic Melt ponds scheme (Flocco et al 2007, 2010) 219 LOGICAL , PUBLIC :: ln_pnd_LEV !: Simple melt pond scheme 220 REAL(wp), PUBLIC :: rn_apnd_min !: Minimum fraction of melt water contributing to ponds 221 REAL(wp), PUBLIC :: rn_apnd_max !: Maximum fraction of melt water contributing to ponds 222 REAL(wp), PUBLIC :: rn_pnd_flush !: Pond flushing efficiency (tuning parameter) 213 223 LOGICAL , PUBLIC :: ln_pnd_CST !: Melt ponds scheme with constant fraction and depth 214 224 REAL(wp), PUBLIC :: rn_apnd !: prescribed pond fraction (0<rn_apnd<1) … … 246 256 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: divu_i !: Divergence of the velocity field [s-1] 247 257 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: shear_i !: Shear of the velocity field [s-1] 258 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: aniso_11, aniso_12 !: structure tensor elements 259 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rdg_conv 248 260 ! 249 261 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_bo !: Sea-Ice bottom temperature [Kelvin] … … 341 353 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: om_i !: mean ice age over all categories (s) 342 354 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tau_icebfr !: ice friction on ocean bottom (landfast param activated) 355 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: icb_mask !: mask of grounded icebergs if landfast [0-1] 343 356 344 357 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_s !: Snow temperatures [K] … … 362 375 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_il !: total melt pond lid volume per gridcell area [m] 363 376 377 ! meltwater arrays to save for melt ponds (mv - could be grouped in a single meltwater volume array) 378 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dh_i_sum_2d !: surface melt (2d arrays for ponds) [m] 379 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dh_s_mlt_2d !: snow surf melt (2d arrays for ponds) [m] 380 364 381 !!---------------------------------------------------------------------- 365 382 !! * Global variables at before time step 366 383 !!---------------------------------------------------------------------- 367 384 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s_b, v_i_b, h_s_b, h_i_b !: snow and ice volumes/thickness 385 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_ip_b, v_il_b !: ponds and lids volumes 368 386 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i_b, sv_i_b !: 369 387 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s_b !: snow heat content … … 392 410 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vsnw !: snw volume variation [m/s] 393 411 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_aice !: ice conc. variation [s-1] 412 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vpnd !: pond volume variation [m/s] 394 413 ! 395 414 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_adv_mass !: advection of mass (kg/m2/s) … … 436 455 ALLOCATE( u_oce (jpi,jpj) , v_oce (jpi,jpj) , ht_i_new (jpi,jpj) , strength(jpi,jpj) , & 437 456 & stress1_i(jpi,jpj) , stress2_i(jpi,jpj) , stress12_i(jpi,jpj) , & 438 & delta_i (jpi,jpj) , divu_i (jpi,jpj) , shear_i (jpi,jpj) , STAT=ierr(ii) ) 457 & delta_i (jpi,jpj) , divu_i (jpi,jpj) , shear_i (jpi,jpj) , & 458 & aniso_11 (jpi,jpj) , aniso_12 (jpi,jpj) , rdg_conv (jpi,jpj) , STAT=ierr(ii) ) 439 459 440 460 ii = ii + 1 … … 468 488 & et_i (jpi,jpj) , et_s (jpi,jpj) , tm_i(jpi,jpj) , tm_s(jpi,jpj) , & 469 489 & sm_i (jpi,jpj) , tm_su(jpi,jpj) , hm_i(jpi,jpj) , hm_s(jpi,jpj) , & 470 & om_i (jpi,jpj) , bvm_i(jpi,jpj) , tau_icebfr(jpi,jpj) 490 & om_i (jpi,jpj) , bvm_i(jpi,jpj) , tau_icebfr(jpi,jpj), icb_mask(jpi,jpj), STAT=ierr(ii) ) 471 491 472 492 ii = ii + 1 … … 478 498 ii = ii + 1 479 499 ALLOCATE( a_ip(jpi,jpj,jpl) , v_ip(jpi,jpj,jpl) , a_ip_frac(jpi,jpj,jpl) , h_ip(jpi,jpj,jpl), & 480 & v_il(jpi,jpj,jpl) , h_il(jpi,jpj,jpl) , a_ip_eff (jpi,jpj,jpl) , STAT = ierr(ii) ) 500 & v_il(jpi,jpj,jpl) , h_il(jpi,jpj,jpl) , a_ip_eff (jpi,jpj,jpl) , & 501 & dh_i_sum_2d(jpi,jpj,jpl) , dh_s_mlt_2d(jpi,jpj,jpl) , STAT = ierr(ii) ) 481 502 482 503 ii = ii + 1 … … 486 507 ii = ii + 1 487 508 ALLOCATE( v_s_b (jpi,jpj,jpl) , v_i_b (jpi,jpj,jpl) , h_s_b(jpi,jpj,jpl) , h_i_b(jpi,jpj,jpl), & 509 & v_ip_b(jpi,jpj,jpl) , v_il_b(jpi,jpj,jpl) , & 488 510 & a_i_b (jpi,jpj,jpl) , sv_i_b(jpi,jpj,jpl) , e_i_b(jpi,jpj,nlay_i,jpl) , e_s_b(jpi,jpj,nlay_s,jpl) , & 489 511 & STAT=ierr(ii) ) … … 500 522 ALLOCATE( diag_trp_vi(jpi,jpj) , diag_trp_vs (jpi,jpj) , diag_trp_ei(jpi,jpj), & 501 523 & diag_trp_es(jpi,jpj) , diag_trp_sv (jpi,jpj) , diag_heat (jpi,jpj), & 502 & diag_sice (jpi,jpj) , diag_vice (jpi,jpj) , diag_vsnw (jpi,jpj), diag_aice(jpi,jpj), &524 & diag_sice (jpi,jpj) , diag_vice (jpi,jpj) , diag_vsnw (jpi,jpj), diag_aice(jpi,jpj), diag_vpnd(jpi,jpj), & 503 525 & diag_adv_mass(jpi,jpj), diag_adv_salt(jpi,jpj), diag_adv_heat(jpi,jpj), STAT=ierr(ii) ) 504 526 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icectl.F90
r13601 r14046 85 85 !! 86 86 REAL(wp) :: zdiag_mass, zdiag_salt, zdiag_heat, & 87 & zdiag_vmin, zdiag_amin, zdiag_amax, zdiag_eimin, zdiag_esmin, zdiag_smin 87 & zdiag_vimin, zdiag_vsmin, zdiag_vpmin, zdiag_vlmin, zdiag_aimin, zdiag_aimax, & 88 & zdiag_eimin, zdiag_esmin, zdiag_simin 88 89 REAL(wp) :: zvtrp, zetrp 89 90 REAL(wp) :: zarea … … 92 93 IF( icount == 0 ) THEN 93 94 94 pdiag_v = glob_sum( 'icectl', SUM( v_i * rhoi + v_s * rhos , dim=3 ) * e1e2t )95 pdiag_v = glob_sum( 'icectl', SUM( v_i * rhoi + v_s * rhos + ( v_ip + v_il ) * rhow, dim=3 ) * e1e2t ) 95 96 pdiag_s = glob_sum( 'icectl', SUM( sv_i * rhoi , dim=3 ) * e1e2t ) 96 97 pdiag_t = glob_sum( 'icectl', ( SUM( SUM( e_i, dim=4 ), dim=3 ) + SUM( SUM( e_s, dim=4 ), dim=3 ) ) * e1e2t ) … … 112 113 113 114 ! -- mass diag -- ! 114 zdiag_mass = ( glob_sum( 'icectl', SUM( v_i * rhoi + v_s * rhos, dim=3 ) * e1e2t ) - pdiag_v ) * r1_Dt_ice & 115 zdiag_mass = ( glob_sum( 'icectl', SUM( v_i * rhoi + v_s * rhos + ( v_ip + v_il ) * rhow, dim=3 ) * e1e2t ) & 116 & - pdiag_v ) * r1_Dt_ice & 115 117 & + glob_sum( 'icectl', ( wfx_bog + wfx_bom + wfx_sum + wfx_sni + wfx_opw + wfx_res + wfx_dyn + & 116 118 & wfx_lam + wfx_pnd + wfx_snw_sni + wfx_snw_sum + wfx_snw_dyn + wfx_snw_sub + & … … 132 134 133 135 ! -- min/max diag -- ! 134 zdiag_amax = glob_max( 'icectl', SUM( a_i, dim=3 ) ) 135 zdiag_vmin = glob_min( 'icectl', v_i ) 136 zdiag_amin = glob_min( 'icectl', a_i ) 137 zdiag_smin = glob_min( 'icectl', sv_i ) 136 zdiag_aimax = glob_max( 'icectl', SUM( a_i, dim=3 ) ) 137 zdiag_vimin = glob_min( 'icectl', v_i ) 138 zdiag_vsmin = glob_min( 'icectl', v_s ) 139 zdiag_vpmin = glob_min( 'icectl', v_ip ) 140 zdiag_vlmin = glob_min( 'icectl', v_il ) 141 zdiag_aimin = glob_min( 'icectl', a_i ) 142 zdiag_simin = glob_min( 'icectl', sv_i ) 138 143 zdiag_eimin = glob_min( 'icectl', SUM( e_i, dim=3 ) ) 139 144 zdiag_esmin = glob_min( 'icectl', SUM( e_s, dim=3 ) ) … … 155 160 & WRITE(numout,*) cd_routine,' : violation heat cons. [J] = ',zdiag_heat * rDt_ice 156 161 ! check negative values 157 IF( zdiag_vmin < 0. ) WRITE(numout,*) cd_routine,' : violation v_i < 0 = ',zdiag_vmin 158 IF( zdiag_amin < 0. ) WRITE(numout,*) cd_routine,' : violation a_i < 0 = ',zdiag_amin 159 IF( zdiag_smin < 0. ) WRITE(numout,*) cd_routine,' : violation s_i < 0 = ',zdiag_smin 160 IF( zdiag_eimin < 0. ) WRITE(numout,*) cd_routine,' : violation e_i < 0 = ',zdiag_eimin 161 IF( zdiag_esmin < 0. ) WRITE(numout,*) cd_routine,' : violation e_s < 0 = ',zdiag_esmin 162 IF( zdiag_vimin < 0. ) WRITE(numout,*) cd_routine,' : violation v_i < 0 = ',zdiag_vimin 163 IF( zdiag_vsmin < 0. ) WRITE(numout,*) cd_routine,' : violation v_s < 0 = ',zdiag_vsmin 164 IF( zdiag_vpmin < 0. ) WRITE(numout,*) cd_routine,' : violation v_ip < 0 = ',zdiag_vpmin 165 IF( zdiag_vlmin < 0. ) WRITE(numout,*) cd_routine,' : violation v_il < 0 = ',zdiag_vlmin 166 IF( zdiag_aimin < 0. ) WRITE(numout,*) cd_routine,' : violation a_i < 0 = ',zdiag_aimin 167 IF( zdiag_simin < 0. ) WRITE(numout,*) cd_routine,' : violation s_i < 0 = ',zdiag_simin 168 IF( zdiag_eimin < 0. ) WRITE(numout,*) cd_routine,' : violation e_i < 0 = ',zdiag_eimin 169 IF( zdiag_esmin < 0. ) WRITE(numout,*) cd_routine,' : violation e_s < 0 = ',zdiag_esmin 162 170 ! check maximum ice concentration 163 IF( zdiag_a max >MAX(rn_amax_n,rn_amax_s)+epsi10 .AND. cd_routine /= 'icedyn_adv' .AND. cd_routine /= 'icedyn_rdgrft' ) &164 & WRITE(numout,*) cd_routine,' : violation a_i > amax = ',zdiag_a max171 IF( zdiag_aimax>MAX(rn_amax_n,rn_amax_s)+epsi10 .AND. cd_routine /= 'icedyn_adv' .AND. cd_routine /= 'icedyn_rdgrft' ) & 172 & WRITE(numout,*) cd_routine,' : violation a_i > amax = ',zdiag_aimax 165 173 ! check if advection scheme is conservative 166 174 IF( ABS(zvtrp) > zchk_m * rn_icechk_glo * zarea .AND. cd_routine == 'icedyn_adv' ) & 167 & WRITE(numout,*) cd_routine,' : violation adv scheme [kg] = ',zvtrp * r dt_ice175 & WRITE(numout,*) cd_routine,' : violation adv scheme [kg] = ',zvtrp * rDt_ice 168 176 IF( ABS(zetrp) > zchk_t * rn_icechk_glo * zarea .AND. cd_routine == 'icedyn_adv' ) & 169 & WRITE(numout,*) cd_routine,' : violation adv scheme [J] = ',zetrp * r dt_ice177 & WRITE(numout,*) cd_routine,' : violation adv scheme [J] = ',zetrp * rDt_ice 170 178 ENDIF 171 179 ! … … 193 201 ! water flux 194 202 ! -- mass diag -- ! 195 zdiag_mass = glob_sum( 'icectl', ( wfx_ice + wfx_snw + wfx_spr + wfx_sub&196 & + diag_vice + diag_vsnw - diag_adv_mass ) * e1e2t )203 zdiag_mass = glob_sum( 'icectl', ( wfx_ice + wfx_snw + wfx_spr + wfx_sub + wfx_pnd & 204 & + diag_vice + diag_vsnw + diag_vpnd - diag_adv_mass ) * e1e2t ) 197 205 198 206 ! -- salt diag -- ! … … 200 208 201 209 ! -- heat diag -- ! 202 zdiag_heat 210 zdiag_heat = glob_sum( 'icectl', ( qt_oce_ai - qt_atm_oi + diag_heat - diag_adv_heat ) * e1e2t ) 203 211 ! equivalent to this: 204 212 !!zdiag_heat = glob_sum( 'icectl', ( -diag_heat + hfx_sum + hfx_bom + hfx_bog + hfx_dif + hfx_opw + hfx_snw & … … 245 253 IF( icount == 0 ) THEN 246 254 247 pdiag_v = SUM( v_i * rhoi + v_s * rhos , dim=3 )248 pdiag_s = SUM( sv_i * rhoi 255 pdiag_v = SUM( v_i * rhoi + v_s * rhos + ( v_ip + v_il ) * rhow, dim=3 ) 256 pdiag_s = SUM( sv_i * rhoi , dim=3 ) 249 257 pdiag_t = SUM( SUM( e_i, dim=4 ), dim=3 ) + SUM( SUM( e_s, dim=4 ), dim=3 ) 250 258 … … 261 269 262 270 ! -- mass diag -- ! 263 zdiag_mass = ( SUM( v_i * rhoi + v_s * rhos , dim=3 ) - pdiag_v ) * r1_Dt_ice&271 zdiag_mass = ( SUM( v_i * rhoi + v_s * rhos + ( v_ip + v_il ) * rhow, dim=3 ) - pdiag_v ) * r1_Dt_ice & 264 272 & + ( wfx_bog + wfx_bom + wfx_sum + wfx_sni + wfx_opw + wfx_res + wfx_dyn + wfx_lam + wfx_pnd + & 265 273 & wfx_snw_sni + wfx_snw_sum + wfx_snw_dyn + wfx_snw_sub + wfx_ice_sub + wfx_spr ) & … … 352 360 CALL iom_rstput( 0, 0, inum, 'sneg_count', pdiag_smin(:,:) , ktype = jp_r8 ) ! 353 361 CALL iom_rstput( 0, 0, inum, 'eneg_count', pdiag_emin(:,:) , ktype = jp_r8 ) ! 362 ! mean state 363 CALL iom_rstput( 0, 0, inum, 'icecon' , SUM(a_i ,dim=3) , ktype = jp_r8 ) ! 364 CALL iom_rstput( 0, 0, inum, 'icevol' , SUM(v_i ,dim=3) , ktype = jp_r8 ) ! 365 CALL iom_rstput( 0, 0, inum, 'snwvol' , SUM(v_s ,dim=3) , ktype = jp_r8 ) ! 366 CALL iom_rstput( 0, 0, inum, 'pndvol' , SUM(v_ip,dim=3) , ktype = jp_r8 ) ! 367 CALL iom_rstput( 0, 0, inum, 'lidvol' , SUM(v_il,dim=3) , ktype = jp_r8 ) ! 354 368 355 369 CALL iom_close( inum ) … … 776 790 ! -- mass diag -- ! 777 791 zdiag_mass = glob_sum( 'icectl', ( wfx_ice + wfx_snw + wfx_spr + wfx_sub & 778 & + diag_vice + diag_vsnw - diag_adv_mass ) * e1e2t ) * r dt_ice792 & + diag_vice + diag_vsnw - diag_adv_mass ) * e1e2t ) * rDt_ice 779 793 zdiag_adv_mass = glob_sum( 'icectl', diag_adv_mass * e1e2t ) * rDt_ice 780 794 781 795 ! -- salt diag -- ! 782 zdiag_salt = glob_sum( 'icectl', ( sfx + diag_sice - diag_adv_salt ) * e1e2t ) * r dt_ice * 1.e-3796 zdiag_salt = glob_sum( 'icectl', ( sfx + diag_sice - diag_adv_salt ) * e1e2t ) * rDt_ice * 1.e-3 783 797 zdiag_adv_salt = glob_sum( 'icectl', diag_adv_salt * e1e2t ) * rDt_ice * 1.e-3 784 798 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icedia.F90
r13286 r14046 261 261 ! Write in numriw (if iter == nitrst) 262 262 ! ------------------ 263 CALL iom_rstput( iter, nitrst, numriw, 'frc_voltop' , frc_voltop 264 CALL iom_rstput( iter, nitrst, numriw, 'frc_volbot' , frc_volbot 265 CALL iom_rstput( iter, nitrst, numriw, 'frc_temtop' , frc_temtop 266 CALL iom_rstput( iter, nitrst, numriw, 'frc_tembot' , frc_tembot 267 CALL iom_rstput( iter, nitrst, numriw, 'frc_sal' , frc_sal 263 CALL iom_rstput( iter, nitrst, numriw, 'frc_voltop' , frc_voltop ) 264 CALL iom_rstput( iter, nitrst, numriw, 'frc_volbot' , frc_volbot ) 265 CALL iom_rstput( iter, nitrst, numriw, 'frc_temtop' , frc_temtop ) 266 CALL iom_rstput( iter, nitrst, numriw, 'frc_tembot' , frc_tembot ) 267 CALL iom_rstput( iter, nitrst, numriw, 'frc_sal' , frc_sal ) 268 268 CALL iom_rstput( iter, nitrst, numriw, 'vol_loc_ini', vol_loc_ini ) 269 269 CALL iom_rstput( iter, nitrst, numriw, 'tem_loc_ini', tem_loc_ini ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icedyn.F90
r13472 r14046 29 29 USE lbclnk ! lateral boundary conditions (or mpp links) 30 30 USE timing ! Timing 31 USE fldread ! read input fields 31 32 32 33 IMPLICIT NONE … … 51 52 REAL(wp) :: rn_vice ! prescribed v-vel (case np_dynADV1D & np_dynADV2D) 52 53 54 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_icbmsk ! structure of input grounded icebergs mask (file informations, fields read) 55 53 56 !! * Substitutions 54 57 # include "do_loop_substitute.h90" … … 81 84 ! 82 85 ! controls 83 IF( ln_timing ) CALL timing_start('ice dyn')86 IF( ln_timing ) CALL timing_start('ice_dyn') 84 87 ! 85 88 IF( kt == nit000 .AND. lwp ) THEN … … 106 109 END WHERE 107 110 ! 111 IF( ln_landfast_L16 ) THEN 112 CALL fld_read( kt, 1, sf_icbmsk ) 113 icb_mask(:,:) = sf_icbmsk(1)%fnow(:,:,1) 114 ENDIF 108 115 ! 109 116 SELECT CASE( nice_dyn ) !-- Set which dynamics is running … … 172 179 ! 173 180 ! controls 174 IF( ln_timing ) CALL timing_stop ('ice dyn')181 IF( ln_timing ) CALL timing_stop ('ice_dyn') 175 182 ! 176 183 END SUBROUTINE ice_dyn … … 216 223 !! ** input : Namelist namdyn 217 224 !!------------------------------------------------------------------- 218 INTEGER :: ios, ioptio ! Local integer output status for namelist read 225 INTEGER :: ios, ioptio, ierror ! Local integer output status for namelist read 226 ! 227 CHARACTER(len=256) :: cn_dir ! Root directory for location of ice files 228 TYPE(FLD_N) :: sn_icbmsk ! informations about the grounded icebergs field to be read 219 229 !! 220 230 NAMELIST/namdyn/ ln_dynALL, ln_dynRHGADV, ln_dynADV1D, ln_dynADV2D, rn_uice, rn_vice, & 221 231 & rn_ishlat , & 222 & ln_landfast_L16, rn_lf_depfra, rn_lf_bfr, rn_lf_relax, rn_lf_tensile 232 & ln_landfast_L16, rn_lf_depfra, rn_lf_bfr, rn_lf_relax, rn_lf_tensile, & 233 & sn_icbmsk, cn_dir 223 234 !!------------------------------------------------------------------- 224 235 ! … … 269 280 IF( .NOT.ln_landfast_L16 ) tau_icebfr(:,:) = 0._wp 270 281 ! 282 ! !--- allocate and fill structure for grounded icebergs mask 283 IF( ln_landfast_L16 ) THEN 284 ALLOCATE( sf_icbmsk(1), STAT=ierror ) 285 IF( ierror > 0 ) THEN 286 CALL ctl_stop( 'ice_dyn_init: unable to allocate sf_icbmsk structure' ) ; RETURN 287 ENDIF 288 ! 289 CALL fld_fill( sf_icbmsk, (/ sn_icbmsk /), cn_dir, 'ice_dyn_init', & 290 & 'landfast ice is a function of read grounded icebergs', 'icedyn' ) 291 ! 292 ALLOCATE( sf_icbmsk(1)%fnow(jpi,jpj,1) ) 293 IF( sf_icbmsk(1)%ln_tint ) ALLOCATE( sf_icbmsk(1)%fdta(jpi,jpj,1,2) ) 294 IF( TRIM(sf_icbmsk(1)%clrootname) == 'NOT USED' ) sf_icbmsk(1)%fnow(:,:,1) = 0._wp ! not used field (set to 0) 295 ELSE 296 icb_mask(:,:) = 0._wp 297 ENDIF 298 ! !--- other init 271 299 CALL ice_dyn_rdgrft_init ! set ice ridging/rafting parameters 272 300 CALL ice_dyn_rhg_init ! set ice rheology parameters -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icedyn_adv_pra.F90
r13637 r14046 156 156 157 157 ! diagnostics 158 zdiag_adv_mass(:,:) = SUM( pv_i(:,:,:) , dim=3 ) * rhoi + SUM( pv_s(:,:,:) , dim=3 ) * rhos 158 zdiag_adv_mass(:,:) = SUM( pv_i (:,:,:) , dim=3 ) * rhoi + SUM( pv_s (:,:,:) , dim=3 ) * rhos & 159 & + SUM( pv_ip(:,:,:) , dim=3 ) * rhow + SUM( pv_il(:,:,:) , dim=3 ) * rhow 159 160 zdiag_adv_salt(:,:) = SUM( psv_i(:,:,:) , dim=3 ) * rhoi 160 161 zdiag_adv_heat(:,:) = - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) & … … 178 179 z0ei(:,:,jk,jl) = pe_i(:,:,jk,jl) * e1e2t(:,:) ! Ice heat content 179 180 END DO 180 IF ( ln_pnd_LEV ) THEN181 IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN 181 182 z0ap(:,:,jl) = pa_ip(:,:,jl) * e1e2t(:,:) ! Melt pond fraction 182 183 z0vp(:,:,jl) = pv_ip(:,:,jl) * e1e2t(:,:) ! Melt pond volume … … 214 215 END DO 215 216 ! 216 IF ( ln_pnd_LEV ) THEN217 IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN 217 218 CALL adv_x( zdt , zudy , 1._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) !--- melt pond fraction 218 219 CALL adv_y( zdt , zvdx , 0._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) … … 249 250 & sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) ) 250 251 END DO 251 IF ( ln_pnd_LEV ) THEN252 IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN 252 253 CALL adv_y( zdt , zvdx , 1._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) !--- melt pond fraction 253 254 CALL adv_x( zdt , zudy , 0._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) … … 278 279 CALL lbc_lnk_multi( 'icedyn_adv_pra', z0ei , 'T', 1._wp, sxe , 'T', -1._wp, sye , 'T', -1._wp & ! ice enthalpy 279 280 & , sxxe , 'T', 1._wp, syye , 'T', 1._wp, sxye , 'T', 1._wp ) 280 IF ( ln_pnd_LEV ) THEN281 IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN 281 282 CALL lbc_lnk_multi( 'icedyn_adv_pra', z0ap , 'T', 1._wp, sxap , 'T', -1._wp, syap , 'T', -1._wp & ! melt pond fraction 282 283 & , sxxap, 'T', 1._wp, syyap, 'T', 1._wp, sxyap, 'T', 1._wp & … … 302 303 pe_i(:,:,jk,jl) = z0ei(:,:,jk,jl) * r1_e1e2t(:,:) * tmask(:,:,1) 303 304 END DO 304 IF ( ln_pnd_LEV ) THEN305 IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN 305 306 pa_ip(:,:,jl) = z0ap(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1) 306 307 pv_ip(:,:,jl) = z0vp(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1) … … 320 321 ! 321 322 ! --- diagnostics --- ! 322 diag_adv_mass(:,:) = diag_adv_mass(:,:) + ( SUM( pv_i(:,:,:) , dim=3 ) * rhoi + SUM( pv_s(:,:,:) , dim=3 ) * rhos & 323 diag_adv_mass(:,:) = diag_adv_mass(:,:) + ( SUM( pv_i (:,:,:) , dim=3 ) * rhoi + SUM( pv_s (:,:,:) , dim=3 ) * rhos & 324 & + SUM( pv_ip(:,:,:) , dim=3 ) * rhow + SUM( pv_il(:,:,:) , dim=3 ) * rhow & 323 325 & - zdiag_adv_mass(:,:) ) * z1_dt 324 326 diag_adv_salt(:,:) = diag_adv_salt(:,:) + ( SUM( psv_i(:,:,:) , dim=3 ) * rhoi & … … 769 771 ! ! -- check h_ip -- ! 770 772 ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 771 IF( ln_pnd_LEV . AND. pv_ip(ji,jj,jl) > 0._wp ) THEN773 IF( ln_pnd_LEV .OR. ln_pnd_TOPO .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 772 774 zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 773 775 IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN … … 989 991 DO jk = 1, nlay_s 990 992 WRITE(zchar1,'(I2.2)') jk 991 znam = 'sxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sxc0 (:,:,jk,:) = z3d(:,:,:) 992 znam = 'syc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; syc0 (:,:,jk,:) = z3d(:,:,:) 993 znam = 'sxxc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxxc0(:,:,jk,:) = z3d(:,:,:) 994 znam = 'syyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syyc0(:,:,jk,:) = z3d(:,:,:) 995 znam = 'sxyc0'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxyc0(:,:,jk,:) = z3d(:,:,:) 993 znam = 'sxc0'//'_l'//zchar1 994 CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sxc0 (:,:,jk,:) = z3d(:,:,:) 995 znam = 'syc0'//'_l'//zchar1 996 CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; syc0 (:,:,jk,:) = z3d(:,:,:) 997 znam = 'sxxc0'//'_l'//zchar1 998 CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxxc0(:,:,jk,:) = z3d(:,:,:) 999 znam = 'syyc0'//'_l'//zchar1 1000 CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syyc0(:,:,jk,:) = z3d(:,:,:) 1001 znam = 'sxyc0'//'_l'//zchar1 1002 CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxyc0(:,:,jk,:) = z3d(:,:,:) 996 1003 END DO 997 1004 ! ! ice layers heat content 998 1005 DO jk = 1, nlay_i 999 1006 WRITE(zchar1,'(I2.2)') jk 1000 znam = 'sxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sxe (:,:,jk,:) = z3d(:,:,:) 1001 znam = 'sye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sye (:,:,jk,:) = z3d(:,:,:) 1002 znam = 'sxxe'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxxe(:,:,jk,:) = z3d(:,:,:) 1003 znam = 'syye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syye(:,:,jk,:) = z3d(:,:,:) 1004 znam = 'sxye'//'_l'//zchar1 ; CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxye(:,:,jk,:) = z3d(:,:,:) 1005 END DO 1006 ! 1007 IF( ln_pnd_LEV ) THEN ! melt pond fraction 1007 znam = 'sxe'//'_l'//zchar1 1008 CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sxe (:,:,jk,:) = z3d(:,:,:) 1009 znam = 'sye'//'_l'//zchar1 1010 CALL iom_get( numrir, jpdom_auto, znam , z3d, psgn = -1._wp ) ; sye (:,:,jk,:) = z3d(:,:,:) 1011 znam = 'sxxe'//'_l'//zchar1 1012 CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxxe(:,:,jk,:) = z3d(:,:,:) 1013 znam = 'syye'//'_l'//zchar1 1014 CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; syye(:,:,jk,:) = z3d(:,:,:) 1015 znam = 'sxye'//'_l'//zchar1 1016 CALL iom_get( numrir, jpdom_auto, znam , z3d ) ; sxye(:,:,jk,:) = z3d(:,:,:) 1017 END DO 1018 ! 1019 IF( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN ! melt pond fraction 1008 1020 IF( iom_varid( numrir, 'sxap', ldstop = .FALSE. ) > 0 ) THEN 1009 1021 CALL iom_get( numrir, jpdom_auto, 'sxap' , sxap , psgn = -1._wp ) … … 1047 1059 sxc0 = 0._wp ; syc0 = 0._wp ; sxxc0 = 0._wp ; syyc0 = 0._wp ; sxyc0 = 0._wp ! snow layers heat content 1048 1060 sxe = 0._wp ; sye = 0._wp ; sxxe = 0._wp ; syye = 0._wp ; sxye = 0._wp ! ice layers heat content 1049 IF( ln_pnd_LEV ) THEN1061 IF( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN 1050 1062 sxap = 0._wp ; syap = 0._wp ; sxxap = 0._wp ; syyap = 0._wp ; sxyap = 0._wp ! melt pond fraction 1051 1063 sxvp = 0._wp ; syvp = 0._wp ; sxxvp = 0._wp ; syyvp = 0._wp ; sxyvp = 0._wp ! melt pond volume … … 1067 1079 ! 1068 1080 ! ! ice thickness 1069 CALL iom_rstput( iter, nitrst, numriw, 'sxice' , sxice 1070 CALL iom_rstput( iter, nitrst, numriw, 'syice' , syice 1071 CALL iom_rstput( iter, nitrst, numriw, 'sxxice', sxxice 1072 CALL iom_rstput( iter, nitrst, numriw, 'syyice', syyice 1073 CALL iom_rstput( iter, nitrst, numriw, 'sxyice', sxyice 1081 CALL iom_rstput( iter, nitrst, numriw, 'sxice' , sxice) 1082 CALL iom_rstput( iter, nitrst, numriw, 'syice' , syice) 1083 CALL iom_rstput( iter, nitrst, numriw, 'sxxice', sxxice) 1084 CALL iom_rstput( iter, nitrst, numriw, 'syyice', syyice) 1085 CALL iom_rstput( iter, nitrst, numriw, 'sxyice', sxyice) 1074 1086 ! ! snow thickness 1075 CALL iom_rstput( iter, nitrst, numriw, 'sxsn' , sxsn 1076 CALL iom_rstput( iter, nitrst, numriw, 'sysn' , sysn 1077 CALL iom_rstput( iter, nitrst, numriw, 'sxxsn' , sxxsn 1078 CALL iom_rstput( iter, nitrst, numriw, 'syysn' , syysn 1079 CALL iom_rstput( iter, nitrst, numriw, 'sxysn' , sxysn 1087 CALL iom_rstput( iter, nitrst, numriw, 'sxsn' , sxsn ) 1088 CALL iom_rstput( iter, nitrst, numriw, 'sysn' , sysn ) 1089 CALL iom_rstput( iter, nitrst, numriw, 'sxxsn' , sxxsn ) 1090 CALL iom_rstput( iter, nitrst, numriw, 'syysn' , syysn ) 1091 CALL iom_rstput( iter, nitrst, numriw, 'sxysn' , sxysn ) 1080 1092 ! ! ice concentration 1081 CALL iom_rstput( iter, nitrst, numriw, 'sxa' , sxa 1082 CALL iom_rstput( iter, nitrst, numriw, 'sya' , sya 1083 CALL iom_rstput( iter, nitrst, numriw, 'sxxa' , sxxa 1084 CALL iom_rstput( iter, nitrst, numriw, 'syya' , syya 1085 CALL iom_rstput( iter, nitrst, numriw, 'sxya' , sxya 1093 CALL iom_rstput( iter, nitrst, numriw, 'sxa' , sxa ) 1094 CALL iom_rstput( iter, nitrst, numriw, 'sya' , sya ) 1095 CALL iom_rstput( iter, nitrst, numriw, 'sxxa' , sxxa ) 1096 CALL iom_rstput( iter, nitrst, numriw, 'syya' , syya ) 1097 CALL iom_rstput( iter, nitrst, numriw, 'sxya' , sxya ) 1086 1098 ! ! ice salinity 1087 CALL iom_rstput( iter, nitrst, numriw, 'sxsal' , sxsal 1088 CALL iom_rstput( iter, nitrst, numriw, 'sysal' , sysal 1089 CALL iom_rstput( iter, nitrst, numriw, 'sxxsal', sxxsal 1090 CALL iom_rstput( iter, nitrst, numriw, 'syysal', syysal 1091 CALL iom_rstput( iter, nitrst, numriw, 'sxysal', sxysal 1099 CALL iom_rstput( iter, nitrst, numriw, 'sxsal' , sxsal) 1100 CALL iom_rstput( iter, nitrst, numriw, 'sysal' , sysal) 1101 CALL iom_rstput( iter, nitrst, numriw, 'sxxsal', sxxsal) 1102 CALL iom_rstput( iter, nitrst, numriw, 'syysal', syysal) 1103 CALL iom_rstput( iter, nitrst, numriw, 'sxysal', sxysal) 1092 1104 ! ! ice age 1093 CALL iom_rstput( iter, nitrst, numriw, 'sxage' , sxage 1094 CALL iom_rstput( iter, nitrst, numriw, 'syage' , syage 1095 CALL iom_rstput( iter, nitrst, numriw, 'sxxage', sxxage 1096 CALL iom_rstput( iter, nitrst, numriw, 'syyage', syyage 1097 CALL iom_rstput( iter, nitrst, numriw, 'sxyage', sxyage 1105 CALL iom_rstput( iter, nitrst, numriw, 'sxage' , sxage) 1106 CALL iom_rstput( iter, nitrst, numriw, 'syage' , syage) 1107 CALL iom_rstput( iter, nitrst, numriw, 'sxxage', sxxage) 1108 CALL iom_rstput( iter, nitrst, numriw, 'syyage', syyage) 1109 CALL iom_rstput( iter, nitrst, numriw, 'sxyage', sxyage) 1098 1110 ! ! snow layers heat content 1099 1111 DO jk = 1, nlay_s 1100 1112 WRITE(zchar1,'(I2.2)') jk 1101 znam = 'sxc0'//'_l'//zchar1 ; z3d(:,:,:) = sxc0 (:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1102 znam = 'syc0'//'_l'//zchar1 ; z3d(:,:,:) = syc0 (:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1103 znam = 'sxxc0'//'_l'//zchar1 ; z3d(:,:,:) = sxxc0(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1104 znam = 'syyc0'//'_l'//zchar1 ; z3d(:,:,:) = syyc0(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1105 znam = 'sxyc0'//'_l'//zchar1 ; z3d(:,:,:) = sxyc0(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1113 znam = 'sxc0'//'_l'//zchar1 ; z3d(:,:,:) = sxc0 (:,:,jk,:) 1114 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1115 znam = 'syc0'//'_l'//zchar1 ; z3d(:,:,:) = syc0 (:,:,jk,:) 1116 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1117 znam = 'sxxc0'//'_l'//zchar1 ; z3d(:,:,:) = sxxc0(:,:,jk,:) 1118 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1119 znam = 'syyc0'//'_l'//zchar1 ; z3d(:,:,:) = syyc0(:,:,jk,:) 1120 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1121 znam = 'sxyc0'//'_l'//zchar1 ; z3d(:,:,:) = sxyc0(:,:,jk,:) 1122 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1106 1123 END DO 1107 1124 ! ! ice layers heat content 1108 1125 DO jk = 1, nlay_i 1109 1126 WRITE(zchar1,'(I2.2)') jk 1110 znam = 'sxe'//'_l'//zchar1 ; z3d(:,:,:) = sxe (:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1111 znam = 'sye'//'_l'//zchar1 ; z3d(:,:,:) = sye (:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1112 znam = 'sxxe'//'_l'//zchar1 ; z3d(:,:,:) = sxxe(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1113 znam = 'syye'//'_l'//zchar1 ; z3d(:,:,:) = syye(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1114 znam = 'sxye'//'_l'//zchar1 ; z3d(:,:,:) = sxye(:,:,jk,:) ; CALL iom_rstput( iter, nitrst, numriw, znam , z3d ) 1127 znam = 'sxe'//'_l'//zchar1 ; z3d(:,:,:) = sxe (:,:,jk,:) 1128 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1129 znam = 'sye'//'_l'//zchar1 ; z3d(:,:,:) = sye (:,:,jk,:) 1130 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1131 znam = 'sxxe'//'_l'//zchar1 ; z3d(:,:,:) = sxxe(:,:,jk,:) 1132 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1133 znam = 'syye'//'_l'//zchar1 ; z3d(:,:,:) = syye(:,:,jk,:) 1134 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1135 znam = 'sxye'//'_l'//zchar1 ; z3d(:,:,:) = sxye(:,:,jk,:) 1136 CALL iom_rstput( iter, nitrst, numriw, znam , z3d) 1115 1137 END DO 1116 1138 ! 1117 IF( ln_pnd_LEV ) THEN ! melt pond fraction1139 IF( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN ! melt pond fraction 1118 1140 CALL iom_rstput( iter, nitrst, numriw, 'sxap' , sxap ) 1119 1141 CALL iom_rstput( iter, nitrst, numriw, 'syap' , syap ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icedyn_adv_umx.F90
r13633 r14046 182 182 183 183 ! diagnostics 184 zdiag_adv_mass(:,:) = SUM( pv_i(:,:,:) , dim=3 ) * rhoi + SUM( pv_s(:,:,:) , dim=3 ) * rhos 184 zdiag_adv_mass(:,:) = SUM( pv_i (:,:,:) , dim=3 ) * rhoi + SUM( pv_s (:,:,:) , dim=3 ) * rhos & 185 & + SUM( pv_ip(:,:,:) , dim=3 ) * rhow + SUM( pv_il(:,:,:) , dim=3 ) * rhow 185 186 zdiag_adv_salt(:,:) = SUM( psv_i(:,:,:) , dim=3 ) * rhoi 186 187 zdiag_adv_heat(:,:) = - SUM(SUM( pe_i(:,:,1:nlay_i,:) , dim=4 ), dim=3 ) & … … 338 339 ! 339 340 !== melt ponds ==! 340 IF ( ln_pnd_LEV ) THEN341 IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN 341 342 ! concentration 342 343 zamsk = 1._wp … … 358 359 359 360 ! --- Lateral boundary conditions --- ! 360 IF ( ln_pnd_LEV.AND. ln_pnd_lids ) THEN361 IF ( ( ln_pnd_LEV .OR. ln_pnd_TOPO ) .AND. ln_pnd_lids ) THEN 361 362 CALL lbc_lnk_multi( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp & 362 363 & , pa_ip,'T',1._wp, pv_ip,'T',1._wp, pv_il,'T',1._wp ) 363 ELSEIF( ln_pnd_LEV.AND. .NOT.ln_pnd_lids ) THEN364 ELSEIF( ( ln_pnd_LEV .OR. ln_pnd_TOPO ) .AND. .NOT.ln_pnd_lids ) THEN 364 365 CALL lbc_lnk_multi( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp & 365 366 & , pa_ip,'T',1._wp, pv_ip,'T',1._wp ) … … 379 380 ! 380 381 ! --- diagnostics --- ! 381 diag_adv_mass(:,:) = diag_adv_mass(:,:) + ( SUM( pv_i(:,:,:) , dim=3 ) * rhoi + SUM( pv_s(:,:,:) , dim=3 ) * rhos & 382 diag_adv_mass(:,:) = diag_adv_mass(:,:) + ( SUM( pv_i (:,:,:) , dim=3 ) * rhoi + SUM( pv_s (:,:,:) , dim=3 ) * rhos & 383 & + SUM( pv_ip(:,:,:) , dim=3 ) * rhow + SUM( pv_il(:,:,:) , dim=3 ) * rhow & 382 384 & - zdiag_adv_mass(:,:) ) * z1_dt 383 385 diag_adv_salt(:,:) = diag_adv_salt(:,:) + ( SUM( psv_i(:,:,:) , dim=3 ) * rhoi & … … 1497 1499 ! ! -- check h_ip -- ! 1498 1500 ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 1499 IF( ln_pnd_LEV.AND. pv_ip(ji,jj,jl) > 0._wp ) THEN1501 IF( ( ln_pnd_LEV .OR. ln_pnd_TOPO ) .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 1500 1502 zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 1501 1503 IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icedyn_rdgrft.F90
r13618 r14046 140 140 INTEGER , DIMENSION(jpij) :: iptidx ! compute ridge/raft or not 141 141 REAL(wp), DIMENSION(jpij) :: zdivu, zdelt ! 1D divu_i & delta_i 142 REAL(wp), DIMENSION(jpij) :: zconv ! 1D rdg_conv (if EAP rheology) 142 143 ! 143 144 INTEGER, PARAMETER :: jp_itermax = 20 … … 175 176 ! just needed here 176 177 CALL tab_2d_1d( npti, nptidx(1:npti), zdelt (1:npti) , delta_i ) 178 CALL tab_2d_1d( npti, nptidx(1:npti), zconv (1:npti) , rdg_conv ) 177 179 ! needed here and in the iteration loop 178 180 CALL tab_2d_1d( npti, nptidx(1:npti), zdivu (1:npti) , divu_i) ! zdivu is used as a work array here (no change in divu_i) … … 184 186 ! closing_net = rate at which open water area is removed + ice area removed by ridging 185 187 ! - ice area added in new ridges 186 closing_net(ji) = rn_csrdg * 0.5_wp * ( zdelt(ji) - ABS( zdivu(ji) ) ) - MIN( zdivu(ji), 0._wp ) 188 IF( ln_rhg_EVP .OR. ln_rhg_VP ) & 189 & closing_net(ji) = rn_csrdg * 0.5_wp * ( zdelt(ji) - ABS( zdivu(ji) ) ) - MIN( zdivu(ji), 0._wp ) 190 IF( ln_rhg_EAP ) closing_net(ji) = zconv(ji) 187 191 ! 188 192 IF( zdivu(ji) < 0._wp ) closing_net(ji) = MAX( closing_net(ji), -zdivu(ji) ) ! make sure the closing rate is large enough … … 575 579 oirft2(ji) = oa_i_2d(ji,jl1) * afrft * hi_hrft 576 580 577 IF ( ln_pnd_LEV ) THEN581 IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN 578 582 aprdg1 = a_ip_2d(ji,jl1) * afrdg 579 583 aprdg2(ji) = a_ip_2d(ji,jl1) * afrdg * hi_hrdg(ji,jl1) … … 612 616 sv_i_2d(ji,jl1) = sv_i_2d(ji,jl1) - sirdg1 - sirft(ji) 613 617 oa_i_2d(ji,jl1) = oa_i_2d(ji,jl1) - oirdg1 - oirft1 614 IF ( ln_pnd_LEV ) THEN618 IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN 615 619 a_ip_2d(ji,jl1) = a_ip_2d(ji,jl1) - aprdg1 - aprft1 616 620 v_ip_2d(ji,jl1) = v_ip_2d(ji,jl1) - vprdg(ji) - vprft(ji) … … 709 713 v_s_2d (ji,jl2) = v_s_2d (ji,jl2) + ( vsrdg (ji) * rn_fsnwrdg * fvol(ji) + & 710 714 & vsrft (ji) * rn_fsnwrft * zswitch(ji) ) 711 IF ( ln_pnd_LEV ) THEN715 IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN 712 716 v_ip_2d (ji,jl2) = v_ip_2d(ji,jl2) + ( vprdg (ji) * rn_fpndrdg * fvol (ji) & 713 717 & + vprft (ji) * rn_fpndrft * zswitch(ji) ) … … 776 780 ! !--------------------------------------------------! 777 781 strength(:,:) = rn_pstar * SUM( v_i(:,:,:), dim=3 ) * EXP( -rn_crhg * ( 1._wp - SUM( a_i(:,:,:), dim=3 ) ) ) 778 ismooth = 1 782 ismooth = 1 ! original code 783 ! ismooth = 0 ! try for EAP stability 779 784 ! !--------------------------------------------------! 780 785 ELSE ! Zero strength ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icedyn_rhg.F90
r13472 r14046 17 17 USE ice ! sea-ice: variables 18 18 USE icedyn_rhg_evp ! sea-ice: EVP rheology 19 USE icedyn_rhg_eap ! sea-ice: EAP rheology 20 USE icedyn_rhg_vp ! sea-ice: VP rheology 19 21 USE icectl ! sea-ice: control prints 20 22 ! … … 33 35 ! ! associated indices: 34 36 INTEGER, PARAMETER :: np_rhgEVP = 1 ! EVP rheology 35 !! INTEGER, PARAMETER :: np_rhgEAP = 2 ! EAP rheology 37 INTEGER, PARAMETER :: np_rhgEAP = 2 ! EAP rheology 38 INTEGER, PARAMETER :: np_rhgVP = 3 ! VP rheology 36 39 37 ! ** namelist (namrhg) **38 LOGICAL :: ln_rhg_EVP ! EVP rheology39 40 ! 40 41 !!---------------------------------------------------------------------- … … 77 78 ! !------------------------! 78 79 CALL ice_dyn_rhg_evp( kt, Kmm, stress1_i, stress2_i, stress12_i, shear_i, divu_i, delta_i ) 79 ! 80 ! 81 ! !------------------------! 82 CASE( np_rhgVP ) ! Viscous-Plastic ! 83 ! !------------------------! 84 CALL ice_dyn_rhg_vp ( kt, shear_i, divu_i, delta_i ) 85 ! 86 ! !----------------------------! 87 CASE( np_rhgEAP ) ! Elasto-Anisotropic-Plastic ! 88 ! !----------------------------! 89 CALL ice_dyn_rhg_eap( kt, Kmm, stress1_i, stress2_i, stress12_i, shear_i, divu_i, delta_i, aniso_11, aniso_12, rdg_conv ) 80 90 END SELECT 81 91 ! 82 IF( lrst_ice ) THEN !* write EVP fields in the restart file 83 IF( ln_rhg_EVP ) CALL rhg_evp_rst( 'WRITE', kt ) 92 IF( lrst_ice ) THEN 93 IF( ln_rhg_EVP ) CALL rhg_evp_rst( 'WRITE', kt ) !* write EVP fields in the restart file 94 IF( ln_rhg_EAP ) CALL rhg_eap_rst( 'WRITE', kt ) !* write EAP fields in the restart file 95 ! MV note: no restart needed for VP as there is no time equation for stress tensor 84 96 ENDIF 85 97 ! … … 108 120 INTEGER :: ios, ioptio ! Local integer output status for namelist read 109 121 !! 110 NAMELIST/namdyn_rhg/ ln_rhg_EVP, ln_aEVP, rn_creepl, rn_ecc , nn_nevp, rn_relast, nn_rhg_chkcvg 122 NAMELIST/namdyn_rhg/ ln_rhg_EVP, ln_aEVP, ln_rhg_EAP, rn_creepl, rn_ecc , nn_nevp, rn_relast, nn_rhg_chkcvg, & !-- evp 123 & ln_rhg_VP, nn_vp_nout, nn_vp_ninn, nn_vp_chkcvg !-- vp 111 124 !!------------------------------------------------------------------- 112 125 ! … … 124 137 WRITE(numout,*) ' rheology EVP (icedyn_rhg_evp) ln_rhg_EVP = ', ln_rhg_EVP 125 138 WRITE(numout,*) ' use adaptive EVP (aEVP) ln_aEVP = ', ln_aEVP 126 WRITE(numout,*) ' creep limit rn_creepl = ', rn_creepl 127 WRITE(numout,*) ' eccentricity of the elliptical yield curve rn_ecc = ', rn_ecc 139 WRITE(numout,*) ' creep limit rn_creepl = ', rn_creepl ! also used by vp 140 WRITE(numout,*) ' eccentricity of the elliptical yield curve rn_ecc = ', rn_ecc ! also used by vp 128 141 WRITE(numout,*) ' number of iterations for subcycling nn_nevp = ', nn_nevp 129 142 WRITE(numout,*) ' ratio of elastic timescale over ice time step rn_relast = ', rn_relast 130 WRITE(numout,*) ' check convergence of rheology nn_rhg_chkcvg = ', nn_rhg_chkcvg 131 IF ( nn_rhg_chkcvg == 0 ) THEN ; WRITE(numout,*) ' no check' 132 ELSEIF( nn_rhg_chkcvg == 1 ) THEN ; WRITE(numout,*) ' check cvg at the main time step' 133 ELSEIF( nn_rhg_chkcvg == 2 ) THEN ; WRITE(numout,*) ' check cvg at both main and rheology time steps' 143 WRITE(numout,*) ' check convergence of rheology nn_rhg_chkcvg = ', nn_rhg_chkcvg 144 WRITE(numout,*) ' rheology VP (icedyn_rhg_VP) ln_rhg_VP = ', ln_rhg_VP 145 WRITE(numout,*) ' number of outer iterations nn_vp_nout = ', nn_vp_nout 146 WRITE(numout,*) ' number of inner iterations nn_vp_ninn = ', nn_vp_ninn 147 WRITE(numout,*) ' iteration step for convergence check nn_vp_chkcvg = ', nn_vp_chkcvg 148 IF( ln_rhg_EVP ) THEN 149 IF ( nn_rhg_chkcvg == 0 ) THEN ; WRITE(numout,*) ' no check cvg' 150 ELSEIF( nn_rhg_chkcvg == 1 ) THEN ; WRITE(numout,*) ' check cvg at the main time step' 151 ELSEIF( nn_rhg_chkcvg == 2 ) THEN ; WRITE(numout,*) ' check cvg at both main and rheology time steps' 152 ENDIF 134 153 ENDIF 154 WRITE(numout,*) ' rheology EAP (icedyn_rhg_eap) ln_rhg_EAP = ', ln_rhg_EAP 135 155 ENDIF 136 156 ! … … 138 158 ioptio = 0 139 159 IF( ln_rhg_EVP ) THEN ; ioptio = ioptio + 1 ; nice_rhg = np_rhgEVP ; ENDIF 140 !! IF( ln_rhg_EAP ) THEN ; ioptio = ioptio + 1 ; nice_rhg = np_rhgEAP ; ENDIF 160 IF( ln_rhg_EAP ) THEN ; ioptio = ioptio + 1 ; nice_rhg = np_rhgEAP ; ENDIF 161 IF( ln_rhg_VP ) THEN ; ioptio = ioptio + 1 ; nice_rhg = np_rhgVP ; ENDIF 141 162 IF( ioptio /= 1 ) CALL ctl_stop( 'ice_dyn_rhg_init: choose one and only one ice rheology' ) 142 163 ! 143 164 IF( ln_rhg_EVP ) CALL rhg_evp_rst( 'READ' ) !* read or initialize all required files 165 IF( ln_rhg_EAP ) CALL rhg_eap_rst( 'READ' ) !* read or initialize all required files 166 ! no restart for VP as there is no explicit time dependency in the equation 144 167 ! 145 168 END SUBROUTINE ice_dyn_rhg_init -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icedyn_rhg_evp.F90
r13612 r14046 199 199 zfmask(ji,jj) = tmask(ji,jj,1) * tmask(ji+1,jj,1) * tmask(ji,jj+1,1) * tmask(ji+1,jj+1,1) 200 200 END_2D 201 CALL lbc_lnk( 'icedyn_rhg_evp', zfmask, 'F', 1._wp 201 CALL lbc_lnk( 'icedyn_rhg_evp', zfmask, 'F', 1._wp) 202 202 203 203 ! Lateral boundary conditions on velocity (modify zfmask) … … 326 326 zvV = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 327 327 ! ice-bottom stress at U points 328 zvCr = zaU(ji,jj) * rn_lf_depfra * hu(ji,jj,Kmm) 328 zvCr = zaU(ji,jj) * rn_lf_depfra * hu(ji,jj,Kmm) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0 329 329 ztaux_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 330 330 ! ice-bottom stress at V points 331 zvCr = zaV(ji,jj) * rn_lf_depfra * hv(ji,jj,Kmm) 331 zvCr = zaV(ji,jj) * rn_lf_depfra * hv(ji,jj,Kmm) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0 332 332 ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 333 333 ! ice_bottom stress at T points 334 zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj) 334 zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj) * ( 1._wp - icb_mask(ji,jj) ) ! if grounded icebergs are read: ocean depth = 0 335 335 tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 336 336 END_2D … … 1033 1033 iter = kt + nn_fsbc - 1 ! ice restarts are written at kt == nitrst - nn_fsbc + 1 1034 1034 ! 1035 CALL iom_rstput( iter, nitrst, numriw, 'stress1_i' , stress1_i 1036 CALL iom_rstput( iter, nitrst, numriw, 'stress2_i' , stress2_i 1035 CALL iom_rstput( iter, nitrst, numriw, 'stress1_i' , stress1_i ) 1036 CALL iom_rstput( iter, nitrst, numriw, 'stress2_i' , stress2_i ) 1037 1037 CALL iom_rstput( iter, nitrst, numriw, 'stress12_i', stress12_i ) 1038 1038 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/iceistate.F90
r13472 r14046 426 426 ! 4) Snow-ice mass (case ice is fully embedded) 427 427 !---------------------------------------------- 428 snwice_mass (:,:) = tmask(:,:,1) * SUM( rhos * v_s (:,:,:) + rhoi * v_i(:,:,:), dim=3 ) ! snow+ice mass428 snwice_mass (:,:) = tmask(:,:,1) * SUM( rhos * v_s + rhoi * v_i + rhow * ( v_ip + v_il ), dim=3 ) ! snow+ice mass 429 429 snwice_mass_b(:,:) = snwice_mass(:,:) 430 430 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/iceitd.F90
r13618 r14046 29 29 USE lib_fortran ! fortran utilities (glob_sum + no signed zero) 30 30 USE prtctl ! Print control 31 USE timing ! Timing 31 32 32 33 IMPLICIT NONE … … 87 88 REAL(wp), DIMENSION(jpij,0:jpl) :: zhbnew ! new boundaries of ice categories 88 89 !!------------------------------------------------------------------ 90 IF( ln_timing ) CALL timing_start('iceitd_rem') 89 91 90 92 IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_itd_rem: remapping ice thickness distribution' … … 315 317 IF ( a_i_1d(ji) > epsi10 .AND. h_i_1d(ji) < rn_himin ) THEN 316 318 a_i_1d(ji) = a_i_1d(ji) * h_i_1d(ji) / rn_himin 317 IF( ln_pnd_LEV ) a_ip_1d(ji) = a_ip_1d(ji) * h_i_1d(ji) / rn_himin319 IF( ln_pnd_LEV .OR. ln_pnd_TOPO ) a_ip_1d(ji) = a_ip_1d(ji) * h_i_1d(ji) / rn_himin 318 320 h_i_1d(ji) = rn_himin 319 321 ENDIF … … 328 330 IF( ln_icediachk ) CALL ice_cons_hsm(1, 'iceitd_rem', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) 329 331 IF( ln_icediachk ) CALL ice_cons2D (1, 'iceitd_rem', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) 332 IF( ln_timing ) CALL timing_stop ('iceitd_rem') 330 333 ! 331 334 END SUBROUTINE ice_itd_rem … … 486 489 zaTsfn(ji,jl2) = zaTsfn(ji,jl2) + ztrans 487 490 ! 488 IF ( ln_pnd_LEV ) THEN491 IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN 489 492 ztrans = a_ip_2d(ji,jl1) * zworka(ji) ! Pond fraction 490 493 a_ip_2d(ji,jl1) = a_ip_2d(ji,jl1) - ztrans 491 494 a_ip_2d(ji,jl2) = a_ip_2d(ji,jl2) + ztrans 492 495 ! 493 ztrans = v_ip_2d(ji,jl1) * zwork a(ji) ! Pond volume (also proportional to da/a)496 ztrans = v_ip_2d(ji,jl1) * zworkv(ji) ! Pond volume 494 497 v_ip_2d(ji,jl1) = v_ip_2d(ji,jl1) - ztrans 495 498 v_ip_2d(ji,jl2) = v_ip_2d(ji,jl2) + ztrans 496 499 ! 497 500 IF ( ln_pnd_lids ) THEN ! Pond lid volume 498 ztrans = v_il_2d(ji,jl1) * zwork a(ji)501 ztrans = v_il_2d(ji,jl1) * zworkv(ji) 499 502 v_il_2d(ji,jl1) = v_il_2d(ji,jl1) - ztrans 500 503 v_il_2d(ji,jl2) = v_il_2d(ji,jl2) + ztrans … … 606 609 REAL(wp), DIMENSION(jpij,jpl-1) :: zdaice, zdvice ! ice area and volume transferred 607 610 !!------------------------------------------------------------------ 611 IF( ln_timing ) CALL timing_start('iceitd_reb') 608 612 ! 609 613 IF( kt == nit000 .AND. lwp ) WRITE(numout,*) '-- ice_itd_reb: rebining ice thickness distribution' … … 635 639 jdonor(ji,jl) = jl 636 640 ! how much of a_i you send in cat sup is somewhat arbitrary 637 !!clem: these do not work properly after a restart (I do not know why) => not sure it is still true 638 !! zdaice(ji,jl) = a_i_1d(ji) * ( h_i_1d(ji) - hi_max(jl) + epsi10 ) / h_i_1d(ji) 639 !! zdvice(ji,jl) = v_i_1d(ji) - ( a_i_1d(ji) - zdaice(ji,jl) ) * ( hi_max(jl) - epsi10 ) 640 !!clem: these do not work properly after a restart (I do not know why) => not sure it is still true 641 !! zdaice(ji,jl) = a_i_1d(ji) 642 !! zdvice(ji,jl) = v_i_1d(ji) 643 !!clem: these are from UCL and work ok 644 zdaice(ji,jl) = a_i_1d(ji) * 0.5_wp 645 zdvice(ji,jl) = v_i_1d(ji) - zdaice(ji,jl) * ( hi_max(jl) + hi_max(jl-1) ) * 0.5_wp 641 ! these are from CICE => transfer everything 642 !!zdaice(ji,jl) = a_i_1d(ji) 643 !!zdvice(ji,jl) = v_i_1d(ji) 644 ! these are from LLN => transfer only half of the category 645 zdaice(ji,jl) = 0.5_wp * a_i_1d(ji) 646 zdvice(ji,jl) = v_i_1d(ji) - (1._wp - 0.5_wp) * a_i_1d(ji) * hi_mean(jl) 646 647 END DO 647 648 ! … … 686 687 IF( ln_icediachk ) CALL ice_cons_hsm(1, 'iceitd_reb', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) 687 688 IF( ln_icediachk ) CALL ice_cons2D (1, 'iceitd_reb', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) 689 IF( ln_timing ) CALL timing_stop ('iceitd_reb') 688 690 ! 689 691 END SUBROUTINE ice_itd_reb -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icerst.F90
r13472 r14046 55 55 CHARACTER(len=50) :: clname ! ice output restart file name 56 56 CHARACTER(len=256) :: clpath ! full path to ice output restart file 57 CHARACTER(LEN=52) :: clpname ! ocean output restart file name including prefix for AGRIF 57 58 !!---------------------------------------------------------------------- 58 59 ! … … 84 85 ENDIF 85 86 ! 86 CALL iom_open( TRIM(clpath)//TRIM(clname), numriw, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) 87 IF(.NOT.lwxios) THEN 88 CALL iom_open( TRIM(clpath)//TRIM(clname), numriw, ldwrt = .TRUE., kdlev = jpl, cdcomp = 'ICE' ) 89 ELSE 90 #if defined key_iomput 91 cw_icerst_cxt = "rstwi_"//TRIM(ADJUSTL(clkt)) 92 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 93 clpname = clname 94 ELSE 95 clpname = TRIM(Agrif_CFixed())//"_"//clname 96 ENDIF 97 numriw = iom_xios_setid(TRIM(clpath)//TRIM(clpname)) 98 CALL iom_init( cw_icerst_cxt, kdid = numriw, ld_closedef = .FALSE. ) 99 CALL iom_swap( cxios_context ) 100 #else 101 clinfo = 'Can not use XIOS in rst_opn' 102 CALL ctl_stop(TRIM(clinfo)) 103 #endif 104 ENDIF 87 105 lrst_ice = .TRUE. 88 106 ENDIF … … 117 135 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' 118 136 ENDIF 119 137 120 138 ! Write in numriw (if iter == nitrst) 121 139 ! ------------------ … … 123 141 CALL iom_rstput( iter, nitrst, numriw, 'nn_fsbc', REAL( nn_fsbc, wp ) ) ! time-step 124 142 CALL iom_rstput( iter, nitrst, numriw, 'kt_ice' , REAL( iter , wp ) ) ! date 125 CALL iom_delay_rst( 'WRITE', 'ICE', numriw ) ! save only ice delayed global communication variables 143 144 IF(.NOT.lwxios) CALL iom_delay_rst( 'WRITE', 'ICE', numriw ) ! save only ice delayed global communication variables 126 145 127 146 ! Prognostic variables … … 154 173 IF( ln_cpl ) THEN 155 174 CALL iom_rstput( iter, nitrst, numriw, 'cnd_ice', cnd_ice ) 156 CALL iom_rstput( iter, nitrst, numriw, 't1_ice' , t1_ice 175 CALL iom_rstput( iter, nitrst, numriw, 't1_ice' , t1_ice ) 157 176 ENDIF 158 177 ! … … 161 180 ! ------------------ 162 181 IF( iter == nitrst ) THEN 163 CALL iom_close( numriw ) 182 IF(.NOT.lwxios) THEN 183 CALL iom_close( numriw ) 184 ELSE 185 CALL iom_context_finalize( cw_icerst_cxt ) 186 iom_file(numriw)%nfid = 0 187 numriw = 0 188 ENDIF 164 189 lrst_ice = .FALSE. 165 190 ENDIF … … 181 206 CHARACTER(len=2) :: zchar, zchar1 182 207 REAL(wp) :: zfice, ziter 208 CHARACTER(lc) :: clpname 183 209 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z3d ! 3D workspace 184 210 !!---------------------------------------------------------------------- … … 190 216 ENDIF 191 217 218 lxios_sini = .FALSE. 192 219 CALL iom_open ( TRIM(cn_icerst_indir)//'/'//cn_icerst_in, numrir ) 220 221 IF( lrxios) THEN 222 cr_icerst_cxt = 'si3_rst' 223 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS for SI3' 224 ! IF( TRIM(Agrif_CFixed()) == '0' ) THEN 225 ! clpname = cn_icerst_in 226 ! ELSE 227 ! clpname = TRIM(Agrif_CFixed())//"_"//cn_icerst_in 228 ! ENDIF 229 CALL iom_init( cr_icerst_cxt, kdid = numrir, ld_closedef = .TRUE. ) 230 ENDIF 193 231 194 232 ! test if v_i exists … … 198 236 IF( id0 > 0 ) THEN ! == case of a normal restart == ! 199 237 ! ! ------------------------------ ! 200 201 238 ! Time info 202 239 CALL iom_get( numrir, 'nn_fsbc', zfice ) … … 278 315 ENDIF 279 316 280 CALL iom_delay_rst( 'READ', 'ICE', numrir ) ! read only ice delayed global communication variables 281 317 IF(.NOT.lrxios) CALL iom_delay_rst( 'READ', 'ICE', numrir ) ! read only ice delayed global communication variables 282 318 ! ! ---------------------------------- ! 283 319 ELSE ! == case of a simplified restart == ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icesbc.F90
r13472 r14046 62 62 !!------------------------------------------------------------------- 63 63 ! 64 IF( ln_timing ) CALL timing_start('ice _sbc')64 IF( ln_timing ) CALL timing_start('icesbc') 65 65 ! 66 66 IF( kt == nit000 .AND. lwp ) THEN … … 89 89 ENDIF 90 90 ! 91 IF( ln_timing ) CALL timing_stop('ice _sbc')91 IF( ln_timing ) CALL timing_stop('icesbc') 92 92 ! 93 93 END SUBROUTINE ice_sbc_tau … … 122 122 !!-------------------------------------------------------------------- 123 123 ! 124 IF( ln_timing ) CALL timing_start('ice _sbc_flx')124 IF( ln_timing ) CALL timing_start('icesbc') 125 125 126 126 IF( kt == nit000 .AND. lwp ) THEN … … 176 176 ENDIF 177 177 ! 178 IF( ln_timing ) CALL timing_stop('ice _sbc_flx')178 IF( ln_timing ) CALL timing_stop('icesbc') 179 179 ! 180 180 END SUBROUTINE ice_sbc_flx -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icestp.F90
r13721 r14046 121 121 !!---------------------------------------------------------------------- 122 122 ! 123 IF( ln_timing ) CALL timing_start('ice _stp')123 IF( ln_timing ) CALL timing_start('icestp') 124 124 ! 125 125 ! !-----------------------! … … 215 215 !!gm remark, the ocean-ice stress is not saved in ice diag call above ..... find a solution!!! 216 216 ! 217 IF( ln_timing ) CALL timing_stop('ice _stp')217 IF( ln_timing ) CALL timing_stop('icestp') 218 218 ! 219 219 END SUBROUTINE ice_stp … … 291 291 tn_ice(:,:,:) = t_su(:,:,:) ! initialisation of surface temp for coupled simu 292 292 ! 293 IF( ln_rstart ) CALL iom_close( numrir ) ! close input ice restart file 293 IF( ln_rstart ) THEN 294 CALL iom_close( numrir ) ! close input ice restart file 295 IF(lrxios) CALL iom_context_finalize( cr_icerst_cxt ) 296 ENDIF 294 297 ! 295 298 END SUBROUTINE ice_init … … 370 373 v_i_b (:,:,:) = v_i (:,:,:) ! ice volume 371 374 v_s_b (:,:,:) = v_s (:,:,:) ! snow volume 375 v_ip_b(:,:,:) = v_ip(:,:,:) ! pond volume 376 v_il_b(:,:,:) = v_il(:,:,:) ! pond lid volume 372 377 sv_i_b(:,:,:) = sv_i(:,:,:) ! salt content 373 378 e_s_b (:,:,:,:) = e_s (:,:,:,:) ! snow thermal energy … … 429 434 diag_heat(ji,jj) = 0._wp ; diag_sice(ji,jj) = 0._wp 430 435 diag_vice(ji,jj) = 0._wp ; diag_vsnw(ji,jj) = 0._wp 436 diag_aice(ji,jj) = 0._wp ; diag_vpnd(ji,jj) = 0._wp 431 437 432 438 tau_icebfr (ji,jj) = 0._wp ! landfast ice param only (clem: important to keep the init here) … … 454 460 qcn_ice (ji,jj,jl) = 0._wp ! conductive flux (ln_cndflx=T & ln_cndemule=T) 455 461 qtr_ice_bot(ji,jj,jl) = 0._wp ! part of solar radiation transmitted through the ice needed at least for outputs 462 ! Melt pond surface melt diagnostics (mv - more efficient: grouped into one water volume flux) 463 dh_i_sum_2d(ji,jj,jl) = 0._wp 464 dh_s_mlt_2d(ji,jj,jl) = 0._wp 456 465 END_2D 457 466 ENDDO … … 482 491 diag_vsnw(:,:) = diag_vsnw(:,:) & 483 492 & + SUM( v_s (:,:,:) - v_s_b (:,:,:) , dim=3 ) * r1_Dt_ice * rhos 493 diag_vpnd(:,:) = diag_vpnd(:,:) & 494 & + SUM( v_ip + v_il - v_ip_b - v_il_b , dim=3 ) * r1_Dt_ice * rhow 484 495 ! 485 496 IF( kn == 2 ) CALL iom_put ( 'hfxdhc' , diag_heat ) ! output of heat trend -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icethd.F90
r13643 r14046 166 166 qsb_ice_bot(ji,jj) = rswitch * MIN( qsb_ice_bot(ji,jj), - zqfr_neg * r1_Dt_ice / MAX( at_i(ji,jj), epsi10 ) ) 167 167 168 ! If conditions are always supercooled (such as at the mouth of ice-shelves), then ice grows continuously 169 ! ==> stop ice formation by artificially setting up the turbulent fluxes to 0 when volume > 20m (arbitrary) 170 IF( ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) > 0._wp .AND. vt_i(ji,jj) >= 20._wp ) THEN 171 zqfr = 0._wp 172 zqfr_pos = 0._wp 173 qsb_ice_bot(ji,jj) = 0._wp 174 ENDIF 175 ! 168 176 ! --- Energy Budget of the leads (qlead, J.m-2) --- ! 169 177 ! qlead is the energy received from the atm. in the leads. … … 239 247 IF( ln_icedH ) THEN ! --- Growing/Melting --- ! 240 248 CALL ice_thd_dh ! Ice-Snow thickness 241 CALL ice_thd_pnd ! Melt ponds formation242 249 CALL ice_thd_ent( e_i_1d(1:npti,:) ) ! Ice enthalpy remapping 243 250 ENDIF … … 260 267 IF( ln_icediachk ) CALL ice_cons2D (1, 'icethd', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) 261 268 ! 269 IF ( ln_pnd .AND. ln_icedH ) & 270 & CALL ice_thd_pnd ! --- Melt ponds 271 ! 262 272 IF( jpl > 1 ) CALL ice_itd_rem( kt ) ! --- Transport ice between thickness categories --- ! 263 273 ! … … 266 276 CALL ice_cor( kt , 2 ) ! --- Corrections --- ! 267 277 ! 268 oa_i(:,:,:) = oa_i(:,:,:) + a_i(:,:,:) * r dt_ice ! ice natural aging incrementation278 oa_i(:,:,:) = oa_i(:,:,:) + a_i(:,:,:) * rDt_ice ! ice natural aging incrementation 269 279 ! 270 280 ! convergence tests … … 377 387 CALL tab_2d_1d( npti, nptidx(1:npti), sz_i_1d(1:npti,jk), sz_i(:,:,jk,kl) ) 378 388 END DO 379 CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d (1:npti), a_ip (:,:,kl) )380 CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d (1:npti), h_ip (:,:,kl) )381 CALL tab_2d_1d( npti, nptidx(1:npti), h_il_1d (1:npti), h_il (:,:,kl) )382 389 ! 383 390 CALL tab_2d_1d( npti, nptidx(1:npti), qprec_ice_1d (1:npti), qprec_ice ) … … 409 416 CALL tab_2d_1d( npti, nptidx(1:npti), wfx_spr_1d (1:npti), wfx_spr ) 410 417 CALL tab_2d_1d( npti, nptidx(1:npti), wfx_lam_1d (1:npti), wfx_lam ) 411 CALL tab_2d_1d( npti, nptidx(1:npti), wfx_pnd_1d (1:npti), wfx_pnd )412 418 ! 413 419 CALL tab_2d_1d( npti, nptidx(1:npti), sfx_bog_1d (1:npti), sfx_bog ) … … 464 470 v_s_1d (1:npti) = h_s_1d (1:npti) * a_i_1d (1:npti) 465 471 sv_i_1d(1:npti) = s_i_1d (1:npti) * v_i_1d (1:npti) 466 v_ip_1d(1:npti) = h_ip_1d(1:npti) * a_ip_1d(1:npti)467 v_il_1d(1:npti) = h_il_1d(1:npti) * a_ip_1d(1:npti)468 472 oa_i_1d(1:npti) = o_i_1d (1:npti) * a_i_1d (1:npti) 469 473 … … 483 487 CALL tab_1d_2d( npti, nptidx(1:npti), sz_i_1d(1:npti,jk), sz_i(:,:,jk,kl) ) 484 488 END DO 485 CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_1d (1:npti), a_ip (:,:,kl) )486 CALL tab_1d_2d( npti, nptidx(1:npti), h_ip_1d (1:npti), h_ip (:,:,kl) )487 CALL tab_1d_2d( npti, nptidx(1:npti), h_il_1d (1:npti), h_il (:,:,kl) )488 489 ! 489 490 CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_sni_1d(1:npti), wfx_snw_sni ) … … 501 502 CALL tab_1d_2d( npti, nptidx(1:npti), wfx_spr_1d (1:npti), wfx_spr ) 502 503 CALL tab_1d_2d( npti, nptidx(1:npti), wfx_lam_1d (1:npti), wfx_lam ) 503 CALL tab_1d_2d( npti, nptidx(1:npti), wfx_pnd_1d (1:npti), wfx_pnd )504 504 ! 505 505 CALL tab_1d_2d( npti, nptidx(1:npti), sfx_bog_1d (1:npti), sfx_bog ) … … 529 529 CALL tab_1d_2d( npti, nptidx(1:npti), cnd_ice_1d(1:npti), cnd_ice(:,:,kl) ) 530 530 CALL tab_1d_2d( npti, nptidx(1:npti), t1_ice_1d (1:npti), t1_ice (:,:,kl) ) 531 ! Melt ponds 532 CALL tab_1d_2d( npti, nptidx(1:npti), dh_i_sum (1:npti) , dh_i_sum_2d(:,:,kl) ) 533 CALL tab_1d_2d( npti, nptidx(1:npti), dh_s_mlt (1:npti) , dh_s_mlt_2d(:,:,kl) ) 531 534 ! SIMIP diagnostics 532 535 CALL tab_1d_2d( npti, nptidx(1:npti), t_si_1d (1:npti), t_si (:,:,kl) ) … … 537 540 CALL tab_1d_2d( npti, nptidx(1:npti), v_s_1d (1:npti), v_s (:,:,kl) ) 538 541 CALL tab_1d_2d( npti, nptidx(1:npti), sv_i_1d(1:npti), sv_i(:,:,kl) ) 539 CALL tab_1d_2d( npti, nptidx(1:npti), v_ip_1d(1:npti), v_ip(:,:,kl) )540 CALL tab_1d_2d( npti, nptidx(1:npti), v_il_1d(1:npti), v_il(:,:,kl) )541 542 CALL tab_1d_2d( npti, nptidx(1:npti), oa_i_1d(1:npti), oa_i(:,:,kl) ) 542 543 ! check convergence of heat diffusion scheme -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icethd_dh.F90
r13643 r14046 55 55 !! - Snow ice formation 56 56 !! 57 !! ** Note : h=max(0,h+dh) are often used to ensure positivity of h. 58 !! very small negative values can occur otherwise (e.g. -1.e-20) 59 !! 57 60 !! References : Bitz and Lipscomb, 1999, J. Geophys. Res. 58 61 !! Fichefet T. and M. Maqueda 1997, J. Geophys. Res., 102(C6), 12609-12646 … … 79 82 REAL(wp) :: zfmdt ! exchange mass flux x time step (J/m2), >0 towards the ocean 80 83 81 REAL(wp), DIMENSION(jpij) :: zqprec ! energy of fallen snow (J.m-3)82 84 REAL(wp), DIMENSION(jpij) :: zq_top ! heat for surface ablation (J.m-2) 83 85 REAL(wp), DIMENSION(jpij) :: zq_bot ! heat for bottom ablation (J.m-2) … … 85 87 REAL(wp), DIMENSION(jpij) :: zf_tt ! Heat budget to determine melting or freezing(W.m-2) 86 88 REAL(wp), DIMENSION(jpij) :: zevap_rema ! remaining mass flux from sublimation (kg.m-2) 87 88 REAL(wp), DIMENSION(jpij) :: zdh_s_mel ! snow melt 89 REAL(wp), DIMENSION(jpij) :: zdh_s_pre ! snow precipitation 90 REAL(wp), DIMENSION(jpij) :: zdh_s_sub ! snow sublimation 91 92 REAL(wp), DIMENSION(jpij,nlay_s) :: zh_s ! snw layer thickness 93 REAL(wp), DIMENSION(jpij,nlay_i) :: zh_i ! ice layer thickness 94 REAL(wp), DIMENSION(jpij,nlay_i) :: zdeltah 95 INTEGER , DIMENSION(jpij,nlay_i) :: icount ! number of layers vanished by melting 96 89 REAL(wp), DIMENSION(jpij) :: zdeltah 97 90 REAL(wp), DIMENSION(jpij) :: zsnw ! distribution of snow after wind blowing 91 92 INTEGER , DIMENSION(jpij,nlay_i) :: icount ! number of layers vanishing by melting 93 REAL(wp), DIMENSION(jpij,0:nlay_i+1) :: zh_i ! ice layer thickness (m) 94 REAL(wp), DIMENSION(jpij,0:nlay_s ) :: zh_s ! snw layer thickness (m) 95 REAL(wp), DIMENSION(jpij,0:nlay_s ) :: ze_s ! snw layer enthalpy (J.m-3) 98 96 99 97 REAL(wp) :: zswitch_sal … … 108 106 END SELECT 109 107 110 ! initialize layer thicknesses and enthalpies 108 ! initialize ice layer thicknesses and enthalpies 109 eh_i_old(1:npti,0:nlay_i+1) = 0._wp 111 110 h_i_old (1:npti,0:nlay_i+1) = 0._wp 112 eh_i_old(1:npti,0:nlay_i+1) = 0._wp111 zh_i (1:npti,0:nlay_i+1) = 0._wp 113 112 DO jk = 1, nlay_i 114 113 DO ji = 1, npti 114 eh_i_old(ji,jk) = h_i_1d(ji) * r1_nlay_i * e_i_1d(ji,jk) 115 115 h_i_old (ji,jk) = h_i_1d(ji) * r1_nlay_i 116 eh_i_old(ji,jk) = e_i_1d(ji,jk) * h_i_old(ji,jk) 116 zh_i (ji,jk) = h_i_1d(ji) * r1_nlay_i 117 END DO 118 END DO 119 ! 120 ! initialize snw layer thicknesses and enthalpies 121 zh_s(1:npti,0) = 0._wp 122 ze_s(1:npti,0) = 0._wp 123 DO jk = 1, nlay_s 124 DO ji = 1, npti 125 zh_s(ji,jk) = h_s_1d(ji) * r1_nlay_s 126 ze_s(ji,jk) = e_s_1d(ji,jk) 117 127 END DO 118 128 END DO … … 141 151 zf_tt(ji) = qcn_ice_bot_1d(ji) + qsb_ice_bot_1d(ji) + fhld_1d(ji) + qtr_ice_bot_1d(ji) * frq_m_1d(ji) 142 152 zq_bot(ji) = MAX( 0._wp, zf_tt(ji) * rDt_ice ) 143 END DO144 145 ! Ice and snow layer thicknesses146 !-------------------------------147 DO jk = 1, nlay_i148 DO ji = 1, npti149 zh_i(ji,jk) = h_i_1d(ji) * r1_nlay_i150 END DO151 END DO152 153 DO jk = 1, nlay_s154 DO ji = 1, npti155 zh_s(ji,jk) = h_s_1d(ji) * r1_nlay_s156 END DO157 153 END DO 158 154 … … 167 163 DO ji = 1, npti 168 164 IF( t_s_1d(ji,jk) > rt0 ) THEN 169 hfx_res_1d (ji) = hfx_res_1d (ji) + e_s_1d(ji,jk) * zh_s(ji,jk) * a_i_1d(ji) * r1_Dt_ice ! heat flux to the ocean [W.m-2], < 0170 wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) + rhos 165 hfx_res_1d (ji) = hfx_res_1d (ji) - ze_s(ji,jk) * zh_s(ji,jk) * a_i_1d(ji) * r1_Dt_ice ! heat flux to the ocean [W.m-2], < 0 166 wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) + rhos * zh_s(ji,jk) * a_i_1d(ji) * r1_Dt_ice ! mass flux 171 167 ! updates 172 dh_s_mlt(ji) = dh_s_mlt(ji) - zh_s(ji,jk)173 h_s_1d (ji) = h_s_1d(ji) - zh_s(ji,jk)168 dh_s_mlt(ji) = dh_s_mlt(ji) - zh_s(ji,jk) 169 h_s_1d (ji) = MAX( 0._wp, h_s_1d (ji) - zh_s(ji,jk) ) 174 170 zh_s (ji,jk) = 0._wp 175 e_s_1d (ji,jk) = 0._wp 176 t_s_1d (ji,jk) = rt0 171 ze_s (ji,jk) = 0._wp 177 172 END IF 178 173 END DO … … 181 176 ! Snow precipitation 182 177 !------------------- 183 CALL ice_var_snwblow( 1.0_wp - at_i_1d(1:npti), zsnw(1:npti) ) ! snow distribution over ice after wind blowing 184 185 zdeltah(1:npti,:) = 0._wp 178 CALL ice_var_snwblow( 1._wp - at_i_1d(1:npti), zsnw(1:npti) ) ! snow distribution over ice after wind blowing 179 186 180 DO ji = 1, npti 187 181 IF( sprecip_1d(ji) > 0._wp ) THEN 182 zh_s(ji,0) = zsnw(ji) * sprecip_1d(ji) * rDt_ice * r1_rhos / at_i_1d(ji) ! thickness of precip 183 ze_s(ji,0) = MAX( 0._wp, - qprec_ice_1d(ji) ) ! enthalpy of the precip (>0, J.m-3) 188 184 ! 189 ! --- precipitation --- 190 zdh_s_pre (ji) = zsnw(ji) * sprecip_1d(ji) * rDt_ice * r1_rhos / at_i_1d(ji) ! thickness change 191 zqprec (ji) = - qprec_ice_1d(ji) ! enthalpy of the precip (>0, J.m-3) 185 hfx_spr_1d(ji) = hfx_spr_1d(ji) + ze_s(ji,0) * zh_s(ji,0) * a_i_1d(ji) * r1_Dt_ice ! heat flux from snow precip (>0, W.m-2) 186 wfx_spr_1d(ji) = wfx_spr_1d(ji) - rhos * zh_s(ji,0) * a_i_1d(ji) * r1_Dt_ice ! mass flux, <0 192 187 ! 193 hfx_spr_1d(ji) = hfx_spr_1d(ji) + zdh_s_pre(ji) * a_i_1d(ji) * zqprec(ji) * r1_Dt_ice ! heat flux from snow precip (>0, W.m-2)194 wfx_spr_1d(ji) = wfx_spr_1d(ji) - rhos * a_i_1d(ji) * zdh_s_pre(ji) * r1_Dt_ice ! mass flux, <0195 196 ! --- melt of falling snow ---197 rswitch = MAX( 0._wp , SIGN( 1._wp , zqprec(ji) - epsi20 ) )198 zdeltah (ji,1) = - rswitch * zq_top(ji) / MAX( zqprec(ji) , epsi20 ) ! thickness change199 zdeltah (ji,1) = MAX( - zdh_s_pre(ji), zdeltah(ji,1) ) ! bound melting200 hfx_snw_1d (ji) = hfx_snw_1d (ji) - zdeltah(ji,1) * a_i_1d(ji) * zqprec(ji) * r1_Dt_ice ! heat used to melt snow (W.m-2, >0)201 wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) - rhos * a_i_1d(ji) * zdeltah(ji,1) * r1_Dt_ice ! snow melting only = water into the ocean (then without snow precip), >0202 203 ! updates available heat + precipitations after melting204 dh_s_mlt (ji) = dh_s_mlt(ji) + zdeltah(ji,1)205 zq_top (ji) = MAX( 0._wp , zq_top (ji) + zdeltah(ji,1) * zqprec(ji) )206 zdh_s_pre(ji) = zdh_s_pre(ji) + zdeltah(ji,1)207 208 188 ! update thickness 209 h_s_1d(ji) = MAX( 0._wp , h_s_1d(ji) + zdh_s_pre(ji) ) 210 ! 211 ELSE 212 ! 213 zdh_s_pre(ji) = 0._wp 214 zqprec (ji) = 0._wp 215 ! 189 h_s_1d(ji) = h_s_1d(ji) + zh_s(ji,0) 216 190 ENDIF 217 END DO218 219 ! recalculate snow layers220 DO jk = 1, nlay_s221 DO ji = 1, npti222 zh_s(ji,jk) = h_s_1d(ji) * r1_nlay_s223 END DO224 191 END DO 225 192 226 193 ! Snow melting 227 194 ! ------------ 228 ! If heat still available (zq_top > 0), then melt more snow 229 zdeltah(1:npti,:) = 0._wp 230 zdh_s_mel(1:npti) = 0._wp 231 DO jk = 1, nlay_s 195 ! If heat still available (zq_top > 0) 196 ! then all snw precip has been melted and we need to melt more snow 197 DO jk = 0, nlay_s 232 198 DO ji = 1, npti 233 199 IF( zh_s(ji,jk) > 0._wp .AND. zq_top(ji) > 0._wp ) THEN 234 200 ! 235 rswitch = MAX( 0._wp, SIGN( 1._wp, e_s_1d(ji,jk) - epsi20 ) ) 236 zdeltah (ji,jk) = - rswitch * zq_top(ji) / MAX( e_s_1d(ji,jk), epsi20 ) ! thickness change 237 zdeltah (ji,jk) = MAX( zdeltah(ji,jk) , - zh_s(ji,jk) ) ! bound melting 238 zdh_s_mel(ji) = zdh_s_mel(ji) + zdeltah(ji,jk) 239 240 hfx_snw_1d(ji) = hfx_snw_1d(ji) - zdeltah(ji,jk) * a_i_1d(ji) * e_s_1d (ji,jk) * r1_Dt_ice ! heat used to melt snow(W.m-2, >0) 241 wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) - rhos * a_i_1d(ji) * zdeltah(ji,jk) * r1_Dt_ice ! snow melting only = water into the ocean (then without snow precip) 201 rswitch = MAX( 0._wp , SIGN( 1._wp , ze_s(ji,jk) - epsi20 ) ) 202 zdum = - rswitch * zq_top(ji) / MAX( ze_s(ji,jk), epsi20 ) ! thickness change 203 zdum = MAX( zdum , - zh_s(ji,jk) ) ! bound melting 204 205 hfx_snw_1d (ji) = hfx_snw_1d (ji) - ze_s(ji,jk) * zdum * a_i_1d(ji) * r1_Dt_ice ! heat used to melt snow(W.m-2, >0) 206 wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) - rhos * zdum * a_i_1d(ji) * r1_Dt_ice ! snow melting only = water into the ocean 242 207 243 208 ! updates available heat + thickness 244 dh_s_mlt(ji) = dh_s_mlt(ji) + zdeltah(ji,jk) 245 zq_top (ji) = MAX( 0._wp , zq_top(ji) + zdeltah(ji,jk) * e_s_1d(ji,jk) ) 246 h_s_1d (ji) = MAX( 0._wp , h_s_1d(ji) + zdeltah(ji,jk) ) 247 zh_s (ji,jk) = MAX( 0._wp , zh_s(ji,jk) + zdeltah(ji,jk) ) 209 dh_s_mlt(ji) = dh_s_mlt(ji) + zdum 210 zq_top (ji) = MAX( 0._wp , zq_top (ji) + zdum * ze_s(ji,jk) ) 211 h_s_1d (ji) = MAX( 0._wp , h_s_1d (ji) + zdum ) 212 zh_s (ji,jk) = MAX( 0._wp , zh_s (ji,jk) + zdum ) 213 !!$ IF( zh_s(ji,jk) == 0._wp ) ze_s(ji,jk) = 0._wp 248 214 ! 249 215 ENDIF … … 255 221 ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates 256 222 ! comment: not counted in mass/heat exchange in iceupdate.F90 since this is an exchange with atm. (not ocean) 257 zdeltah(1:npti,:) = 0._wp 223 zdeltah (1:npti) = 0._wp ! total snow thickness that sublimates, < 0 224 zevap_rema(1:npti) = 0._wp 258 225 DO ji = 1, npti 259 226 IF( evap_ice_1d(ji) > 0._wp ) THEN 227 zdeltah (ji) = MAX( - evap_ice_1d(ji) * r1_rhos * rDt_ice, - h_s_1d(ji) ) ! amount of snw that sublimates, < 0 228 zevap_rema(ji) = MAX( 0._wp, evap_ice_1d(ji) * rDt_ice + zdeltah(ji) * rhos ) ! remaining evap in kg.m-2 (used for ice sublimation later on) 229 ENDIF 230 END DO 231 232 DO jk = 0, nlay_s 233 DO ji = 1, npti 234 zdum = MAX( -zh_s(ji,jk), zdeltah(ji) ) ! snow layer thickness that sublimates, < 0 260 235 ! 261 zdh_s_sub (ji) = MAX( - h_s_1d(ji) , - evap_ice_1d(ji) * r1_rhos * rDt_ice ) 262 zevap_rema(ji) = evap_ice_1d(ji) * rDt_ice + zdh_s_sub(ji) * rhos ! remaining evap in kg.m-2 (used for ice melting later on) 263 zdeltah (ji,1) = MAX( zdh_s_sub(ji), - zdh_s_pre(ji) ) 264 265 hfx_sub_1d (ji) = hfx_sub_1d(ji) + & ! Heat flux by sublimation [W.m-2], < 0 (sublimate snow that had fallen, then pre-existing snow) 266 & ( zdeltah(ji,1) * zqprec(ji) + ( zdh_s_sub(ji) - zdeltah(ji,1) ) * e_s_1d(ji,1) ) & 267 & * a_i_1d(ji) * r1_Dt_ice 268 wfx_snw_sub_1d(ji) = wfx_snw_sub_1d(ji) - rhos * a_i_1d(ji) * zdh_s_sub(ji) * r1_Dt_ice ! Mass flux by sublimation 269 270 ! new snow thickness 271 h_s_1d(ji) = MAX( 0._wp , h_s_1d(ji) + zdh_s_sub(ji) ) 272 ! update precipitations after sublimation and correct sublimation 273 zdh_s_pre(ji) = zdh_s_pre(ji) + zdeltah(ji,1) 274 zdh_s_sub(ji) = zdh_s_sub(ji) - zdeltah(ji,1) 275 ! 276 ELSE 277 ! 278 zdh_s_sub (ji) = 0._wp 279 zevap_rema(ji) = 0._wp 280 ! 281 ENDIF 282 END DO 283 284 ! --- Update snow diags --- ! 285 DO ji = 1, npti 286 dh_s_tot(ji) = zdh_s_mel(ji) + zdh_s_pre(ji) + zdh_s_sub(ji) 287 END DO 288 289 ! Update temperature, energy 290 !--------------------------- 291 ! new temp and enthalpy of the snow (remaining snow precip + remaining pre-existing snow) 292 DO jk = 1, nlay_s 293 DO ji = 1,npti 294 rswitch = MAX( 0._wp , SIGN( 1._wp, h_s_1d(ji) - epsi20 ) ) 295 e_s_1d(ji,jk) = rswitch / MAX( h_s_1d(ji), epsi20 ) * & 296 & ( ( zdh_s_pre(ji) ) * zqprec(ji) + & 297 & ( h_s_1d(ji) - zdh_s_pre(ji) ) * rhos * ( rcpi * ( rt0 - t_s_1d(ji,jk) ) + rLfus ) ) 298 END DO 299 END DO 300 236 hfx_sub_1d (ji) = hfx_sub_1d (ji) + ze_s(ji,jk) * zdum * a_i_1d(ji) * r1_Dt_ice ! Heat flux of snw that sublimates [W.m-2], < 0 237 wfx_snw_sub_1d(ji) = wfx_snw_sub_1d(ji) - rhos * zdum * a_i_1d(ji) * r1_Dt_ice ! Mass flux by sublimation 238 239 ! update thickness 240 h_s_1d(ji) = MAX( 0._wp , h_s_1d(ji) + zdum ) 241 zh_s (ji,jk) = MAX( 0._wp , zh_s (ji,jk) + zdum ) 242 !!$ IF( zh_s(ji,jk) == 0._wp ) ze_s(ji,jk) = 0._wp 243 244 ! update sublimation left 245 zdeltah(ji) = MIN( zdeltah(ji) - zdum, 0._wp ) 246 END DO 247 END DO 248 249 ! 301 250 ! ! ============ ! 302 251 ! ! Ice ! … … 305 254 ! Surface ice melting 306 255 !-------------------- 307 zdeltah(1:npti,:) = 0._wp ! important308 256 DO jk = 1, nlay_i 309 257 DO ji = 1, npti … … 313 261 314 262 zEi = - e_i_1d(ji,jk) * r1_rhoi ! Specific enthalpy of layer k [J/kg, <0] 315 zdE = 0._wp ! Specific enthalpy difference (J/kg, <0) 316 ! set up at 0 since no energy is needed to melt water...(it is already melted) 317 zdeltah(ji,jk) = MIN( 0._wp , - zh_i(ji,jk) ) ! internal melting occurs when the internal temperature is above freezing 318 ! this should normally not happen, but sometimes, heat diffusion leads to this 319 zfmdt = - zdeltah(ji,jk) * rhoi ! Mass flux x time step > 0 320 321 dh_i_itm(ji) = dh_i_itm(ji) + zdeltah(ji,jk) ! Cumulate internal melting 322 323 zfmdt = - rhoi * zdeltah(ji,jk) ! Recompute mass flux [kg/m2, >0] 324 325 hfx_res_1d(ji) = hfx_res_1d(ji) + zfmdt * a_i_1d(ji) * zEi * r1_Dt_ice ! Heat flux to the ocean [W.m-2], <0 326 ! ice enthalpy zEi is "sent" to the ocean 327 sfx_res_1d(ji) = sfx_res_1d(ji) - rhoi * a_i_1d(ji) * zdeltah(ji,jk) * s_i_1d(ji) * r1_Dt_ice ! Salt flux 328 ! using s_i_1d and not sz_i_1d(jk) is ok 329 wfx_res_1d(ji) = wfx_res_1d(ji) - rhoi * a_i_1d(ji) * zdeltah(ji,jk) * r1_Dt_ice ! Mass flux 330 263 zdE = 0._wp ! Specific enthalpy difference (J/kg, <0) 264 ! set up at 0 since no energy is needed to melt water...(it is already melted) 265 zdum = MIN( 0._wp , - zh_i(ji,jk) ) ! internal melting occurs when the internal temperature is above freezing 266 ! this should normally not happen, but sometimes, heat diffusion leads to this 267 zfmdt = - zdum * rhoi ! Recompute mass flux [kg/m2, >0] 268 ! 269 dh_i_itm(ji) = dh_i_itm(ji) + zdum ! Cumulate internal melting 270 ! 271 hfx_res_1d(ji) = hfx_res_1d(ji) + zEi * zfmdt * a_i_1d(ji) * r1_Dt_ice ! Heat flux to the ocean [W.m-2], <0 272 ! ice enthalpy zEi is "sent" to the ocean 273 wfx_res_1d(ji) = wfx_res_1d(ji) - rhoi * zdum * a_i_1d(ji) * r1_Dt_ice ! Mass flux 274 sfx_res_1d(ji) = sfx_res_1d(ji) - rhoi * zdum * s_i_1d(ji) * a_i_1d(ji) * r1_Dt_ice ! Salt flux 275 ! using s_i_1d and not sz_i_1d(jk) is ok 331 276 ELSE !-- Surface melting 332 277 … … 337 282 zfmdt = - zq_top(ji) / zdE ! Mass flux to the ocean [kg/m2, >0] 338 283 339 zd eltah(ji,jk)= - zfmdt * r1_rhoi ! Melt of layer jk [m, <0]340 341 zd eltah(ji,jk) = MIN( 0._wp , MAX( zdeltah(ji,jk), - zh_i(ji,jk) ) ) ! Melt of layer jk cannot exceed the layer thickness [m, <0]342 343 zq_top(ji) = MAX( 0._wp , zq_top(ji) - zdeltah(ji,jk)* rhoi * zdE ) ! update available heat344 345 dh_i_sum(ji) = dh_i_sum(ji) + zd eltah(ji,jk)! Cumulate surface melt346 347 zfmdt = - rhoi * zd eltah(ji,jk)! Recompute mass flux [kg/m2, >0]284 zdum = - zfmdt * r1_rhoi ! Melt of layer jk [m, <0] 285 286 zdum = MIN( 0._wp , MAX( zdum , - zh_i(ji,jk) ) ) ! Melt of layer jk cannot exceed the layer thickness [m, <0] 287 288 zq_top(ji) = MAX( 0._wp , zq_top(ji) - zdum * rhoi * zdE ) ! update available heat 289 290 dh_i_sum(ji) = dh_i_sum(ji) + zdum ! Cumulate surface melt 291 292 zfmdt = - rhoi * zdum ! Recompute mass flux [kg/m2, >0] 348 293 349 294 zQm = zfmdt * zEw ! Energy of the melt water sent to the ocean [J/m2, <0] 350 295 351 sfx_sum_1d(ji) = sfx_sum_1d(ji) - rhoi * a_i_1d(ji) * zdeltah(ji,jk) * s_i_1d(ji) * r1_Dt_ice ! Salt flux >0 352 ! using s_i_1d and not sz_i_1d(jk) is ok) 353 hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_Dt_ice ! Heat flux [W.m-2], < 0 354 hfx_sum_1d(ji) = hfx_sum_1d(ji) - zfmdt * a_i_1d(ji) * zdE * r1_Dt_ice ! Heat flux used in this process [W.m-2], > 0 355 ! 356 wfx_sum_1d(ji) = wfx_sum_1d(ji) - rhoi * a_i_1d(ji) * zdeltah(ji,jk) * r1_Dt_ice ! Mass flux 357 296 hfx_thd_1d(ji) = hfx_thd_1d(ji) + zEw * zfmdt * a_i_1d(ji) * r1_Dt_ice ! Heat flux [W.m-2], < 0 297 hfx_sum_1d(ji) = hfx_sum_1d(ji) - zdE * zfmdt * a_i_1d(ji) * r1_Dt_ice ! Heat flux used in this process [W.m-2], > 0 298 wfx_sum_1d(ji) = wfx_sum_1d(ji) - rhoi * zdum * a_i_1d(ji) * r1_Dt_ice ! Mass flux 299 sfx_sum_1d(ji) = sfx_sum_1d(ji) - rhoi * zdum * s_i_1d(ji) * a_i_1d(ji) * r1_Dt_ice ! Salt flux >0 300 ! using s_i_1d and not sz_i_1d(jk) is ok) 358 301 END IF 359 302 ! update thickness 303 zh_i(ji,jk) = MAX( 0._wp, zh_i(ji,jk) + zdum ) 304 h_i_1d(ji) = MAX( 0._wp, h_i_1d(ji) + zdum ) 305 ! 306 ! update heat content (J.m-2) and layer thickness 307 eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdum * e_i_1d(ji,jk) 308 h_i_old (ji,jk) = h_i_old (ji,jk) + zdum 309 ! 310 ! 360 311 ! Ice sublimation 361 312 ! --------------- 362 zdum = MAX( - ( zh_i(ji,jk) + zdeltah(ji,jk) ) , - zevap_rema(ji) * r1_rhoi ) 363 zdeltah (ji,jk) = zdeltah (ji,jk) + zdum 364 dh_i_sub(ji) = dh_i_sub(ji) + zdum 365 366 sfx_sub_1d(ji) = sfx_sub_1d(ji) - rhoi * a_i_1d(ji) * zdum * s_i_1d(ji) * r1_Dt_ice ! Salt flux >0 367 ! clem: flux is sent to the ocean for simplicity 368 ! but salt should remain in the ice except 369 ! if all ice is melted. => must be corrected 370 hfx_sub_1d(ji) = hfx_sub_1d(ji) + zdum * e_i_1d(ji,jk) * a_i_1d(ji) * r1_Dt_ice ! Heat flux [W.m-2], < 0 371 372 wfx_ice_sub_1d(ji) = wfx_ice_sub_1d(ji) - rhoi * a_i_1d(ji) * zdum * r1_Dt_ice ! Mass flux > 0 373 374 ! update remaining mass flux 375 zevap_rema(ji) = zevap_rema(ji) + zdum * rhoi 376 313 zdum = MAX( - zh_i(ji,jk) , - zevap_rema(ji) * r1_rhoi ) 314 ! 315 hfx_sub_1d(ji) = hfx_sub_1d(ji) + e_i_1d(ji,jk) * zdum * a_i_1d(ji) * r1_Dt_ice ! Heat flux [W.m-2], < 0 316 wfx_ice_sub_1d(ji) = wfx_ice_sub_1d(ji) - rhoi * zdum * a_i_1d(ji) * r1_Dt_ice ! Mass flux > 0 317 sfx_sub_1d(ji) = sfx_sub_1d(ji) - rhoi * zdum * s_i_1d(ji) * a_i_1d(ji) * r1_Dt_ice ! Salt flux >0 318 ! clem: flux is sent to the ocean for simplicity 319 ! but salt should remain in the ice except 320 ! if all ice is melted. => must be corrected 321 ! update remaining mass flux and thickness 322 zevap_rema(ji) = zevap_rema(ji) + zdum * rhoi 323 zh_i(ji,jk) = MAX( 0._wp, zh_i(ji,jk) + zdum ) 324 h_i_1d(ji) = MAX( 0._wp, h_i_1d(ji) + zdum ) 325 dh_i_sub(ji) = dh_i_sub(ji) + zdum 326 327 ! update heat content (J.m-2) and layer thickness 328 eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdum * e_i_1d(ji,jk) 329 h_i_old (ji,jk) = h_i_old (ji,jk) + zdum 330 377 331 ! record which layers have disappeared (for bottom melting) 378 332 ! => icount=0 : no layer has vanished 379 333 ! => icount=5 : 5 layers have vanished 380 rswitch = MAX( 0._wp , SIGN( 1._wp , - ( zh_i(ji,jk) + zdeltah(ji,jk)) ) )334 rswitch = MAX( 0._wp , SIGN( 1._wp , - zh_i(ji,jk) ) ) 381 335 icount(ji,jk) = NINT( rswitch ) 382 zh_i(ji,jk) = MAX( 0._wp , zh_i(ji,jk) + zdeltah(ji,jk) )383 336 384 ! update heat content (J.m-2) and layer thickness 385 eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdeltah(ji,jk) * e_i_1d(ji,jk) 386 h_i_old (ji,jk) = h_i_old (ji,jk) + zdeltah(ji,jk) 387 END DO 388 END DO 389 390 ! update ice thickness 391 DO ji = 1, npti 392 h_i_1d(ji) = MAX( 0._wp , h_i_1d(ji) + dh_i_sum(ji) + dh_i_itm(ji) + dh_i_sub(ji) ) 393 END DO 394 337 END DO 338 END DO 339 395 340 ! remaining "potential" evap is sent to ocean 396 341 DO ji = 1, npti … … 430 375 & + zswi2 * 0.26 / ( 0.26 + 0.74 * EXP ( - 724300.0 * zgrr ) ) , 0.5 ) 431 376 432 s_i_new(ji) = zswitch_sal * zfracs * sss_1d(ji) + ( 1. - zswitch_sal ) * s_i_1d(ji) ! New ice salinity433 434 ztmelts = - rTmlt * s_i_new(ji) ! New ice melting point (C)435 436 zt_i_new = zswitch_sal * t_bo_1d(ji) + ( 1. - zswitch_sal) * t_i_1d(ji, nlay_i)437 438 zEi = rcpi * ( zt_i_new - (ztmelts+rt0) ) & ! Specific enthalpy of forming ice (J/kg, <0)439 & - rLfus * ( 1.0 - ztmelts / ( MIN( zt_i_new - rt0, -epsi10 ) ) ) + rcp* ztmelts440 441 zEw = rcp * ( t_bo_1d(ji) - rt0 ) ! Specific enthalpy of seawater (J/kg, < 0)442 443 zdE = zEi - zEw ! Specific enthalpy difference (J/kg, <0)444 445 dh_i_bog(ji) = rDt_ice * MAX( 0._wp , zf_tt(ji) / ( zdE * rhoi ) )377 s_i_new(ji) = zswitch_sal * zfracs * sss_1d(ji) + ( 1. - zswitch_sal ) * s_i_1d(ji) ! New ice salinity 378 379 ztmelts = - rTmlt * s_i_new(ji) ! New ice melting point (C) 380 381 zt_i_new = zswitch_sal * t_bo_1d(ji) + ( 1. - zswitch_sal) * t_i_1d(ji, nlay_i) 382 383 zEi = rcpi * ( zt_i_new - (ztmelts+rt0) ) & ! Specific enthalpy of forming ice (J/kg, <0) 384 & - rLfus * ( 1.0 - ztmelts / ( MIN( zt_i_new - rt0, -epsi10 ) ) ) + rcp * ztmelts 385 386 zEw = rcp * ( t_bo_1d(ji) - rt0 ) ! Specific enthalpy of seawater (J/kg, < 0) 387 388 zdE = zEi - zEw ! Specific enthalpy difference (J/kg, <0) 389 390 dh_i_bog(ji) = rDt_ice * MAX( 0._wp , zf_tt(ji) / ( zdE * rhoi ) ) 446 391 447 392 END DO 448 393 ! Contribution to Energy and Salt Fluxes 449 zfmdt = - rhoi * dh_i_bog(ji)! Mass flux x time step (kg/m2, < 0)394 zfmdt = - rhoi * dh_i_bog(ji) ! Mass flux x time step (kg/m2, < 0) 450 395 451 hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_Dt_ice ! Heat flux to the ocean [W.m-2], >0 452 hfx_bog_1d(ji) = hfx_bog_1d(ji) - zfmdt * a_i_1d(ji) * zdE * r1_Dt_ice ! Heat flux used in this process [W.m-2], <0 453 454 sfx_bog_1d(ji) = sfx_bog_1d(ji) - rhoi * a_i_1d(ji) * dh_i_bog(ji) * s_i_new(ji) * r1_Dt_ice ! Salt flux, <0 455 456 wfx_bog_1d(ji) = wfx_bog_1d(ji) - rhoi * a_i_1d(ji) * dh_i_bog(ji) * r1_Dt_ice ! Mass flux, <0 396 hfx_thd_1d(ji) = hfx_thd_1d(ji) + zEw * zfmdt * a_i_1d(ji) * r1_Dt_ice ! Heat flux to the ocean [W.m-2], >0 397 hfx_bog_1d(ji) = hfx_bog_1d(ji) - zdE * zfmdt * a_i_1d(ji) * r1_Dt_ice ! Heat flux used in this process [W.m-2], <0 398 wfx_bog_1d(ji) = wfx_bog_1d(ji) - rhoi * dh_i_bog(ji) * a_i_1d(ji) * r1_Dt_ice ! Mass flux, <0 399 sfx_bog_1d(ji) = sfx_bog_1d(ji) - rhoi * dh_i_bog(ji) * s_i_new(ji) * a_i_1d(ji) * r1_Dt_ice ! Salt flux, <0 400 401 ! update thickness 402 zh_i(ji,nlay_i+1) = zh_i(ji,nlay_i+1) + dh_i_bog(ji) 403 h_i_1d(ji) = h_i_1d(ji) + dh_i_bog(ji) 457 404 458 405 ! update heat content (J.m-2) and layer thickness … … 466 413 ! Ice Basal melt 467 414 !--------------- 468 zdeltah(1:npti,:) = 0._wp ! important469 415 DO jk = nlay_i, 1, -1 470 416 DO ji = 1, npti … … 475 421 IF( t_i_1d(ji,jk) >= (ztmelts+rt0) ) THEN !-- Internal melting 476 422 477 zEi = - e_i_1d(ji,jk) * r1_rhoi ! Specific enthalpy of melting ice (J/kg, <0) 478 zdE = 0._wp ! Specific enthalpy difference (J/kg, <0) 479 ! set up at 0 since no energy is needed to melt water...(it is already melted) 480 zdeltah (ji,jk) = MIN( 0._wp , - zh_i(ji,jk) ) ! internal melting occurs when the internal temperature is above freezing 481 ! this should normally not happen, but sometimes, heat diffusion leads to this 482 483 dh_i_itm (ji) = dh_i_itm(ji) + zdeltah(ji,jk) 484 485 zfmdt = - zdeltah(ji,jk) * rhoi ! Mass flux x time step > 0 486 487 hfx_res_1d(ji) = hfx_res_1d(ji) + zfmdt * a_i_1d(ji) * zEi * r1_Dt_ice ! Heat flux to the ocean [W.m-2], <0 488 ! ice enthalpy zEi is "sent" to the ocean 489 sfx_res_1d(ji) = sfx_res_1d(ji) - rhoi * a_i_1d(ji) * zdeltah(ji,jk) * s_i_1d(ji) * r1_Dt_ice ! Salt flux 490 ! using s_i_1d and not sz_i_1d(jk) is ok 491 wfx_res_1d(ji) = wfx_res_1d(ji) - rhoi * a_i_1d(ji) * zdeltah(ji,jk) * r1_Dt_ice ! Mass flux 492 493 ! update heat content (J.m-2) and layer thickness 494 eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdeltah(ji,jk) * e_i_1d(ji,jk) 495 h_i_old (ji,jk) = h_i_old (ji,jk) + zdeltah(ji,jk) 496 423 zEi = - e_i_1d(ji,jk) * r1_rhoi ! Specific enthalpy of melting ice (J/kg, <0) 424 zdE = 0._wp ! Specific enthalpy difference (J/kg, <0) 425 ! set up at 0 since no energy is needed to melt water...(it is already melted) 426 zdum = MIN( 0._wp , - zh_i(ji,jk) ) ! internal melting occurs when the internal temperature is above freezing 427 ! this should normally not happen, but sometimes, heat diffusion leads to this 428 dh_i_itm (ji) = dh_i_itm(ji) + zdum 429 ! 430 zfmdt = - zdum * rhoi ! Mass flux x time step > 0 431 ! 432 hfx_res_1d(ji) = hfx_res_1d(ji) + zEi * zfmdt * a_i_1d(ji) * r1_Dt_ice ! Heat flux to the ocean [W.m-2], <0 433 ! ice enthalpy zEi is "sent" to the ocean 434 wfx_res_1d(ji) = wfx_res_1d(ji) - rhoi * zdum * a_i_1d(ji) * r1_Dt_ice ! Mass flux 435 sfx_res_1d(ji) = sfx_res_1d(ji) - rhoi * zdum * s_i_1d(ji) * a_i_1d(ji) * r1_Dt_ice ! Salt flux 436 ! using s_i_1d and not sz_i_1d(jk) is ok 497 437 ELSE !-- Basal melting 498 438 499 zEi = - e_i_1d(ji,jk) * r1_rhoi! Specific enthalpy of melting ice (J/kg, <0)500 zEw = rcp * ztmelts! Specific enthalpy of meltwater (J/kg, <0)501 zdE = zEi - zEw! Specific enthalpy difference (J/kg, <0)502 503 zfmdt = - zq_bot(ji) / zdE! Mass flux x time step (kg/m2, >0)504 505 zd eltah(ji,jk) = - zfmdt * r1_rhoi! Gross thickness change506 507 zd eltah(ji,jk) = MIN( 0._wp , MAX( zdeltah(ji,jk), - zh_i(ji,jk) ) ) ! bound thickness change439 zEi = - e_i_1d(ji,jk) * r1_rhoi ! Specific enthalpy of melting ice (J/kg, <0) 440 zEw = rcp * ztmelts ! Specific enthalpy of meltwater (J/kg, <0) 441 zdE = zEi - zEw ! Specific enthalpy difference (J/kg, <0) 442 443 zfmdt = - zq_bot(ji) / zdE ! Mass flux x time step (kg/m2, >0) 444 445 zdum = - zfmdt * r1_rhoi ! Gross thickness change 446 447 zdum = MIN( 0._wp , MAX( zdum, - zh_i(ji,jk) ) ) ! bound thickness change 508 448 509 zq_bot(ji) = MAX( 0._wp , zq_bot(ji) - zdeltah(ji,jk) * rhoi * zdE ) ! update available heat. MAX is necessary for roundup errors 510 511 dh_i_bom(ji) = dh_i_bom(ji) + zdeltah(ji,jk) ! Update basal melt 512 513 zfmdt = - zdeltah(ji,jk) * rhoi ! Mass flux x time step > 0 514 515 zQm = zfmdt * zEw ! Heat exchanged with ocean 516 517 hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_Dt_ice ! Heat flux to the ocean [W.m-2], <0 518 hfx_bom_1d(ji) = hfx_bom_1d(ji) - zfmdt * a_i_1d(ji) * zdE * r1_Dt_ice ! Heat used in this process [W.m-2], >0 519 520 sfx_bom_1d(ji) = sfx_bom_1d(ji) - rhoi * a_i_1d(ji) * zdeltah(ji,jk) * s_i_1d(ji) * r1_Dt_ice ! Salt flux 521 ! using s_i_1d and not sz_i_1d(jk) is ok 522 523 wfx_bom_1d(ji) = wfx_bom_1d(ji) - rhoi * a_i_1d(ji) * zdeltah(ji,jk) * r1_Dt_ice ! Mass flux 524 525 ! update heat content (J.m-2) and layer thickness 526 eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdeltah(ji,jk) * e_i_1d(ji,jk) 527 h_i_old (ji,jk) = h_i_old (ji,jk) + zdeltah(ji,jk) 449 zq_bot(ji) = MAX( 0._wp , zq_bot(ji) - zdum * rhoi * zdE ) ! update available heat. MAX is necessary for roundup errors 450 451 dh_i_bom(ji) = dh_i_bom(ji) + zdum ! Update basal melt 452 453 zfmdt = - zdum * rhoi ! Mass flux x time step > 0 454 455 zQm = zfmdt * zEw ! Heat exchanged with ocean 456 457 hfx_thd_1d(ji) = hfx_thd_1d(ji) + zEw * zfmdt * a_i_1d(ji) * r1_Dt_ice ! Heat flux to the ocean [W.m-2], <0 458 hfx_bom_1d(ji) = hfx_bom_1d(ji) - zdE * zfmdt * a_i_1d(ji) * r1_Dt_ice ! Heat used in this process [W.m-2], >0 459 wfx_bom_1d(ji) = wfx_bom_1d(ji) - rhoi * zdum * a_i_1d(ji) * r1_Dt_ice ! Mass flux 460 sfx_bom_1d(ji) = sfx_bom_1d(ji) - rhoi * zdum * s_i_1d(ji) * a_i_1d(ji) * r1_Dt_ice ! Salt flux 461 ! using s_i_1d and not sz_i_1d(jk) is ok 528 462 ENDIF 529 463 ! update thickness 464 zh_i(ji,jk) = MAX( 0._wp, zh_i(ji,jk) + zdum ) 465 h_i_1d(ji) = MAX( 0._wp, h_i_1d(ji) + zdum ) 466 ! 467 ! update heat content (J.m-2) and layer thickness 468 eh_i_old(ji,jk) = eh_i_old(ji,jk) + zdum * e_i_1d(ji,jk) 469 h_i_old (ji,jk) = h_i_old (ji,jk) + zdum 530 470 ENDIF 531 471 END DO 532 472 END DO 533 473 534 ! Update temperature, energy 535 ! -------------------------- 536 DO ji = 1, npti 537 h_i_1d(ji) = MAX( 0._wp , h_i_1d(ji) + dh_i_bog(ji) + dh_i_bom(ji) ) 538 END DO 539 540 ! If heat still available then melt more snow 541 !------------------------------------------- 542 zdeltah(1:npti,:) = 0._wp ! important 543 DO ji = 1, npti 544 zq_rema (ji) = zq_top(ji) + zq_bot(ji) 545 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp, - h_s_1d(ji) ) ) ! =1 if snow 546 rswitch = rswitch * MAX( 0._wp, SIGN( 1._wp, e_s_1d(ji,1) - epsi20 ) ) 547 zdeltah (ji,1) = - rswitch * zq_rema(ji) / MAX( e_s_1d(ji,1), epsi20 ) 548 zdeltah (ji,1) = MIN( 0._wp , MAX( zdeltah(ji,1) , - h_s_1d(ji) ) ) ! bound melting 549 dh_s_tot(ji) = dh_s_tot(ji) + zdeltah(ji,1) 550 h_s_1d (ji) = h_s_1d (ji) + zdeltah(ji,1) 551 552 zq_rema(ji) = zq_rema(ji) + zdeltah(ji,1) * e_s_1d(ji,1) ! update available heat (J.m-2) 553 hfx_snw_1d(ji) = hfx_snw_1d(ji) - zdeltah(ji,1) * a_i_1d(ji) * e_s_1d(ji,1) * r1_Dt_ice ! Heat used to melt snow, W.m-2 (>0) 554 wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) - rhos * a_i_1d(ji) * zdeltah(ji,1) * r1_Dt_ice ! Mass flux 555 dh_s_mlt(ji) = dh_s_mlt(ji) + zdeltah(ji,1) 556 ! 557 ! Remaining heat flux (W.m-2) is sent to the ocean heat budget 558 !!hfx_res_1d(ji) = hfx_res_1d(ji) + ( zq_rema(ji) * a_i_1d(ji) ) * r1_Dt_ice 559 560 IF( ln_icectl .AND. zq_rema(ji) < 0. .AND. lwp ) WRITE(numout,*) 'ALERTE zq_rema <0 = ', zq_rema(ji) 561 END DO 562 563 ! 474 ! Remove snow if ice has melted entirely 475 ! -------------------------------------- 476 DO jk = 0, nlay_s 477 DO ji = 1,npti 478 IF( h_i_1d(ji) == 0._wp ) THEN 479 ! mass & energy loss to the ocean 480 hfx_res_1d(ji) = hfx_res_1d(ji) - ze_s(ji,jk) * zh_s(ji,jk) * a_i_1d(ji) * r1_Dt_ice ! heat flux to the ocean [W.m-2], < 0 481 wfx_res_1d(ji) = wfx_res_1d(ji) + rhos * zh_s(ji,jk) * a_i_1d(ji) * r1_Dt_ice ! mass flux 482 483 ! update thickness and energy 484 h_s_1d(ji) = 0._wp 485 ze_s (ji,jk) = 0._wp 486 zh_s (ji,jk) = 0._wp 487 ENDIF 488 END DO 489 END DO 490 491 ! Snow load on ice 492 ! ----------------- 493 ! When snow load exceeds Archimede's limit and sst is positive, 494 ! snow-ice formation (next bloc) can lead to negative ice enthalpy. 495 ! Therefore we consider here that this excess of snow falls into the ocean 496 zdeltah(1:npti) = h_s_1d(1:npti) + h_i_1d(1:npti) * (rhoi-rho0) * r1_rhos 497 DO jk = 0, nlay_s 498 DO ji = 1, npti 499 IF( zdeltah(ji) > 0._wp .AND. sst_1d(ji) > 0._wp ) THEN 500 ! snow layer thickness that falls into the ocean 501 zdum = MIN( zdeltah(ji) , zh_s(ji,jk) ) 502 ! mass & energy loss to the ocean 503 hfx_res_1d(ji) = hfx_res_1d(ji) - ze_s(ji,jk) * zdum * a_i_1d(ji) * r1_Dt_ice ! heat flux to the ocean [W.m-2], < 0 504 wfx_res_1d(ji) = wfx_res_1d(ji) + rhos * zdum * a_i_1d(ji) * r1_Dt_ice ! mass flux 505 ! update thickness and energy 506 h_s_1d(ji) = MAX( 0._wp, h_s_1d(ji) - zdum ) 507 zh_s (ji,jk) = MAX( 0._wp, zh_s(ji,jk) - zdum ) 508 ! update snow thickness that still has to fall 509 zdeltah(ji) = MAX( 0._wp, zdeltah(ji) - zdum ) 510 ENDIF 511 END DO 512 END DO 513 564 514 ! Snow-Ice formation 565 515 ! ------------------ 566 ! When snow load exce sses Archimede's limit, snow-ice interface goes down under sea-level,567 ! flooding of seawater transforms snow into ice dh_snowice is positive for the ice516 ! When snow load exceeds Archimede's limit, snow-ice interface goes down under sea-level, 517 ! flooding of seawater transforms snow into ice. Thickness that is transformed is dh_snowice (positive for the ice) 568 518 z1_rho = 1._wp / ( rhos+rho0-rhoi ) 519 zdeltah(1:npti) = 0._wp 569 520 DO ji = 1, npti 570 521 ! 571 dh_snowice(ji) = MAX( 522 dh_snowice(ji) = MAX( 0._wp , ( rhos * h_s_1d(ji) + (rhoi-rho0) * h_i_1d(ji) ) * z1_rho ) 572 523 573 524 h_i_1d(ji) = h_i_1d(ji) + dh_snowice(ji) … … 579 530 zQm = zfmdt * zEw 580 531 581 hfx_thd_1d(ji) = hfx_thd_1d(ji) + zfmdt * a_i_1d(ji) * zEw * r1_Dt_ice ! Heat flux 582 583 sfx_sni_1d(ji) = sfx_sni_1d(ji) + sss_1d(ji) * a_i_1d(ji) * zfmdt * r1_Dt_ice ! Salt flux 532 hfx_thd_1d(ji) = hfx_thd_1d(ji) + zEw * zfmdt * a_i_1d(ji) * r1_Dt_ice ! Heat flux 533 sfx_sni_1d(ji) = sfx_sni_1d(ji) + sss_1d(ji) * zfmdt * a_i_1d(ji) * r1_Dt_ice ! Salt flux 584 534 585 535 ! Case constant salinity in time: virtual salt flux to keep salinity constant 586 536 IF( nn_icesal /= 2 ) THEN 587 sfx_bri_1d(ji) = sfx_bri_1d(ji) - sss_1d (ji) * a_i_1d(ji) * zfmdt * r1_Dt_ice &! put back sss_m into the ocean588 & - s_i_1d(ji) * a_i_1d(ji) * dh_snowice(ji) * rhoi* r1_Dt_ice ! and get rn_icesal from the ocean537 sfx_bri_1d(ji) = sfx_bri_1d(ji) - sss_1d(ji) * zfmdt * a_i_1d(ji) * r1_Dt_ice & ! put back sss_m into the ocean 538 & - s_i_1d(ji) * dh_snowice(ji) * rhoi * a_i_1d(ji) * r1_Dt_ice ! and get rn_icesal from the ocean 589 539 ENDIF 590 540 591 541 ! Mass flux: All snow is thrown in the ocean, and seawater is taken to replace the volume 592 wfx_sni_1d(ji) = wfx_sni_1d(ji) - a_i_1d(ji) * dh_snowice(ji) * rhoi * r1_Dt_ice 593 wfx_snw_sni_1d(ji) = wfx_snw_sni_1d(ji) + a_i_1d(ji) * dh_snowice(ji) * rhos * r1_Dt_ice 542 wfx_sni_1d (ji) = wfx_sni_1d (ji) - dh_snowice(ji) * rhoi * a_i_1d(ji) * r1_Dt_ice 543 wfx_snw_sni_1d(ji) = wfx_snw_sni_1d(ji) + dh_snowice(ji) * rhos * a_i_1d(ji) * r1_Dt_ice 544 545 ! update thickness 546 zh_i(ji,0) = zh_i(ji,0) + dh_snowice(ji) 547 zdeltah(ji) = dh_snowice(ji) 594 548 595 549 ! update heat content (J.m-2) and layer thickness 596 eh_i_old(ji,0) = eh_i_old(ji,0) + dh_snowice(ji) * e_s_1d(ji,1) + zfmdt * zEw597 550 h_i_old (ji,0) = h_i_old (ji,0) + dh_snowice(ji) 598 599 END DO 600 601 ! 602 ! Update temperature, energy 603 ! -------------------------- 604 DO ji = 1, npti 605 rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - h_i_1d(ji) ) ) 606 t_su_1d(ji) = rswitch * t_su_1d(ji) + ( 1._wp - rswitch ) * rt0 607 END DO 608 551 eh_i_old(ji,0) = eh_i_old(ji,0) + zfmdt * zEw ! 1st part (sea water enthalpy) 552 553 END DO 554 ! 555 DO jk = nlay_s, 0, -1 ! flooding of snow starts from the base 556 DO ji = 1, npti 557 zdum = MIN( zdeltah(ji), zh_s(ji,jk) ) ! amount of snw that floods, > 0 558 zh_s(ji,jk) = MAX( 0._wp, zh_s(ji,jk) - zdum ) ! remove some snow thickness 559 eh_i_old(ji,0) = eh_i_old(ji,0) + zdum * ze_s(ji,jk) ! 2nd part (snow enthalpy) 560 ! update dh_snowice 561 zdeltah(ji) = MAX( 0._wp, zdeltah(ji) - zdum ) 562 END DO 563 END DO 564 ! 565 ! 566 !!$ ! --- Update snow diags --- ! 567 !!$ !!clem: this is wrong. dh_s_tot is not used anyway 568 !!$ DO ji = 1, npti 569 !!$ dh_s_tot(ji) = dh_s_tot(ji) + dh_s_mlt(ji) + zdeltah(ji) + zdh_s_sub(ji) - dh_snowice(ji) 570 !!$ END DO 571 ! 572 ! 573 ! Remapping of snw enthalpy on a regular grid 574 !-------------------------------------------- 575 CALL snw_ent( zh_s, ze_s, e_s_1d ) 576 577 ! recalculate t_s_1d from e_s_1d 609 578 DO jk = 1, nlay_s 610 579 DO ji = 1,npti 611 ! where there is no ice or no snow 612 rswitch = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, - h_s_1d(ji) ) ) ) * ( 1._wp - MAX( 0._wp, SIGN(1._wp, - h_i_1d(ji) ) ) ) 613 ! mass & energy loss to the ocean 614 hfx_res_1d(ji) = hfx_res_1d(ji) + ( 1._wp - rswitch ) * & 615 & ( e_s_1d(ji,jk) * h_s_1d(ji) * r1_nlay_s * a_i_1d(ji) * r1_Dt_ice ) ! heat flux to the ocean [W.m-2], < 0 616 wfx_res_1d(ji) = wfx_res_1d(ji) + ( 1._wp - rswitch ) * & 617 & ( rhos * h_s_1d(ji) * r1_nlay_s * a_i_1d(ji) * r1_Dt_ice ) ! mass flux 618 ! update energy (mass is updated in the next loop) 619 e_s_1d(ji,jk) = rswitch * e_s_1d(ji,jk) 620 ! recalculate t_s_1d from e_s_1d 621 t_s_1d(ji,jk) = rt0 + rswitch * ( - e_s_1d(ji,jk) * r1_rhos * r1_rcpi + rLfus * r1_rcpi ) 622 END DO 623 END DO 580 IF( h_s_1d(ji) > 0._wp ) THEN 581 t_s_1d(ji,jk) = rt0 + ( - e_s_1d(ji,jk) * r1_rhos * r1_rcpi + rLfus * r1_rcpi ) 582 ELSE 583 t_s_1d(ji,jk) = rt0 584 ENDIF 585 END DO 586 END DO 587 588 ! Note: remapping of ice enthalpy is done in icethd.F90 624 589 625 590 ! --- ensure that a_i = 0 & h_s = 0 where h_i = 0 --- 626 591 WHERE( h_i_1d(1:npti) == 0._wp ) 627 a_i_1d(1:npti) = 0._wp 628 h_s_1d(1:npti) = 0._wp 592 a_i_1d (1:npti) = 0._wp 593 h_s_1d (1:npti) = 0._wp 594 t_su_1d(1:npti) = rt0 629 595 END WHERE 630 !596 631 597 END SUBROUTINE ice_thd_dh 632 598 599 SUBROUTINE snw_ent( ph_old, pe_old, pe_new ) 600 !!------------------------------------------------------------------- 601 !! *** ROUTINE snw_ent *** 602 !! 603 !! ** Purpose : 604 !! This routine computes new vertical grids in the snow, 605 !! and consistently redistributes temperatures. 606 !! Redistribution is made so as to ensure to energy conservation 607 !! 608 !! 609 !! ** Method : linear conservative remapping 610 !! 611 !! ** Steps : 1) cumulative integrals of old enthalpies/thicknesses 612 !! 2) linear remapping on the new layers 613 !! 614 !! ------------ cum0(0) ------------- cum1(0) 615 !! NEW ------------- 616 !! ------------ cum0(1) ==> ------------- 617 !! ... ------------- 618 !! ------------ ------------- 619 !! ------------ cum0(nlay_s+1) ------------- cum1(nlay_s) 620 !! 621 !! 622 !! References : Bitz & Lipscomb, JGR 99; Vancoppenolle et al., GRL, 2005 623 !!------------------------------------------------------------------- 624 REAL(wp), DIMENSION(jpij,0:nlay_s), INTENT(in ) :: ph_old ! old thicknesses (m) 625 REAL(wp), DIMENSION(jpij,0:nlay_s), INTENT(in ) :: pe_old ! old enthlapies (J.m-3) 626 REAL(wp), DIMENSION(jpij,1:nlay_s), INTENT(inout) :: pe_new ! new enthlapies (J.m-3, remapped) 627 ! 628 INTEGER :: ji ! dummy loop indices 629 INTEGER :: jk0, jk1 ! old/new layer indices 630 ! 631 REAL(wp), DIMENSION(jpij,0:nlay_s+1) :: zeh_cum0, zh_cum0 ! old cumulative enthlapies and layers interfaces 632 REAL(wp), DIMENSION(jpij,0:nlay_s) :: zeh_cum1, zh_cum1 ! new cumulative enthlapies and layers interfaces 633 REAL(wp), DIMENSION(jpij) :: zhnew ! new layers thicknesses 634 !!------------------------------------------------------------------- 635 636 !-------------------------------------------------------------------------- 637 ! 1) Cumulative integral of old enthalpy * thickness and layers interfaces 638 !-------------------------------------------------------------------------- 639 zeh_cum0(1:npti,0) = 0._wp 640 zh_cum0 (1:npti,0) = 0._wp 641 DO jk0 = 1, nlay_s+1 642 DO ji = 1, npti 643 zeh_cum0(ji,jk0) = zeh_cum0(ji,jk0-1) + pe_old(ji,jk0-1) * ph_old(ji,jk0-1) 644 zh_cum0 (ji,jk0) = zh_cum0 (ji,jk0-1) + ph_old(ji,jk0-1) 645 END DO 646 END DO 647 648 !------------------------------------ 649 ! 2) Interpolation on the new layers 650 !------------------------------------ 651 ! new layer thickesses 652 DO ji = 1, npti 653 zhnew(ji) = SUM( ph_old(ji,0:nlay_s) ) * r1_nlay_s 654 END DO 655 656 ! new layers interfaces 657 zh_cum1(1:npti,0) = 0._wp 658 DO jk1 = 1, nlay_s 659 DO ji = 1, npti 660 zh_cum1(ji,jk1) = zh_cum1(ji,jk1-1) + zhnew(ji) 661 END DO 662 END DO 663 664 zeh_cum1(1:npti,0:nlay_s) = 0._wp 665 ! new cumulative q*h => linear interpolation 666 DO jk0 = 1, nlay_s+1 667 DO jk1 = 1, nlay_s-1 668 DO ji = 1, npti 669 IF( zh_cum1(ji,jk1) <= zh_cum0(ji,jk0) .AND. zh_cum1(ji,jk1) > zh_cum0(ji,jk0-1) ) THEN 670 zeh_cum1(ji,jk1) = ( zeh_cum0(ji,jk0-1) * ( zh_cum0(ji,jk0) - zh_cum1(ji,jk1 ) ) + & 671 & zeh_cum0(ji,jk0 ) * ( zh_cum1(ji,jk1) - zh_cum0(ji,jk0-1) ) ) & 672 & / ( zh_cum0(ji,jk0) - zh_cum0(ji,jk0-1) ) 673 ENDIF 674 END DO 675 END DO 676 END DO 677 ! to ensure that total heat content is strictly conserved, set: 678 zeh_cum1(1:npti,nlay_s) = zeh_cum0(1:npti,nlay_s+1) 679 680 ! new enthalpies 681 DO jk1 = 1, nlay_s 682 DO ji = 1, npti 683 rswitch = MAX( 0._wp , SIGN( 1._wp , zhnew(ji) - epsi20 ) ) 684 pe_new(ji,jk1) = rswitch * ( zeh_cum1(ji,jk1) - zeh_cum1(ji,jk1-1) ) / MAX( zhnew(ji), epsi20 ) 685 END DO 686 END DO 687 688 END SUBROUTINE snw_ent 689 690 633 691 #else 634 692 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icethd_pnd.F90
r13472 r14046 20 20 USE ice1D ! sea-ice: thermodynamics variables 21 21 USE icetab ! sea-ice: 1D <==> 2D transformation 22 USE sbc_ice ! surface energy budget 22 23 ! 23 24 USE in_out_manager ! I/O manager 25 USE iom ! I/O manager library 24 26 USE lib_mpp ! MPP library 25 27 USE lib_fortran ! fortran utilities (glob_sum + no signed zero) … … 34 36 INTEGER :: nice_pnd ! choice of the type of pond scheme 35 37 ! ! associated indices: 36 INTEGER, PARAMETER :: np_pndNO = 0 ! No pond scheme 37 INTEGER, PARAMETER :: np_pndCST = 1 ! Constant ice pond scheme 38 INTEGER, PARAMETER :: np_pndLEV = 2 ! Level ice pond scheme 39 38 INTEGER, PARAMETER :: np_pndNO = 0 ! No pond scheme 39 INTEGER, PARAMETER :: np_pndCST = 1 ! Constant ice pond scheme 40 INTEGER, PARAMETER :: np_pndLEV = 2 ! Level ice pond scheme 41 INTEGER, PARAMETER :: np_pndTOPO = 3 ! Level ice pond scheme 42 43 !-------------------------------------------------------------------------- 44 ! Diagnostics for pond volume per area 45 ! 46 ! dV/dt = mlt + drn + lid + rnf 47 ! mlt = input from surface melting 48 ! drn = drainage through brine network 49 ! lid = lid growth & melt 50 ! rnf = runoff (water directly removed out of surface melting + overflow) 51 ! 52 ! In topo mode, the pond water lost because it is in the snow is not included in the budget 53 ! In level mode, all terms are incorporated 54 ! 55 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: diag_dvpn_mlt ! meltwater pond volume input [kg/m2/s] 56 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: diag_dvpn_drn ! pond volume lost by drainage [-] 57 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: diag_dvpn_lid ! exchange with lid / refreezing [-] 58 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: diag_dvpn_rnf ! meltwater pond lost to runoff [-] 59 REAL(wp), ALLOCATABLE, DIMENSION(:) :: diag_dvpn_mlt_1d ! meltwater pond volume input [-] 60 REAL(wp), ALLOCATABLE, DIMENSION(:) :: diag_dvpn_drn_1d ! pond volume lost by drainage [-] 61 REAL(wp), ALLOCATABLE, DIMENSION(:) :: diag_dvpn_lid_1d ! exchange with lid / refreezing [-] 62 REAL(wp), ALLOCATABLE, DIMENSION(:) :: diag_dvpn_rnf_1d ! meltwater pond lost to runoff [-] 63 64 !! * Substitutions 65 # include "do_loop_substitute.h90" 40 66 !!---------------------------------------------------------------------- 41 67 !! NEMO/ICE 4.0 , NEMO Consortium (2018) … … 46 72 47 73 SUBROUTINE ice_thd_pnd 74 48 75 !!------------------------------------------------------------------- 49 76 !! *** ROUTINE ice_thd_pnd *** 50 77 !! 51 78 !! ** Purpose : change melt pond fraction and thickness 52 !! 79 !! 80 !! ** Note : Melt ponds affect only radiative transfer for now 81 !! No heat, no salt. 82 !! The current diagnostics lacks a contribution from drainage 53 83 !!------------------------------------------------------------------- 84 INTEGER :: ji, jj, jl ! loop indices 85 !!------------------------------------------------------------------- 86 87 ALLOCATE( diag_dvpn_mlt(jpi,jpj), diag_dvpn_lid(jpi,jpj), diag_dvpn_drn(jpi,jpj), diag_dvpn_rnf(jpi,jpj) ) 88 ALLOCATE( diag_dvpn_mlt_1d(jpij), diag_dvpn_lid_1d(jpij), diag_dvpn_drn_1d(jpij), diag_dvpn_rnf_1d(jpij) ) 54 89 ! 55 SELECT CASE ( nice_pnd ) 90 diag_dvpn_mlt (:,:) = 0._wp ; diag_dvpn_drn (:,:) = 0._wp 91 diag_dvpn_lid (:,:) = 0._wp ; diag_dvpn_rnf (:,:) = 0._wp 92 diag_dvpn_mlt_1d(:) = 0._wp ; diag_dvpn_drn_1d(:) = 0._wp 93 diag_dvpn_lid_1d(:) = 0._wp ; diag_dvpn_rnf_1d(:) = 0._wp 94 95 !------------------------------------- 96 ! Remove ponds where ice has vanished 97 !------------------------------------- 98 at_i(:,:) = SUM( a_i, dim=3 ) 56 99 ! 57 CASE (np_pndCST) ; CALL pnd_CST !== Constant melt ponds ==! 58 ! 59 CASE (np_pndLEV) ; CALL pnd_LEV !== Level ice melt ponds ==! 60 ! 61 END SELECT 100 DO jl = 1, jpl 101 DO_2D( 1, 1, 1, 1 ) 102 IF( v_i(ji,jj,jl) < epsi10 .OR. at_i(ji,jj) < epsi10 ) THEN 103 wfx_pnd (ji,jj) = wfx_pnd(ji,jj) + ( v_ip(ji,jj,jl) + v_il(ji,jj,jl) ) * rhow * r1_Dt_ice 104 a_ip (ji,jj,jl) = 0._wp 105 v_ip (ji,jj,jl) = 0._wp 106 v_il (ji,jj,jl) = 0._wp 107 h_ip (ji,jj,jl) = 0._wp 108 h_il (ji,jj,jl) = 0._wp 109 a_ip_frac(ji,jj,jl) = 0._wp 110 ENDIF 111 END_2D 112 END DO 113 114 !------------------------------ 115 ! Identify grid cells with ice 116 !------------------------------ 117 npti = 0 ; nptidx(:) = 0 118 DO_2D( 1, 1, 1, 1 ) 119 IF( at_i(ji,jj) >= epsi10 ) THEN 120 npti = npti + 1 121 nptidx( npti ) = (jj - 1) * jpi + ji 122 ENDIF 123 END_2D 124 125 !------------------------------------ 126 ! Select melt pond scheme to be used 127 !------------------------------------ 128 IF( npti > 0 ) THEN 129 SELECT CASE ( nice_pnd ) 130 ! 131 CASE (np_pndCST) ; CALL pnd_CST !== Constant melt ponds ==! 132 ! 133 CASE (np_pndLEV) ; CALL pnd_LEV !== Level ice melt ponds ==! 134 ! 135 CASE (np_pndTOPO) ; CALL pnd_TOPO !== Topographic melt ponds ==! 136 ! 137 END SELECT 138 ENDIF 139 140 !------------------------------------ 141 ! Diagnostics 142 !------------------------------------ 143 CALL iom_put( 'dvpn_mlt', diag_dvpn_mlt ) ! input from melting 144 CALL iom_put( 'dvpn_lid', diag_dvpn_lid ) ! exchanges with lid 145 CALL iom_put( 'dvpn_drn', diag_dvpn_drn ) ! vertical drainage 146 CALL iom_put( 'dvpn_rnf', diag_dvpn_rnf ) ! runoff + overflow 62 147 ! 148 DEALLOCATE( diag_dvpn_mlt , diag_dvpn_lid , diag_dvpn_drn , diag_dvpn_rnf ) 149 DEALLOCATE( diag_dvpn_mlt_1d, diag_dvpn_lid_1d, diag_dvpn_drn_1d, diag_dvpn_rnf_1d ) 150 63 151 END SUBROUTINE ice_thd_pnd 64 152 … … 80 168 !! ** References : Bush, G.W., and Trump, D.J. (2017) 81 169 !!------------------------------------------------------------------- 82 INTEGER :: ji ! loop indices 170 INTEGER :: ji, jl ! loop indices 171 REAL(wp) :: zdv_pnd ! Amount of water going into the ponds & lids 83 172 !!------------------------------------------------------------------- 84 DO ji = 1, npti 85 ! 86 IF( a_i_1d(ji) > 0._wp .AND. t_su_1d(ji) >= rt0 ) THEN 87 h_ip_1d(ji) = rn_hpnd 88 a_ip_1d(ji) = rn_apnd * a_i_1d(ji) 89 h_il_1d(ji) = 0._wp ! no pond lids whatsoever 90 ELSE 91 h_ip_1d(ji) = 0._wp 92 a_ip_1d(ji) = 0._wp 93 h_il_1d(ji) = 0._wp 94 ENDIF 95 ! 173 DO jl = 1, jpl 174 175 CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d (1:npti), a_i (:,:,jl) ) 176 CALL tab_2d_1d( npti, nptidx(1:npti), t_su_1d (1:npti), t_su (:,:,jl) ) 177 CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d (1:npti), a_ip (:,:,jl) ) 178 CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d (1:npti), h_ip (:,:,jl) ) 179 CALL tab_2d_1d( npti, nptidx(1:npti), h_il_1d (1:npti), h_il (:,:,jl) ) 180 CALL tab_2d_1d( npti, nptidx(1:npti), wfx_pnd_1d(1:npti), wfx_pnd(:,:) ) 181 182 DO ji = 1, npti 183 ! 184 zdv_pnd = ( h_ip_1d(ji) + h_il_1d(ji) ) * a_ip_1d(ji) 185 ! 186 IF( a_i_1d(ji) >= 0.01_wp .AND. t_su_1d(ji) >= rt0 ) THEN 187 h_ip_1d(ji) = rn_hpnd 188 a_ip_1d(ji) = rn_apnd * a_i_1d(ji) 189 h_il_1d(ji) = 0._wp ! no pond lids whatsoever 190 ELSE 191 h_ip_1d(ji) = 0._wp 192 a_ip_1d(ji) = 0._wp 193 h_il_1d(ji) = 0._wp 194 ENDIF 195 ! 196 v_ip_1d(ji) = h_ip_1d(ji) * a_ip_1d(ji) 197 v_il_1d(ji) = h_il_1d(ji) * a_ip_1d(ji) 198 ! 199 zdv_pnd = ( h_ip_1d(ji) + h_il_1d(ji) ) * a_ip_1d(ji) - zdv_pnd 200 wfx_pnd_1d(ji) = wfx_pnd_1d(ji) - zdv_pnd * rhow * r1_Dt_ice 201 ! 202 END DO 203 204 CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_1d (1:npti), a_ip (:,:,jl) ) 205 CALL tab_1d_2d( npti, nptidx(1:npti), h_ip_1d (1:npti), h_ip (:,:,jl) ) 206 CALL tab_1d_2d( npti, nptidx(1:npti), h_il_1d (1:npti), h_il (:,:,jl) ) 207 CALL tab_1d_2d( npti, nptidx(1:npti), v_ip_1d (1:npti), v_ip (:,:,jl) ) 208 CALL tab_1d_2d( npti, nptidx(1:npti), v_il_1d (1:npti), v_il (:,:,jl) ) 209 CALL tab_1d_2d( npti, nptidx(1:npti), wfx_pnd_1d(1:npti), wfx_pnd(:,:) ) 210 96 211 END DO 97 212 ! … … 132 247 !! if no lids: Vp = Vp * exp(0.01*MAX(Tp-Tsu,0)/Tp) --- from Holland et al 2012 --- 133 248 !! 134 !! - Flushing: w = -perm/visc * rho_oce * grav * Hp / Hi 135 !! perm = permability of sea-ice 249 !! - Flushing: w = -perm/visc * rho_oce * grav * Hp / Hi * flush --- from Flocco et al 2007 --- 250 !! perm = permability of sea-ice + correction from Hunke et al 2012 (flush) 136 251 !! visc = water viscosity 137 252 !! Hp = height of top of the pond above sea-level 138 253 !! Hi = ice thickness thru which there is flushing 254 !! flush= correction otherwise flushing is excessive 139 255 !! 140 256 !! - Corrections: remove melt ponds when lid thickness is 10 times the pond thickness … … 143 259 !! a_ip/a_i = a_ip_frac = h_ip / zaspect 144 260 !! 145 !! ** Tunable parameters : ln_pnd_lids, rn_apnd_max, rn_apnd_min261 !! ** Tunable parameters : rn_apnd_max, rn_apnd_min, rn_pnd_flush 146 262 !! 147 !! ** Note : mostly stolen from CICE263 !! ** Note : Mostly stolen from CICE but not only. These are between level-ice ponds and CESM ponds. 148 264 !! 149 265 !! ** References : Flocco and Feltham (JGR, 2007) 150 266 !! Flocco et al (JGR, 2010) 151 267 !! Holland et al (J. Clim, 2012) 152 !!------------------------------------------------------------------- 268 !! Hunke et al (OM 2012) 269 !!------------------------------------------------------------------- 153 270 REAL(wp), DIMENSION(nlay_i) :: ztmp ! temporary array 154 271 !! … … 157 274 REAL(wp), PARAMETER :: zvisc = 1.79e-3_wp ! water viscosity 158 275 !! 159 REAL(wp) :: zfr_mlt, zdv_mlt 276 REAL(wp) :: zfr_mlt, zdv_mlt, zdv_avail ! fraction and volume of available meltwater retained for melt ponding 160 277 REAL(wp) :: zdv_frz, zdv_flush ! Amount of melt pond that freezes, flushes 278 REAL(wp) :: zdv_pnd ! Amount of water going into the ponds & lids 161 279 REAL(wp) :: zhp ! heigh of top of pond lid wrt ssh 162 280 REAL(wp) :: zv_ip_max ! max pond volume allowed 163 281 REAL(wp) :: zdT ! zTp-t_su 164 REAL(wp) :: zsbr 282 REAL(wp) :: zsbr, ztmelts ! Brine salinity 165 283 REAL(wp) :: zperm ! permeability of sea ice 166 284 REAL(wp) :: zfac, zdum ! temporary arrays 167 285 REAL(wp) :: z1_rhow, z1_aspect, z1_Tp ! inverse 168 286 !! 169 INTEGER :: ji, jk 287 INTEGER :: ji, jk, jl ! loop indices 170 288 !!------------------------------------------------------------------- 171 289 z1_rhow = 1._wp / rhow 172 290 z1_aspect = 1._wp / zaspect 173 291 z1_Tp = 1._wp / zTp 174 175 DO ji = 1, npti 176 ! !----------------------------------------------------! 177 IF( h_i_1d(ji) < rn_himin .OR. a_i_1d(ji) < epsi10 ) THEN ! Case ice thickness < rn_himin or tiny ice fraction ! 178 ! !----------------------------------------------------! 179 !--- Remove ponds on thin ice or tiny ice fractions 180 a_ip_1d(ji) = 0._wp 181 h_ip_1d(ji) = 0._wp 182 h_il_1d(ji) = 0._wp 183 ! !--------------------------------! 184 ELSE ! Case ice thickness >= rn_himin ! 185 ! !--------------------------------! 186 v_ip_1d(ji) = h_ip_1d(ji) * a_ip_1d(ji) ! retrieve volume from thickness 292 293 CALL tab_2d_1d( npti, nptidx(1:npti), at_i_1d (1:npti), at_i ) 294 CALL tab_2d_1d( npti, nptidx(1:npti), wfx_pnd_1d (1:npti), wfx_pnd ) 295 296 CALL tab_2d_1d( npti, nptidx(1:npti), diag_dvpn_mlt_1d (1:npti), diag_dvpn_mlt ) 297 CALL tab_2d_1d( npti, nptidx(1:npti), diag_dvpn_drn_1d (1:npti), diag_dvpn_drn ) 298 CALL tab_2d_1d( npti, nptidx(1:npti), diag_dvpn_lid_1d (1:npti), diag_dvpn_lid ) 299 CALL tab_2d_1d( npti, nptidx(1:npti), diag_dvpn_rnf_1d (1:npti), diag_dvpn_rnf ) 300 301 DO jl = 1, jpl 302 303 CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d (1:npti), a_i (:,:,jl) ) 304 CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d (1:npti), h_i (:,:,jl) ) 305 CALL tab_2d_1d( npti, nptidx(1:npti), t_su_1d (1:npti), t_su(:,:,jl) ) 306 CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d (1:npti), a_ip(:,:,jl) ) 307 CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d (1:npti), h_ip(:,:,jl) ) 308 CALL tab_2d_1d( npti, nptidx(1:npti), h_il_1d (1:npti), h_il(:,:,jl) ) 309 310 CALL tab_2d_1d( npti, nptidx(1:npti), dh_i_sum(1:npti), dh_i_sum_2d(:,:,jl) ) 311 CALL tab_2d_1d( npti, nptidx(1:npti), dh_s_mlt(1:npti), dh_s_mlt_2d(:,:,jl) ) 312 313 DO jk = 1, nlay_i 314 CALL tab_2d_1d( npti, nptidx(1:npti), sz_i_1d(1:npti,jk), sz_i(:,:,jk,jl) ) 315 CALL tab_2d_1d( npti, nptidx(1:npti), t_i_1d (1:npti,jk), t_i (:,:,jk,jl) ) 316 END DO 317 318 !----------------------- 319 ! Melt pond calculations 320 !----------------------- 321 DO ji = 1, npti 322 ! 323 zdv_pnd = ( h_ip_1d(ji) + h_il_1d(ji) ) * a_ip_1d(ji) 324 ! !----------------------------------------------------! 325 IF( h_i_1d(ji) < rn_himin .OR. a_i_1d(ji) < 0.01_wp ) THEN ! Case ice thickness < rn_himin or tiny ice fraction ! 326 ! !----------------------------------------------------! 327 !--- Remove ponds on thin ice or tiny ice fractions 328 a_ip_1d(ji) = 0._wp 329 h_ip_1d(ji) = 0._wp 330 h_il_1d(ji) = 0._wp 331 ! !--------------------------------! 332 ELSE ! Case ice thickness >= rn_himin ! 333 ! !--------------------------------! 334 v_ip_1d(ji) = h_ip_1d(ji) * a_ip_1d(ji) ! retrieve volume from thickness 335 v_il_1d(ji) = h_il_1d(ji) * a_ip_1d(ji) 336 ! 337 !------------------! 338 ! case ice melting ! 339 !------------------! 340 ! 341 !--- available meltwater for melt ponding (zdv_avail) ---! 342 zdv_avail = -( dh_i_sum(ji)*rhoi + dh_s_mlt(ji)*rhos ) * z1_rhow * a_i_1d(ji) ! > 0 343 zfr_mlt = rn_apnd_min + ( rn_apnd_max - rn_apnd_min ) * at_i_1d(ji) ! = ( 1 - r ) = fraction of melt water that is not flushed 344 zdv_mlt = MAX( 0._wp, zfr_mlt * zdv_avail ) ! max for roundoff errors? 345 ! 346 !--- overflow ---! 347 ! 348 ! area driven overflow 349 ! If pond area exceeds zfr_mlt * a_i_1d(ji) then reduce the pond volume 350 ! a_ip_max = zfr_mlt * a_i 351 ! => from zaspect = h_ip / (a_ip / a_i), set v_ip_max as: 352 zv_ip_max = zfr_mlt**2 * a_i_1d(ji) * zaspect 353 zdv_mlt = MAX( 0._wp, MIN( zdv_mlt, zv_ip_max - v_ip_1d(ji) ) ) 354 355 ! depth driven overflow 356 ! If pond depth exceeds half the ice thickness then reduce the pond volume 357 ! h_ip_max = 0.5 * h_i 358 ! => from zaspect = h_ip / (a_ip / a_i), set v_ip_max as: 359 zv_ip_max = z1_aspect * a_i_1d(ji) * 0.25 * h_i_1d(ji) * h_i_1d(ji) 360 zdv_mlt = MAX( 0._wp, MIN( zdv_mlt, zv_ip_max - v_ip_1d(ji) ) ) 361 362 !--- Pond growing ---! 363 v_ip_1d(ji) = v_ip_1d(ji) + zdv_mlt 364 ! 365 !--- Lid melting ---! 366 IF( ln_pnd_lids ) v_il_1d(ji) = MAX( 0._wp, v_il_1d(ji) - zdv_mlt ) ! must be bounded by 0 367 ! 368 !-------------------! 369 ! case ice freezing ! i.e. t_su_1d(ji) < (zTp+rt0) 370 !-------------------! 371 ! 372 zdT = MAX( zTp+rt0 - t_su_1d(ji), 0._wp ) 373 ! 374 !--- Pond contraction (due to refreezing) ---! 375 IF( ln_pnd_lids ) THEN 376 ! 377 !--- Lid growing and subsequent pond shrinking ---! 378 zdv_frz = - 0.5_wp * MAX( 0._wp, -v_il_1d(ji) + & ! Flocco 2010 (eq. 5) solved implicitly as aH**2 + bH + c = 0 379 & SQRT( v_il_1d(ji)**2 + a_ip_1d(ji)**2 * 4._wp * rcnd_i * zdT * rDt_ice / (rLfus * rhow) ) ) ! max for roundoff errors 380 381 ! Lid growing 382 v_il_1d(ji) = MAX( 0._wp, v_il_1d(ji) - zdv_frz ) 383 384 ! Pond shrinking 385 v_ip_1d(ji) = MAX( 0._wp, v_ip_1d(ji) + zdv_frz ) 386 387 ELSE 388 zdv_frz = v_ip_1d(ji) * ( EXP( 0.01_wp * zdT * z1_Tp ) - 1._wp ) ! Holland 2012 (eq. 6) 389 ! Pond shrinking 390 v_ip_1d(ji) = MAX( 0._wp, v_ip_1d(ji) + zdv_frz ) 391 ENDIF 392 ! 393 !--- Set new pond area and depth ---! assuming linear relation between h_ip and a_ip_frac 394 ! v_ip = h_ip * a_ip 395 ! a_ip/a_i = a_ip_frac = h_ip / zaspect (cf Holland 2012, fitting SHEBA so that knowing v_ip we can distribute it to a_ip and h_ip) 396 a_ip_1d(ji) = MIN( a_i_1d(ji), SQRT( v_ip_1d(ji) * z1_aspect * a_i_1d(ji) ) ) ! make sure a_ip < a_i 397 h_ip_1d(ji) = zaspect * a_ip_1d(ji) / a_i_1d(ji) 398 ! 399 400 !------------------------------------------------! 401 ! Pond drainage through brine network (flushing) ! 402 !------------------------------------------------! 403 ! height of top of the pond above sea-level 404 zhp = ( h_i_1d(ji) * ( rho0 - rhoi ) + h_ip_1d(ji) * ( rho0 - rhow * a_ip_1d(ji) / a_i_1d(ji) ) ) * r1_rho0 405 406 ! Calculate the permeability of the ice (Assur 1958, see Flocco 2010) 407 DO jk = 1, nlay_i 408 ! MV Assur is inconsistent with SI3 409 !!zsbr = - 1.2_wp & 410 !! & - 21.8_wp * ( t_i_1d(ji,jk) - rt0 ) & 411 !! & - 0.919_wp * ( t_i_1d(ji,jk) - rt0 )**2 & 412 !! & - 0.0178_wp * ( t_i_1d(ji,jk) - rt0 )**3 413 !!ztmp(jk) = sz_i_1d(ji,jk) / zsbr 414 ! MV linear expression more consistent & simpler: zsbr = - ( t_i_1d(ji,jk) - rt0 ) / rTmlt 415 ztmelts = -rTmlt * sz_i_1d(ji,jk) 416 ztmp(jk) = ztmelts / MIN( ztmelts, t_i_1d(ji,jk) - rt0 ) 417 END DO 418 zperm = MAX( 0._wp, 3.e-08_wp * MINVAL(ztmp)**3 ) 419 420 ! Do the drainage using Darcy's law 421 zdv_flush = -zperm * rho0 * grav * zhp * rDt_ice / (zvisc * h_i_1d(ji)) * a_ip_1d(ji) * rn_pnd_flush ! zflush comes from Hunke et al. (2012) 422 zdv_flush = MAX( zdv_flush, -v_ip_1d(ji) ) ! < 0 423 v_ip_1d(ji) = v_ip_1d(ji) + zdv_flush 424 425 !--- Set new pond area and depth ---! assuming linear relation between h_ip and a_ip_frac 426 a_ip_1d(ji) = MIN( a_i_1d(ji), SQRT( v_ip_1d(ji) * z1_aspect * a_i_1d(ji) ) ) ! make sure a_ip < a_i 427 h_ip_1d(ji) = zaspect * a_ip_1d(ji) / a_i_1d(ji) 428 429 !--- Corrections and lid thickness ---! 430 IF( ln_pnd_lids ) THEN 431 !--- retrieve lid thickness from volume ---! 432 IF( a_ip_1d(ji) > 0.01_wp ) THEN ; h_il_1d(ji) = v_il_1d(ji) / a_ip_1d(ji) 433 ELSE ; h_il_1d(ji) = 0._wp 434 ENDIF 435 !--- remove ponds if lids are much larger than ponds ---! 436 IF ( h_il_1d(ji) > h_ip_1d(ji) * 10._wp ) THEN 437 a_ip_1d(ji) = 0._wp 438 h_ip_1d(ji) = 0._wp 439 h_il_1d(ji) = 0._wp 440 ENDIF 441 ENDIF 442 443 ! diagnostics: dvpnd = mlt+rnf+lid+drn 444 diag_dvpn_mlt_1d(ji) = diag_dvpn_mlt_1d(ji) + rhow * zdv_avail * r1_Dt_ice ! > 0, surface melt input 445 diag_dvpn_rnf_1d(ji) = diag_dvpn_rnf_1d(ji) + rhow * ( zdv_mlt - zdv_avail ) * r1_Dt_ice ! < 0, runoff 446 diag_dvpn_lid_1d(ji) = diag_dvpn_lid_1d(ji) + rhow * zdv_frz * r1_Dt_ice ! < 0, shrinking 447 diag_dvpn_drn_1d(ji) = diag_dvpn_drn_1d(ji) + rhow * zdv_flush * r1_Dt_ice ! < 0, drainage 448 ! 449 ENDIF 450 ! 451 v_ip_1d(ji) = h_ip_1d(ji) * a_ip_1d(ji) 187 452 v_il_1d(ji) = h_il_1d(ji) * a_ip_1d(ji) 188 453 ! 189 !------------------! 190 ! case ice melting ! 191 !------------------! 454 zdv_pnd = ( h_ip_1d(ji) + h_il_1d(ji) ) * a_ip_1d(ji) - zdv_pnd 455 wfx_pnd_1d(ji) = wfx_pnd_1d(ji) - zdv_pnd * rhow * r1_Dt_ice 192 456 ! 193 !--- available meltwater for melt ponding ---! 194 zdum = -( dh_i_sum(ji)*rhoi + dh_s_mlt(ji)*rhos ) * z1_rhow * a_i_1d(ji) 195 zfr_mlt = rn_apnd_min + ( rn_apnd_max - rn_apnd_min ) * at_i_1d(ji) ! = ( 1 - r ) = fraction of melt water that is not flushed 196 zdv_mlt = MAX( 0._wp, zfr_mlt * zdum ) ! max for roundoff errors? 197 ! 198 !--- overflow ---! 199 ! If pond area exceeds zfr_mlt * a_i_1d(ji) then reduce the pond volume 200 ! a_ip_max = zfr_mlt * a_i 201 ! => from zaspect = h_ip / (a_ip / a_i), set v_ip_max as: 202 zv_ip_max = zfr_mlt**2 * a_i_1d(ji) * zaspect 203 zdv_mlt = MAX( 0._wp, MIN( zdv_mlt, zv_ip_max - v_ip_1d(ji) ) ) 204 205 ! If pond depth exceeds half the ice thickness then reduce the pond volume 206 ! h_ip_max = 0.5 * h_i 207 ! => from zaspect = h_ip / (a_ip / a_i), set v_ip_max as: 208 zv_ip_max = z1_aspect * a_i_1d(ji) * 0.25 * h_i_1d(ji) * h_i_1d(ji) 209 zdv_mlt = MAX( 0._wp, MIN( zdv_mlt, zv_ip_max - v_ip_1d(ji) ) ) 210 211 !--- Pond growing ---! 212 v_ip_1d(ji) = v_ip_1d(ji) + zdv_mlt 213 ! 214 !--- Lid melting ---! 215 IF( ln_pnd_lids ) v_il_1d(ji) = MAX( 0._wp, v_il_1d(ji) - zdv_mlt ) ! must be bounded by 0 216 ! 217 !--- mass flux ---! 218 IF( zdv_mlt > 0._wp ) THEN 219 zfac = zdv_mlt * rhow * r1_Dt_ice ! melt pond mass flux < 0 [kg.m-2.s-1] 220 wfx_pnd_1d(ji) = wfx_pnd_1d(ji) - zfac 221 ! 222 zdum = zfac / ( wfx_snw_sum_1d(ji) + wfx_sum_1d(ji) ) ! adjust ice/snow melting flux > 0 to balance melt pond flux 223 wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) * (1._wp + zdum) 224 wfx_sum_1d(ji) = wfx_sum_1d(ji) * (1._wp + zdum) 225 ENDIF 226 227 !-------------------! 228 ! case ice freezing ! i.e. t_su_1d(ji) < (zTp+rt0) 229 !-------------------! 230 ! 231 zdT = MAX( zTp+rt0 - t_su_1d(ji), 0._wp ) 232 ! 233 !--- Pond contraction (due to refreezing) ---! 234 IF( ln_pnd_lids ) THEN 235 ! 236 !--- Lid growing and subsequent pond shrinking ---! 237 zdv_frz = 0.5_wp * MAX( 0._wp, -v_il_1d(ji) + & ! Flocco 2010 (eq. 5) solved implicitly as aH**2 + bH + c = 0 238 & SQRT( v_il_1d(ji)**2 + a_ip_1d(ji)**2 * 4._wp * rcnd_i * zdT * rdt_ice / (rLfus * rhow) ) ) ! max for roundoff errors 239 240 ! Lid growing 241 v_il_1d(ji) = MAX( 0._wp, v_il_1d(ji) + zdv_frz ) 242 243 ! Pond shrinking 244 v_ip_1d(ji) = MAX( 0._wp, v_ip_1d(ji) - zdv_frz ) 245 246 ELSE 247 ! Pond shrinking 248 v_ip_1d(ji) = v_ip_1d(ji) * EXP( 0.01_wp * zdT * z1_Tp ) ! Holland 2012 (eq. 6) 249 ENDIF 250 ! 251 !--- Set new pond area and depth ---! assuming linear relation between h_ip and a_ip_frac 252 ! v_ip = h_ip * a_ip 253 ! a_ip/a_i = a_ip_frac = h_ip / zaspect (cf Holland 2012, fitting SHEBA so that knowing v_ip we can distribute it to a_ip and h_ip) 254 a_ip_1d(ji) = MIN( a_i_1d(ji), SQRT( v_ip_1d(ji) * z1_aspect * a_i_1d(ji) ) ) ! make sure a_ip < a_i 255 h_ip_1d(ji) = zaspect * a_ip_1d(ji) / a_i_1d(ji) 256 257 !---------------! 258 ! Pond flushing ! 259 !---------------! 260 ! height of top of the pond above sea-level 261 zhp = ( h_i_1d(ji) * ( rho0 - rhoi ) + h_ip_1d(ji) * ( rho0 - rhow * a_ip_1d(ji) / a_i_1d(ji) ) ) * r1_rho0 262 263 ! Calculate the permeability of the ice (Assur 1958, see Flocco 2010) 264 DO jk = 1, nlay_i 265 zsbr = - 1.2_wp & 266 & - 21.8_wp * ( t_i_1d(ji,jk) - rt0 ) & 267 & - 0.919_wp * ( t_i_1d(ji,jk) - rt0 )**2 & 268 & - 0.0178_wp * ( t_i_1d(ji,jk) - rt0 )**3 269 ztmp(jk) = sz_i_1d(ji,jk) / zsbr 270 END DO 271 zperm = MAX( 0._wp, 3.e-08_wp * MINVAL(ztmp)**3 ) 272 273 ! Do the drainage using Darcy's law 274 zdv_flush = -zperm * rho0 * grav * zhp * rdt_ice / (zvisc * h_i_1d(ji)) * a_ip_1d(ji) 275 zdv_flush = MAX( zdv_flush, -v_ip_1d(ji) ) 276 v_ip_1d(ji) = v_ip_1d(ji) + zdv_flush 277 278 !--- Set new pond area and depth ---! assuming linear relation between h_ip and a_ip_frac 279 a_ip_1d(ji) = MIN( a_i_1d(ji), SQRT( v_ip_1d(ji) * z1_aspect * a_i_1d(ji) ) ) ! make sure a_ip < a_i 280 h_ip_1d(ji) = zaspect * a_ip_1d(ji) / a_i_1d(ji) 281 282 !--- Corrections and lid thickness ---! 283 IF( ln_pnd_lids ) THEN 284 !--- retrieve lid thickness from volume ---! 285 IF( a_ip_1d(ji) > epsi10 ) THEN ; h_il_1d(ji) = v_il_1d(ji) / a_ip_1d(ji) 286 ELSE ; h_il_1d(ji) = 0._wp 287 ENDIF 288 !--- remove ponds if lids are much larger than ponds ---! 289 IF ( h_il_1d(ji) > h_ip_1d(ji) * 10._wp ) THEN 290 a_ip_1d(ji) = 0._wp 291 h_ip_1d(ji) = 0._wp 292 h_il_1d(ji) = 0._wp 293 ENDIF 294 ENDIF 295 ! 296 ENDIF 297 457 END DO 458 459 !-------------------------------------------------------------------- 460 ! Retrieve 2D arrays 461 !-------------------------------------------------------------------- 462 CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_1d(1:npti), a_ip(:,:,jl) ) 463 CALL tab_1d_2d( npti, nptidx(1:npti), h_ip_1d(1:npti), h_ip(:,:,jl) ) 464 CALL tab_1d_2d( npti, nptidx(1:npti), h_il_1d(1:npti), h_il(:,:,jl) ) 465 CALL tab_1d_2d( npti, nptidx(1:npti), v_ip_1d(1:npti), v_ip(:,:,jl) ) 466 CALL tab_1d_2d( npti, nptidx(1:npti), v_il_1d(1:npti), v_il(:,:,jl) ) 467 ! 298 468 END DO 299 469 ! 470 CALL tab_1d_2d( npti, nptidx(1:npti), wfx_pnd_1d(1:npti), wfx_pnd ) 471 ! 472 CALL tab_1d_2d( npti, nptidx(1:npti), diag_dvpn_mlt_1d (1:npti), diag_dvpn_mlt ) 473 CALL tab_1d_2d( npti, nptidx(1:npti), diag_dvpn_drn_1d (1:npti), diag_dvpn_drn ) 474 CALL tab_1d_2d( npti, nptidx(1:npti), diag_dvpn_lid_1d (1:npti), diag_dvpn_lid ) 475 CALL tab_1d_2d( npti, nptidx(1:npti), diag_dvpn_rnf_1d (1:npti), diag_dvpn_rnf ) 476 ! 300 477 END SUBROUTINE pnd_LEV 301 478 479 480 481 SUBROUTINE pnd_TOPO 482 483 !!------------------------------------------------------------------- 484 !! *** ROUTINE pnd_TOPO *** 485 !! 486 !! ** Purpose : Compute melt pond evolution based on the ice 487 !! topography inferred from the ice thickness distribution 488 !! 489 !! ** Method : This code is initially based on Flocco and Feltham 490 !! (2007) and Flocco et al. (2010). 491 !! 492 !! - Calculate available pond water base on surface meltwater 493 !! - Redistribute water as a function of topography, drain water 494 !! - Exchange water with the lid 495 !! 496 !! ** Tunable parameters : 497 !! 498 !! ** Note : 499 !! 500 !! ** References 501 !! 502 !! Flocco, D. and D. L. Feltham, 2007. A continuum model of melt pond 503 !! evolution on Arctic sea ice. J. Geophys. Res. 112, C08016, doi: 504 !! 10.1029/2006JC003836. 505 !! 506 !! Flocco, D., D. L. Feltham and A. K. Turner, 2010. Incorporation of 507 !! a physically based melt pond scheme into the sea ice component of a 508 !! climate model. J. Geophys. Res. 115, C08012, 509 !! doi: 10.1029/2009JC005568. 510 !! 511 !!------------------------------------------------------------------- 512 REAL(wp), PARAMETER :: & ! shared parameters for topographic melt ponds 513 zTd = 0.15_wp , & ! temperature difference for freeze-up (C) 514 zvp_min = 1.e-4_wp ! minimum pond volume (m) 515 516 517 ! local variables 518 REAL(wp) :: & 519 zdHui, & ! change in thickness of ice lid (m) 520 zomega, & ! conduction 521 zdTice, & ! temperature difference across ice lid (C) 522 zdvice, & ! change in ice volume (m) 523 zTavg, & ! mean surface temperature across categories (C) 524 zfsurf, & ! net heat flux, excluding conduction and transmitted radiation (W/m2) 525 zTp, & ! pond freezing temperature (C) 526 zrhoi_L, & ! volumetric latent heat of sea ice (J/m^3) 527 zfr_mlt, & ! fraction and volume of available meltwater retained for melt ponding 528 z1_rhow, & ! inverse water density 529 zv_pnd , & ! volume of meltwater contributing to ponds 530 zv_mlt ! total amount of meltwater produced 531 532 REAL(wp), DIMENSION(jpi,jpj) :: zvolp, & !! total melt pond water available before redistribution and drainage 533 zvolp_res !! remaining melt pond water available after drainage 534 535 REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_a_i 536 537 INTEGER :: ji, jj, jk, jl ! loop indices 538 539 INTEGER :: i_test 540 541 ! Note 542 ! equivalent for CICE translation 543 ! a_ip -> apond 544 ! a_ip_frac -> apnd 545 546 CALL ctl_stop( 'STOP', 'icethd_pnd : topographic melt ponds are still an ongoing work' ) 547 548 !--------------------------------------------------------------- 549 ! Initialise 550 !--------------------------------------------------------------- 551 552 ! Parameters & constants (move to parameters) 553 zrhoi_L = rhoi * rLfus ! volumetric latent heat (J/m^3) 554 zTp = rt0 - 0.15_wp ! pond freezing point, slightly below 0C (ponds are bid saline) 555 z1_rhow = 1._wp / rhow 556 557 ! Set required ice variables (hard-coded here for now) 558 ! zfpond(:,:) = 0._wp ! contributing freshwater flux (?) 559 560 at_i (:,:) = SUM( a_i (:,:,:), dim=3 ) ! ice fraction 561 vt_i (:,:) = SUM( v_i (:,:,:), dim=3 ) ! volume per grid area 562 vt_ip(:,:) = SUM( v_ip(:,:,:), dim=3 ) ! pond volume per grid area 563 vt_il(:,:) = SUM( v_il(:,:,:), dim=3 ) ! lid volume per grid area 564 565 ! thickness 566 WHERE( a_i(:,:,:) > epsi20 ) ; z1_a_i(:,:,:) = 1._wp / a_i(:,:,:) 567 ELSEWHERE ; z1_a_i(:,:,:) = 0._wp 568 END WHERE 569 h_i(:,:,:) = v_i (:,:,:) * z1_a_i(:,:,:) 570 571 !--------------------------------------------------------------- 572 ! Change 2D to 1D 573 !--------------------------------------------------------------- 574 ! MV 575 ! a less computing-intensive version would have 2D-1D passage here 576 ! use what we have in iceitd.F90 (incremental remapping) 577 578 !-------------------------------------------------------------- 579 ! Collect total available pond water volume 580 !-------------------------------------------------------------- 581 ! Assuming that meltwater (+rain in principle) runsoff the surface 582 ! Holland et al (2012) suggest that the fraction of runoff decreases with total ice fraction 583 ! I cite her words, they are very talkative 584 ! "grid cells with very little ice cover (and hence more open water area) 585 ! have a higher runoff fraction to rep- resent the greater proximity of ice to open water." 586 ! "This results in the same runoff fraction r for each ice category within a grid cell" 587 588 zvolp(:,:) = 0._wp 589 590 DO jl = 1, jpl 591 DO_2D( 1, 1, 1, 1 ) 592 593 IF ( a_i(ji,jj,jl) > epsi10 ) THEN 594 595 !--- Available and contributing meltwater for melt ponding ---! 596 zv_mlt = - ( dh_i_sum_2d(ji,jj,jl) * rhoi + dh_s_mlt_2d(ji,jj,jl) * rhos ) & ! available volume of surface melt water per grid area 597 & * z1_rhow * a_i(ji,jj,jl) 598 ! MV -> could move this directly in ice_thd_dh and get an array (ji,jj,jl) for surface melt water volume per grid area 599 zfr_mlt = rn_apnd_min + ( rn_apnd_max - rn_apnd_min ) * at_i(ji,jj) ! fraction of surface meltwater going to ponds 600 zv_pnd = zfr_mlt * zv_mlt ! contributing meltwater volume for category jl 601 602 diag_dvpn_mlt(ji,jj) = diag_dvpn_mlt(ji,jj) + zv_mlt * r1_Dt_ice ! diags 603 diag_dvpn_rnf(ji,jj) = diag_dvpn_rnf(ji,jj) + ( 1. - zfr_mlt ) * zv_mlt * r1_Dt_ice 604 605 !--- Create possible new ponds 606 ! if pond does not exist, create new pond over full ice area 607 !IF ( a_ip_frac(ji,jj,jl) < epsi10 ) THEN 608 IF ( a_ip(ji,jj,jl) < epsi10 ) THEN 609 a_ip(ji,jj,jl) = a_i(ji,jj,jl) 610 a_ip_frac(ji,jj,jl) = 1.0_wp ! pond fraction of sea ice (apnd for CICE) 611 ENDIF 612 613 !--- Deepen existing ponds with no change in pond fraction, before redistribution and drainage 614 v_ip(ji,jj,jl) = v_ip(ji,jj,jl) + zv_pnd ! use pond water to increase thickness 615 h_ip(ji,jj,jl) = v_ip(ji,jj,jl) / a_ip(ji,jj,jl) 616 617 !--- Total available pond water volume (pre-existing + newly produced)j 618 zvolp(ji,jj) = zvolp(ji,jj) + v_ip(ji,jj,jl) 619 ! zfpond(ji,jj) = zfpond(ji,jj) + zpond * a_ip_frac(ji,jj,jl) ! useless for now 620 621 ENDIF ! a_i 622 623 END_2D 624 END DO ! ji 625 626 !-------------------------------------------------------------- 627 ! Redistribute and drain water from ponds 628 !-------------------------------------------------------------- 629 CALL ice_thd_pnd_area( zvolp, zvolp_res ) 630 631 !-------------------------------------------------------------- 632 ! Melt pond lid growth and melt 633 !-------------------------------------------------------------- 634 635 IF( ln_pnd_lids ) THEN 636 637 DO_2D( 1, 1, 1, 1 ) 638 639 IF ( at_i(ji,jj) > 0.01 .AND. hm_i(ji,jj) > rn_himin .AND. vt_ip(ji,jj) > zvp_min * at_i(ji,jj) ) THEN 640 641 !-------------------------- 642 ! Pond lid growth and melt 643 !-------------------------- 644 ! Mean surface temperature 645 zTavg = 0._wp 646 DO jl = 1, jpl 647 zTavg = zTavg + t_su(ji,jj,jl)*a_i(ji,jj,jl) 648 END DO 649 zTavg = zTavg / a_i(ji,jj,jl) !!! could get a division by zero here 650 651 DO jl = 1, jpl-1 652 653 IF ( v_il(ji,jj,jl) > epsi10 ) THEN 654 655 !---------------------------------------------------------------- 656 ! Lid melting: floating upper ice layer melts in whole or part 657 !---------------------------------------------------------------- 658 ! Use Tsfc for each category 659 IF ( t_su(ji,jj,jl) > zTp ) THEN 660 661 zdvice = MIN( dh_i_sum_2d(ji,jj,jl)*a_ip(ji,jj,jl), v_il(ji,jj,jl) ) 662 663 IF ( zdvice > epsi10 ) THEN 664 665 v_il (ji,jj,jl) = v_il (ji,jj,jl) - zdvice 666 v_ip(ji,jj,jl) = v_ip(ji,jj,jl) + zdvice ! MV: not sure i understand dh_i_sum seems counted twice - 667 ! as it is already counted in surface melt 668 ! zvolp(ji,jj) = zvolp(ji,jj) + zdvice ! pointless to calculate total volume (done in icevar) 669 ! zfpond(ji,jj) = fpond(ji,jj) + zdvice ! pointless to follow fw budget (ponds have no fw) 670 671 IF ( v_il(ji,jj,jl) < epsi10 .AND. v_ip(ji,jj,jl) > epsi10) THEN 672 ! ice lid melted and category is pond covered 673 v_ip(ji,jj,jl) = v_ip(ji,jj,jl) + v_il(ji,jj,jl) 674 ! zfpond(ji,jj) = zfpond (ji,jj) + v_il(ji,jj,jl) 675 v_il(ji,jj,jl) = 0._wp 676 ENDIF 677 h_ip(ji,jj,jl) = v_ip(ji,jj,jl) / a_ip(ji,jj,jl) !!! could get a division by zero here 678 679 diag_dvpn_lid(ji,jj) = diag_dvpn_lid(ji,jj) + zdvice ! diag 680 681 ENDIF 682 683 !---------------------------------------------------------------- 684 ! Freeze pre-existing lid 685 !---------------------------------------------------------------- 686 687 ELSE IF ( v_ip(ji,jj,jl) > epsi10 ) THEN ! Tsfcn(i,j,n) <= Tp 688 689 ! differential growth of base of surface floating ice layer 690 zdTice = MAX( - t_su(ji,jj,jl) - zTd , 0._wp ) ! > 0 691 zomega = rcnd_i * zdTice / zrhoi_L 692 zdHui = SQRT( 2._wp * zomega * rDt_ice + ( v_il(ji,jj,jl) / a_i(ji,jj,jl) )**2 ) & 693 - v_il(ji,jj,jl) / a_i(ji,jj,jl) 694 zdvice = min( zdHui*a_ip(ji,jj,jl) , v_ip(ji,jj,jl) ) 695 696 IF ( zdvice > epsi10 ) THEN 697 v_il (ji,jj,jl) = v_il(ji,jj,jl) + zdvice 698 v_ip(ji,jj,jl) = v_ip(ji,jj,jl) - zdvice 699 ! zvolp(ji,jj) = zvolp(ji,jj) - zdvice 700 ! zfpond(ji,jj) = zfpond(ji,jj) - zdvice 701 h_ip(ji,jj,jl) = v_ip(ji,jj,jl) / a_ip(ji,jj,jl) 702 703 diag_dvpn_lid(ji,jj) = diag_dvpn_lid(ji,jj) - zdvice ! diag 704 705 ENDIF 706 707 ENDIF ! Tsfcn(i,j,n) 708 709 !---------------------------------------------------------------- 710 ! Freeze new lids 711 !---------------------------------------------------------------- 712 ! upper ice layer begins to form 713 ! note: albedo does not change 714 715 ELSE ! v_il < epsi10 716 717 ! thickness of newly formed ice 718 ! the surface temperature of a meltpond is the same as that 719 ! of the ice underneath (0C), and the thermodynamic surface 720 ! flux is the same 721 722 !!! we need net surface energy flux, excluding conduction 723 !!! fsurf is summed over categories in CICE 724 !!! we have the category-dependent flux, let us use it ? 725 zfsurf = qns_ice(ji,jj,jl) + qsr_ice(ji,jj,jl) 726 zdHui = MAX ( -zfsurf * rDt_ice/zrhoi_L , 0._wp ) 727 zdvice = MIN ( zdHui * a_ip(ji,jj,jl) , v_ip(ji,jj,jl) ) 728 IF ( zdvice > epsi10 ) THEN 729 v_il (ji,jj,jl) = v_il(ji,jj,jl) + zdvice 730 v_ip(ji,jj,jl) = v_ip(ji,jj,jl) - zdvice 731 732 diag_dvpn_lid(ji,jj) = diag_dvpn_lid(ji,jj) - zdvice ! diag 733 ! zvolp(ji,jj) = zvolp(ji,jj) - zdvice 734 ! zfpond(ji,jj) = zfpond(ji,jj) - zdvice 735 h_ip(ji,jj,jl) = v_ip(ji,jj,jl) / a_ip(ji,jj,jl) ! MV - in principle, this is useless as h_ip is computed in icevar 736 ENDIF 737 738 ENDIF ! v_il 739 740 END DO ! jl 741 742 ELSE ! remove ponds on thin ice 743 744 v_ip(ji,jj,:) = 0._wp 745 v_il(ji,jj,:) = 0._wp 746 ! zfpond(ji,jj) = zfpond(ji,jj)- zvolp(ji,jj) 747 ! zvolp(ji,jj) = 0._wp 748 749 ENDIF 750 751 END_2D 752 753 ENDIF ! ln_pnd_lids 754 755 !--------------------------------------------------------------- 756 ! Clean-up variables (probably duplicates what icevar would do) 757 !--------------------------------------------------------------- 758 ! MV comment 759 ! In the ideal world, the lines above should update only v_ip, a_ip, v_il 760 ! icevar should recompute all other variables (if needed at all) 761 762 DO jl = 1, jpl 763 764 DO_2D( 1, 1, 1, 1 ) 765 766 ! ! zap lids on small ponds 767 ! IF ( a_i(ji,jj,jl) > epsi10 .AND. v_ip(ji,jj,jl) < epsi10 & 768 ! .AND. v_il(ji,jj,jl) > epsi10) THEN 769 ! v_il(ji,jj,jl) = 0._wp ! probably uselesss now since we get zap_small 770 ! ENDIF 771 772 ! recalculate equivalent pond variables 773 IF ( a_ip(ji,jj,jl) > epsi10) THEN 774 h_ip(ji,jj,jl) = v_ip(ji,jj,jl) / a_i(ji,jj,jl) 775 a_ip_frac(ji,jj,jl) = a_ip(ji,jj,jl) / a_i(ji,jj,jl) ! MV in principle, useless as computed in icevar 776 h_il(ji,jj,jl) = v_il(ji,jj,jl) / a_ip(ji,jj,jl) ! MV in principle, useless as computed in icevar 777 ENDIF 778 ! h_ip(ji,jj,jl) = 0._wp ! MV in principle, useless as computed in icevar 779 ! h_il(ji,jj,jl) = 0._wp ! MV in principle, useless as omputed in icevar 780 ! ENDIF 781 782 END_2D 783 784 END DO ! jl 785 786 787 END SUBROUTINE pnd_TOPO 788 789 790 SUBROUTINE ice_thd_pnd_area( zvolp , zdvolp ) 791 792 !!------------------------------------------------------------------- 793 !! *** ROUTINE ice_thd_pnd_area *** 794 !! 795 !! ** Purpose : Given the total volume of available pond water, 796 !! redistribute and drain water 797 !! 798 !! ** Method 799 !! 800 !-----------| 801 ! | 802 ! |-----------| 803 !___________|___________|______________________________________sea-level 804 ! | | 805 ! | |---^--------| 806 ! | | | | 807 ! | | | |-----------| |------- 808 ! | | | alfan | | | 809 ! | | | | |--------------| 810 ! | | | | | | 811 !---------------------------v------------------------------------------- 812 ! | | ^ | | | 813 ! | | | | |--------------| 814 ! | | | betan | | | 815 ! | | | |-----------| |------- 816 ! | | | | 817 ! | |---v------- | 818 ! | | 819 ! |-----------| 820 ! | 821 !-----------| 822 ! 823 !! 824 !!------------------------------------------------------------------ 825 826 REAL (wp), DIMENSION(jpi,jpj), INTENT(INOUT) :: & 827 zvolp, & ! total available pond water 828 zdvolp ! remaining meltwater after redistribution 829 830 INTEGER :: & 831 ns, & 832 m_index, & 833 permflag 834 835 REAL (wp), DIMENSION(jpl) :: & 836 hicen, & 837 hsnon, & 838 asnon, & 839 alfan, & 840 betan, & 841 cum_max_vol, & 842 reduced_aicen 843 844 REAL (wp), DIMENSION(0:jpl) :: & 845 cum_max_vol_tmp 846 847 REAL (wp) :: & 848 hpond, & 849 drain, & 850 floe_weight, & 851 pressure_head, & 852 hsl_rel, & 853 deltah, & 854 perm, & 855 msno 856 857 REAL (wp), parameter :: & 858 viscosity = 1.79e-3_wp ! kinematic water viscosity in kg/m/s 859 860 REAL(wp), PARAMETER :: & ! shared parameters for topographic melt ponds 861 zvp_min = 1.e-4_wp ! minimum pond volume (m) 862 863 INTEGER :: ji, jj, jk, jl ! loop indices 864 865 a_ip(:,:,:) = 0._wp 866 h_ip(:,:,:) = 0._wp 867 868 DO_2D( 1, 1, 1, 1 ) 869 870 IF ( at_i(ji,jj) > 0.01 .AND. hm_i(ji,jj) > rn_himin .AND. zvolp(ji,jj) > zvp_min * at_i(ji,jj) ) THEN 871 872 !------------------------------------------------------------------- 873 ! initialize 874 !------------------------------------------------------------------- 875 876 DO jl = 1, jpl 877 878 !---------------------------------------- 879 ! compute the effective snow fraction 880 !---------------------------------------- 881 882 IF (a_i(ji,jj,jl) < epsi10) THEN 883 hicen(jl) = 0._wp 884 hsnon(jl) = 0._wp 885 reduced_aicen(jl) = 0._wp 886 asnon(jl) = 0._wp !js: in CICE 5.1.2: make sense as the compiler may not initiate the variables 887 ELSE 888 hicen(jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl) 889 hsnon(jl) = v_s(ji,jj,jl) / a_i(ji,jj,jl) 890 reduced_aicen(jl) = 1._wp ! n=jpl 891 892 !js: initial code in NEMO_DEV 893 !IF (n < jpl) reduced_aicen(jl) = aicen(jl) & 894 ! * (-0.024_wp*hicen(jl) + 0.832_wp) 895 896 !js: from CICE 5.1.2: this limit reduced_aicen to 0.2 when hicen is too large 897 IF (jl < jpl) reduced_aicen(jl) = a_i(ji,jj,jl) & 898 * max(0.2_wp,(-0.024_wp*hicen(jl) + 0.832_wp)) 899 900 asnon(jl) = reduced_aicen(jl) ! effective snow fraction (empirical) 901 ! MV should check whether this makes sense to have the same effective snow fraction in here 902 ! OLI: it probably doesn't 903 END IF 904 905 ! This choice for alfa and beta ignores hydrostatic equilibium of categories. 906 ! Hydrostatic equilibium of the entire ITD is accounted for below, assuming 907 ! a surface topography implied by alfa=0.6 and beta=0.4, and rigidity across all 908 ! categories. alfa and beta partition the ITD - they are areas not thicknesses! 909 ! Multiplying by hicen, alfan and betan (below) are thus volumes per unit area. 910 ! Here, alfa = 60% of the ice area (and since hice is constant in a category, 911 ! alfan = 60% of the ice volume) in each category lies above the reference line, 912 ! and 40% below. Note: p6 is an arbitrary choice, but alfa+beta=1 is required. 913 914 ! MV: 915 ! Note that this choice is not in the original FF07 paper and has been adopted in CICE 916 ! No reason why is explained in the doc, but I guess there is a reason. I'll try to investigate, maybe 917 918 ! Where does that choice come from ? => OLI : Coz' Chuck Norris said so... 919 920 alfan(jl) = 0.6 * hicen(jl) 921 betan(jl) = 0.4 * hicen(jl) 922 923 cum_max_vol(jl) = 0._wp 924 cum_max_vol_tmp(jl) = 0._wp 925 926 END DO ! jpl 927 928 cum_max_vol_tmp(0) = 0._wp 929 drain = 0._wp 930 zdvolp(ji,jj) = 0._wp 931 932 !---------------------------------------------------------- 933 ! Drain overflow water, update pond fraction and volume 934 !---------------------------------------------------------- 935 936 !-------------------------------------------------------------------------- 937 ! the maximum amount of water that can be contained up to each ice category 938 !-------------------------------------------------------------------------- 939 ! If melt ponds are too deep to be sustainable given the ITD (OVERFLOW) 940 ! Then the excess volume cum_max_vol(jl) drains out of the system 941 ! It should be added to wfx_pnd_out 942 943 DO jl = 1, jpl-1 ! last category can not hold any volume 944 945 IF (alfan(jl+1) >= alfan(jl) .AND. alfan(jl+1) > 0._wp ) THEN 946 947 ! total volume in level including snow 948 cum_max_vol_tmp(jl) = cum_max_vol_tmp(jl-1) + & 949 (alfan(jl+1) - alfan(jl)) * sum(reduced_aicen(1:jl)) 950 951 ! subtract snow solid volumes from lower categories in current level 952 DO ns = 1, jl 953 cum_max_vol_tmp(jl) = cum_max_vol_tmp(jl) & 954 - rhos/rhow * & ! free air fraction that can be filled by water 955 asnon(ns) * & ! effective areal fraction of snow in that category 956 max(min(hsnon(ns)+alfan(ns)-alfan(jl), alfan(jl+1)-alfan(jl)), 0._wp) 957 END DO 958 959 ELSE ! assume higher categories unoccupied 960 cum_max_vol_tmp(jl) = cum_max_vol_tmp(jl-1) 961 END IF 962 !IF (cum_max_vol_tmp(jl) < z0) THEN 963 ! CALL abort_ice('negative melt pond volume') 964 !END IF 965 END DO 966 cum_max_vol_tmp(jpl) = cum_max_vol_tmp(jpl-1) ! last category holds no volume 967 cum_max_vol (1:jpl) = cum_max_vol_tmp(1:jpl) 968 969 !---------------------------------------------------------------- 970 ! is there more meltwater than can be held in the floe? 971 !---------------------------------------------------------------- 972 IF (zvolp(ji,jj) >= cum_max_vol(jpl)) THEN 973 drain = zvolp(ji,jj) - cum_max_vol(jpl) + epsi10 974 zvolp(ji,jj) = zvolp(ji,jj) - drain ! update meltwater volume available 975 976 diag_dvpn_rnf(ji,jj) = - drain ! diag - overflow counted in the runoff part (arbitrary choice) 977 978 zdvolp(ji,jj) = drain ! this is the drained water 979 IF (zvolp(ji,jj) < epsi10) THEN 980 zdvolp(ji,jj) = zdvolp(ji,jj) + zvolp(ji,jj) 981 zvolp(ji,jj) = 0._wp 982 END IF 983 END IF 984 985 ! height and area corresponding to the remaining volume 986 ! routine leaves zvolp unchanged 987 CALL ice_thd_pnd_depth(reduced_aicen, asnon, hsnon, alfan, zvolp(ji,jj), cum_max_vol, hpond, m_index) 988 989 DO jl = 1, m_index 990 !h_ip(jl) = hpond - alfan(jl) + alfan(1) ! here oui choulde update 991 ! ! volume instead, no ? 992 h_ip(ji,jj,jl) = max((hpond - alfan(jl) + alfan(1)), 0._wp) !js: from CICE 5.1.2 993 a_ip(ji,jj,jl) = reduced_aicen(jl) 994 ! in practise, pond fraction depends on the empirical snow fraction 995 ! so in turn on ice thickness 996 END DO 997 !zapond = sum(a_ip(1:m_index)) !js: from CICE 5.1.2; not in Icepack1.1.0-6-gac6195d 998 999 !------------------------------------------------------------------------ 1000 ! Drainage through brine network (permeability) 1001 !------------------------------------------------------------------------ 1002 !!! drainage due to ice permeability - Darcy's law 1003 1004 ! sea water level 1005 msno = 0._wp 1006 DO jl = 1 , jpl 1007 msno = msno + v_s(ji,jj,jl) * rhos 1008 END DO 1009 floe_weight = ( msno + rhoi*vt_i(ji,jj) + rho0*zvolp(ji,jj) ) / at_i(ji,jj) 1010 hsl_rel = floe_weight / rho0 & 1011 - ( ( sum(betan(:)*a_i(ji,jj,:)) / at_i(ji,jj) ) + alfan(1) ) 1012 1013 deltah = hpond - hsl_rel 1014 pressure_head = grav * rho0 * max(deltah, 0._wp) 1015 1016 ! drain if ice is permeable 1017 permflag = 0 1018 1019 IF (pressure_head > 0._wp) THEN 1020 DO jl = 1, jpl-1 1021 IF ( hicen(jl) /= 0._wp ) THEN 1022 1023 !IF (hicen(jl) > 0._wp) THEN !js: from CICE 5.1.2 1024 1025 perm = 0._wp ! MV ugly dummy patch 1026 CALL ice_thd_pnd_perm(t_i(ji,jj,:,jl), sz_i(ji,jj,:,jl), perm) ! bof 1027 IF (perm > 0._wp) permflag = 1 1028 1029 drain = perm*a_ip(ji,jj,jl)*pressure_head*rDt_ice / & 1030 (viscosity*hicen(jl)) 1031 zdvolp(ji,jj) = zdvolp(ji,jj) + min(drain, zvolp(ji,jj)) 1032 zvolp(ji,jj) = max(zvolp(ji,jj) - drain, 0._wp) 1033 1034 diag_dvpn_drn(ji,jj) = - drain ! diag (could be better coded) 1035 1036 IF (zvolp(ji,jj) < epsi10) THEN 1037 zdvolp(ji,jj) = zdvolp(ji,jj) + zvolp(ji,jj) 1038 zvolp(ji,jj) = 0._wp 1039 END IF 1040 END IF 1041 END DO 1042 1043 ! adjust melt pond dimensions 1044 IF (permflag > 0) THEN 1045 ! recompute pond depth 1046 CALL ice_thd_pnd_depth(reduced_aicen, asnon, hsnon, alfan, zvolp(ji,jj), cum_max_vol, hpond, m_index) 1047 DO jl = 1, m_index 1048 h_ip(ji,jj,jl) = hpond - alfan(jl) + alfan(1) 1049 a_ip(ji,jj,jl) = reduced_aicen(jl) 1050 END DO 1051 !zapond = sum(a_ip(1:m_index)) !js: from CICE 5.1.2; not in Icepack1.1.0-6-gac6195d 1052 END IF 1053 END IF ! pressure_head 1054 1055 !------------------------------- 1056 ! remove water from the snow 1057 !------------------------------- 1058 !------------------------------------------------------------------------ 1059 ! total melt pond volume in category does not include snow volume 1060 ! snow in melt ponds is not melted 1061 !------------------------------------------------------------------------ 1062 1063 ! MV here, it seems that we remove some meltwater from the ponds, but I can't really tell 1064 ! how much, so I did not diagnose it 1065 ! so if there is a problem here, nobody is going to see it... 1066 1067 1068 ! Calculate pond volume for lower categories 1069 DO jl = 1,m_index-1 1070 v_ip(ji,jj,jl) = a_ip(ji,jj,jl) * h_ip(ji,jj,jl) & ! what is not in the snow 1071 - (rhos/rhow) * asnon(jl) * min(hsnon(jl), h_ip(ji,jj,jl)) 1072 END DO 1073 1074 ! Calculate pond volume for highest category = remaining pond volume 1075 1076 ! The following is completely unclear to Martin at least 1077 ! Could we redefine properly and recode in a more readable way ? 1078 1079 ! m_index = last category with melt pond 1080 1081 IF (m_index == 1) v_ip(ji,jj,m_index) = zvolp(ji,jj) ! volume of mw in 1st category is the total volume of melt water 1082 1083 IF (m_index > 1) THEN 1084 IF (zvolp(ji,jj) > sum( v_ip(ji,jj,1:m_index-1))) THEN 1085 v_ip(ji,jj,m_index) = zvolp(ji,jj) - sum(v_ip(ji,jj,1:m_index-1)) 1086 ELSE 1087 v_ip(ji,jj,m_index) = 0._wp 1088 h_ip(ji,jj,m_index) = 0._wp 1089 a_ip(ji,jj,m_index) = 0._wp 1090 ! If remaining pond volume is negative reduce pond volume of 1091 ! lower category 1092 IF ( zvolp(ji,jj) + epsi10 < SUM(v_ip(ji,jj,1:m_index-1))) & 1093 v_ip(ji,jj,m_index-1) = v_ip(ji,jj,m_index-1) - sum(v_ip(ji,jj,1:m_index-1)) + zvolp(ji,jj) 1094 END IF 1095 END IF 1096 1097 DO jl = 1,m_index 1098 IF (a_ip(ji,jj,jl) > epsi10) THEN 1099 h_ip(ji,jj,jl) = v_ip(ji,jj,jl) / a_ip(ji,jj,jl) 1100 ELSE 1101 zdvolp(ji,jj) = zdvolp(ji,jj) + v_ip(ji,jj,jl) 1102 h_ip(ji,jj,jl) = 0._wp 1103 v_ip(ji,jj,jl) = 0._wp 1104 a_ip(ji,jj,jl) = 0._wp 1105 END IF 1106 END DO 1107 DO jl = m_index+1, jpl 1108 h_ip(ji,jj,jl) = 0._wp 1109 a_ip(ji,jj,jl) = 0._wp 1110 v_ip(ji,jj,jl) = 0._wp 1111 END DO 1112 1113 ENDIF 1114 1115 END_2D 1116 1117 END SUBROUTINE ice_thd_pnd_area 1118 1119 1120 SUBROUTINE ice_thd_pnd_depth(aicen, asnon, hsnon, alfan, zvolp, cum_max_vol, hpond, m_index) 1121 !!------------------------------------------------------------------- 1122 !! *** ROUTINE ice_thd_pnd_depth *** 1123 !! 1124 !! ** Purpose : Compute melt pond depth 1125 !!------------------------------------------------------------------- 1126 1127 REAL (wp), DIMENSION(jpl), INTENT(IN) :: & 1128 aicen, & 1129 asnon, & 1130 hsnon, & 1131 alfan, & 1132 cum_max_vol 1133 1134 REAL (wp), INTENT(IN) :: & 1135 zvolp 1136 1137 REAL (wp), INTENT(OUT) :: & 1138 hpond 1139 1140 INTEGER, INTENT(OUT) :: & 1141 m_index 1142 1143 INTEGER :: n, ns 1144 1145 REAL (wp), DIMENSION(0:jpl+1) :: & 1146 hitl, & 1147 aicetl 1148 1149 REAL (wp) :: & 1150 rem_vol, & 1151 area, & 1152 vol, & 1153 tmp, & 1154 z0 = 0.0_wp 1155 1156 !---------------------------------------------------------------- 1157 ! hpond is zero if zvolp is zero - have we fully drained? 1158 !---------------------------------------------------------------- 1159 1160 IF (zvolp < epsi10) THEN 1161 hpond = z0 1162 m_index = 0 1163 ELSE 1164 1165 !---------------------------------------------------------------- 1166 ! Calculate the category where water fills up to 1167 !---------------------------------------------------------------- 1168 1169 !----------| 1170 ! | 1171 ! | 1172 ! |----------| -- -- 1173 !__________|__________|_________________________________________ ^ 1174 ! | | rem_vol ^ | Semi-filled 1175 ! | |----------|-- -- -- - ---|-- ---- -- -- --v layer 1176 ! | | | | 1177 ! | | | |hpond 1178 ! | | |----------| | |------- 1179 ! | | | | | | 1180 ! | | | |---v-----| 1181 ! | | m_index | | | 1182 !------------------------------------------------------------- 1183 1184 m_index = 0 ! 1:m_index categories have water in them 1185 DO n = 1, jpl 1186 IF (zvolp <= cum_max_vol(n)) THEN 1187 m_index = n 1188 IF (n == 1) THEN 1189 rem_vol = zvolp 1190 ELSE 1191 rem_vol = zvolp - cum_max_vol(n-1) 1192 END IF 1193 exit ! to break out of the loop 1194 END IF 1195 END DO 1196 m_index = min(jpl-1, m_index) 1197 1198 !---------------------------------------------------------------- 1199 ! semi-filled layer may have m_index different snow in it 1200 !---------------------------------------------------------------- 1201 1202 !----------------------------------------------------------- ^ 1203 ! | alfan(m_index+1) 1204 ! | 1205 !hitl(3)--> |----------| | 1206 !hitl(2)--> |------------| * * * * *| | 1207 !hitl(1)--> |----------|* * * * * * |* * * * * | | 1208 !hitl(0)-->------------------------------------------------- | ^ 1209 ! various snow from lower categories | |alfa(m_index) 1210 1211 ! hitl - heights of the snow layers from thinner and current categories 1212 ! aicetl - area of each snow depth in this layer 1213 1214 hitl(:) = z0 1215 aicetl(:) = z0 1216 DO n = 1, m_index 1217 hitl(n) = max(min(hsnon(n) + alfan(n) - alfan(m_index), & 1218 alfan(m_index+1) - alfan(m_index)), z0) 1219 aicetl(n) = asnon(n) 1220 1221 aicetl(0) = aicetl(0) + (aicen(n) - asnon(n)) 1222 END DO 1223 1224 hitl(m_index+1) = alfan(m_index+1) - alfan(m_index) 1225 aicetl(m_index+1) = z0 1226 1227 !---------------------------------------------------------------- 1228 ! reorder array according to hitl 1229 ! snow heights not necessarily in height order 1230 !---------------------------------------------------------------- 1231 1232 DO ns = 1, m_index+1 1233 DO n = 0, m_index - ns + 1 1234 IF (hitl(n) > hitl(n+1)) THEN ! swap order 1235 tmp = hitl(n) 1236 hitl(n) = hitl(n+1) 1237 hitl(n+1) = tmp 1238 tmp = aicetl(n) 1239 aicetl(n) = aicetl(n+1) 1240 aicetl(n+1) = tmp 1241 END IF 1242 END DO 1243 END DO 1244 1245 !---------------------------------------------------------------- 1246 ! divide semi-filled layer into set of sublayers each vertically homogenous 1247 !---------------------------------------------------------------- 1248 1249 !hitl(3)---------------------------------------------------------------- 1250 ! | * * * * * * * * 1251 ! |* * * * * * * * * 1252 !hitl(2)---------------------------------------------------------------- 1253 ! | * * * * * * * * | * * * * * * * * 1254 ! |* * * * * * * * * |* * * * * * * * * 1255 !hitl(1)---------------------------------------------------------------- 1256 ! | * * * * * * * * | * * * * * * * * | * * * * * * * * 1257 ! |* * * * * * * * * |* * * * * * * * * |* * * * * * * * * 1258 !hitl(0)---------------------------------------------------------------- 1259 ! aicetl(0) aicetl(1) aicetl(2) aicetl(3) 1260 1261 ! move up over layers incrementing volume 1262 DO n = 1, m_index+1 1263 1264 area = sum(aicetl(:)) - & ! total area of sub-layer 1265 (rhos/rho0) * sum(aicetl(n:jpl+1)) ! area of sub-layer occupied by snow 1266 1267 vol = (hitl(n) - hitl(n-1)) * area ! thickness of sub-layer times area 1268 1269 IF (vol >= rem_vol) THEN ! have reached the sub-layer with the depth within 1270 hpond = rem_vol / area + hitl(n-1) + alfan(m_index) - alfan(1) 1271 1272 exit 1273 ELSE ! still in sub-layer below the sub-layer with the depth 1274 rem_vol = rem_vol - vol 1275 END IF 1276 1277 END DO 1278 1279 END IF 1280 1281 END SUBROUTINE ice_thd_pnd_depth 1282 1283 1284 SUBROUTINE ice_thd_pnd_perm(ticen, salin, perm) 1285 !!------------------------------------------------------------------- 1286 !! *** ROUTINE ice_thd_pnd_perm *** 1287 !! 1288 !! ** Purpose : Determine the liquid fraction of brine in the ice 1289 !! and its permeability 1290 !!------------------------------------------------------------------- 1291 1292 REAL (wp), DIMENSION(nlay_i), INTENT(IN) :: & 1293 ticen, & ! internal ice temperature (K) 1294 salin ! salinity (ppt) !js: ppt according to cice 1295 1296 REAL (wp), INTENT(OUT) :: & 1297 perm ! permeability 1298 1299 REAL (wp) :: & 1300 Sbr ! brine salinity 1301 1302 REAL (wp), DIMENSION(nlay_i) :: & 1303 Tin, & ! ice temperature 1304 phi ! liquid fraction 1305 1306 INTEGER :: k 1307 1308 !----------------------------------------------------------------- 1309 ! Compute ice temperatures from enthalpies using quadratic formula 1310 !----------------------------------------------------------------- 1311 1312 DO k = 1,nlay_i 1313 Tin(k) = ticen(k) - rt0 !js: from K to degC 1314 END DO 1315 1316 !----------------------------------------------------------------- 1317 ! brine salinity and liquid fraction 1318 !----------------------------------------------------------------- 1319 1320 DO k = 1, nlay_i 1321 1322 Sbr = - Tin(k) / rTmlt ! Consistent expression with SI3 (linear liquidus) 1323 ! Best expression to date is that one (Vancoppenolle et al JGR 2019) 1324 ! Sbr = - 18.7 * Tin(k) - 0.519 * Tin(k)**2 - 0.00535 * Tin(k) **3 1325 phi(k) = salin(k) / Sbr 1326 1327 END DO 1328 1329 !----------------------------------------------------------------- 1330 ! permeability 1331 !----------------------------------------------------------------- 1332 1333 perm = 3.0e-08_wp * (minval(phi))**3 ! Golden et al. (2007) 1334 1335 END SUBROUTINE ice_thd_pnd_perm 302 1336 303 1337 SUBROUTINE ice_thd_pnd_init … … 315 1349 INTEGER :: ios, ioptio ! Local integer 316 1350 !! 317 NAMELIST/namthd_pnd/ ln_pnd, ln_pnd_LEV , rn_apnd_min, rn_apnd_max, &1351 NAMELIST/namthd_pnd/ ln_pnd, ln_pnd_LEV , rn_apnd_min, rn_apnd_max, rn_pnd_flush, & 318 1352 & ln_pnd_CST , rn_apnd, rn_hpnd, & 1353 & ln_pnd_TOPO, & 319 1354 & ln_pnd_lids, ln_pnd_alb 320 1355 !!------------------------------------------------------------------- … … 332 1367 WRITE(numout,*) ' Namelist namicethd_pnd:' 333 1368 WRITE(numout,*) ' Melt ponds activated or not ln_pnd = ', ln_pnd 1369 WRITE(numout,*) ' Topographic melt pond scheme ln_pnd_TOPO = ', ln_pnd_TOPO 334 1370 WRITE(numout,*) ' Level ice melt pond scheme ln_pnd_LEV = ', ln_pnd_LEV 335 1371 WRITE(numout,*) ' Minimum ice fraction that contributes to melt ponds rn_apnd_min = ', rn_apnd_min 336 1372 WRITE(numout,*) ' Maximum ice fraction that contributes to melt ponds rn_apnd_max = ', rn_apnd_max 1373 WRITE(numout,*) ' Pond flushing efficiency rn_pnd_flush = ', rn_pnd_flush 337 1374 WRITE(numout,*) ' Constant ice melt pond scheme ln_pnd_CST = ', ln_pnd_CST 338 1375 WRITE(numout,*) ' Prescribed pond fraction rn_apnd = ', rn_apnd … … 347 1384 IF( ln_pnd_CST ) THEN ; ioptio = ioptio + 1 ; nice_pnd = np_pndCST ; ENDIF 348 1385 IF( ln_pnd_LEV ) THEN ; ioptio = ioptio + 1 ; nice_pnd = np_pndLEV ; ENDIF 1386 IF( ln_pnd_TOPO ) THEN ; ioptio = ioptio + 1 ; nice_pnd = np_pndTOPO ; ENDIF 349 1387 IF( ioptio /= 1 ) & 350 & CALL ctl_stop( 'ice_thd_pnd_init: choose either none (ln_pnd=F) or only one pond scheme (ln_pnd_LEV or ln_pnd_CST)' )1388 & CALL ctl_stop( 'ice_thd_pnd_init: choose either none (ln_pnd=F) or only one pond scheme (ln_pnd_LEV, ln_pnd_CST or ln_pnd_TOPO)' ) 351 1389 ! 352 1390 SELECT CASE( nice_pnd ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icethd_zdf_bl99.F90
r13472 r14046 109 109 REAL(wp), DIMENSION(jpij) :: zdqns_ice_b ! derivative of the surface flux function 110 110 ! 111 REAL(wp), DIMENSION(jpij ) 112 REAL(wp), DIMENSION(jpij,nlay_i) 113 REAL(wp), DIMENSION(jpij,nlay_s) 114 REAL(wp), DIMENSION(jpij,nlay_i) 115 REAL(wp), DIMENSION(jpij,nlay_s) 116 REAL(wp), DIMENSION(jpij,0:nlay_i) 117 REAL(wp), DIMENSION(jpij,0:nlay_i) 118 REAL(wp), DIMENSION(jpij,0:nlay_i) 119 REAL(wp), DIMENSION(jpij,0:nlay_i) 120 REAL(wp), DIMENSION(jpij,0:nlay_i) 121 REAL(wp), DIMENSION(jpij,0:nlay_i) 122 REAL(wp), DIMENSION(jpij,0:nlay_s) 123 REAL(wp), DIMENSION(jpij,0:nlay_s) 124 REAL(wp), DIMENSION(jpij,0:nlay_s) 125 REAL(wp), DIMENSION(jpij,0:nlay_s) 126 REAL(wp), DIMENSION(jpij) 127 REAL(wp), DIMENSION(jpij ,nlay_i+3) :: zindterm ! 'Ind'ependent term128 REAL(wp), DIMENSION(jpij ,nlay_i+3) :: zindtbis ! Temporary 'ind'ependent term129 REAL(wp), DIMENSION(jpij ,nlay_i+3) :: zdiagbis ! Temporary 'dia'gonal term130 REAL(wp), DIMENSION(jpij ,nlay_i+3,3) :: ztrid ! Tridiagonal system terms131 REAL(wp), DIMENSION(jpij) :: zq_ini ! diag errors on heat132 REAL(wp), DIMENSION(jpij ) :: zghe ! G(he), th. conduct enhancement factor, mono-cat133 REAL(wp), DIMENSION(jpij ) :: za_s_fra ! ice fraction covered by snow134 REAL(wp), DIMENSION(jpij ) :: isnow ! snow presence (1) or not (0)135 REAL(wp), DIMENSION(jpij ) :: isnow_comb ! snow presence for met-office111 REAL(wp), DIMENSION(jpij ) :: ztsuold ! Old surface temperature in the ice 112 REAL(wp), DIMENSION(jpij,nlay_i) :: ztiold ! Old temperature in the ice 113 REAL(wp), DIMENSION(jpij,nlay_s) :: ztsold ! Old temperature in the snow 114 REAL(wp), DIMENSION(jpij,nlay_i) :: ztib ! Temporary temperature in the ice to check the convergence 115 REAL(wp), DIMENSION(jpij,nlay_s) :: ztsb ! Temporary temperature in the snow to check the convergence 116 REAL(wp), DIMENSION(jpij,0:nlay_i) :: ztcond_i ! Ice thermal conductivity 117 REAL(wp), DIMENSION(jpij,0:nlay_i) :: ztcond_i_cp ! copy 118 REAL(wp), DIMENSION(jpij,0:nlay_i) :: zradtr_i ! Radiation transmitted through the ice 119 REAL(wp), DIMENSION(jpij,0:nlay_i) :: zradab_i ! Radiation absorbed in the ice 120 REAL(wp), DIMENSION(jpij,0:nlay_i) :: zkappa_i ! Kappa factor in the ice 121 REAL(wp), DIMENSION(jpij,0:nlay_i) :: zeta_i ! Eta factor in the ice 122 REAL(wp), DIMENSION(jpij,0:nlay_s) :: zradtr_s ! Radiation transmited through the snow 123 REAL(wp), DIMENSION(jpij,0:nlay_s) :: zradab_s ! Radiation absorbed in the snow 124 REAL(wp), DIMENSION(jpij,0:nlay_s) :: zkappa_s ! Kappa factor in the snow 125 REAL(wp), DIMENSION(jpij,0:nlay_s) :: zeta_s ! Eta factor in the snow 126 REAL(wp), DIMENSION(jpij) :: zkappa_comb ! Combined snow and ice surface conductivity 127 REAL(wp), DIMENSION(jpij) :: zq_ini ! diag errors on heat 128 REAL(wp), DIMENSION(jpij) :: zghe ! G(he), th. conduct enhancement factor, mono-cat 129 REAL(wp), DIMENSION(jpij) :: za_s_fra ! ice fraction covered by snow 130 REAL(wp), DIMENSION(jpij) :: isnow ! snow presence (1) or not (0) 131 REAL(wp), DIMENSION(jpij) :: isnow_comb ! snow presence for met-office 132 REAL(wp), DIMENSION(jpij,nlay_i+nlay_s+1) :: zindterm ! 'Ind'ependent term 133 REAL(wp), DIMENSION(jpij,nlay_i+nlay_s+1) :: zindtbis ! Temporary 'ind'ependent term 134 REAL(wp), DIMENSION(jpij,nlay_i+nlay_s+1) :: zdiagbis ! Temporary 'dia'gonal term 135 REAL(wp), DIMENSION(jpij,nlay_i+nlay_s+1,3) :: ztrid ! Tridiagonal system terms 136 136 ! 137 137 ! Mono-category … … 533 533 ! Solve the tridiagonal system with Gauss elimination method. 534 534 ! Thomas algorithm, from Computational fluid Dynamics, J.D. ANDERSON, McGraw-Hill 1984 535 jm_maxt = 0 536 jm_mint = nlay_i+5 537 DO ji = 1, npti 538 jm_mint = MIN(jm_min(ji),jm_mint) 539 jm_maxt = MAX(jm_max(ji),jm_maxt) 540 END DO 541 542 DO jk = jm_mint+1, jm_maxt 543 DO ji = 1, npti 544 jm = MIN(MAX(jm_min(ji)+1,jk),jm_max(ji)) 535 !!$ jm_maxt = 0 536 !!$ jm_mint = nlay_i+5 537 !!$ DO ji = 1, npti 538 !!$ jm_mint = MIN(jm_min(ji),jm_mint) 539 !!$ jm_maxt = MAX(jm_max(ji),jm_maxt) 540 !!$ END DO 541 !!$ !!clem SNWLAY => check why LIM1D does not get this loop. Is nlay_i+5 correct? 542 !!$ 543 !!$ DO jk = jm_mint+1, jm_maxt 544 !!$ DO ji = 1, npti 545 !!$ jm = MIN(MAX(jm_min(ji)+1,jk),jm_max(ji)) 546 !!$ zdiagbis(ji,jm) = ztrid (ji,jm,2) - ztrid(ji,jm,1) * ztrid (ji,jm-1,3) / zdiagbis(ji,jm-1) 547 !!$ zindtbis(ji,jm) = zindterm(ji,jm ) - ztrid(ji,jm,1) * zindtbis(ji,jm-1 ) / zdiagbis(ji,jm-1) 548 !!$ END DO 549 !!$ END DO 550 ! clem: maybe one should find a way to reverse this loop for mpi performance 551 DO ji = 1, npti 552 jm_mint = jm_min(ji) 553 jm_maxt = jm_max(ji) 554 DO jm = jm_mint+1, jm_maxt 545 555 zdiagbis(ji,jm) = ztrid (ji,jm,2) - ztrid(ji,jm,1) * ztrid (ji,jm-1,3) / zdiagbis(ji,jm-1) 546 556 zindtbis(ji,jm) = zindterm(ji,jm ) - ztrid(ji,jm,1) * zindtbis(ji,jm-1 ) / zdiagbis(ji,jm-1) … … 564 574 END DO 565 575 576 ! snow temperatures 566 577 DO ji = 1, npti 567 578 ! Variables used after iterations 568 579 ! Value must be frozen after convergence for MPP independance reason 569 IF ( .NOT. l_T_converged(ji) ) THEN 570 ! snow temperatures 571 IF( h_s_1d(ji) > 0._wp ) THEN 572 t_s_1d(ji,nlay_s) = ( zindtbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) * t_i_1d(ji,1) ) / zdiagbis(ji,nlay_s+1) 573 ENDIF 574 ! surface temperature 580 IF ( .NOT. l_T_converged(ji) .AND. h_s_1d(ji) > 0._wp ) & 581 & t_s_1d(ji,nlay_s) = ( zindtbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) * t_i_1d(ji,1) ) / zdiagbis(ji,nlay_s+1) 582 END DO 583 !!clem SNWLAY 584 DO jm = nlay_s, 2, -1 585 DO ji = 1, npti 586 jk = jm - 1 587 IF ( .NOT. l_T_converged(ji) .AND. h_s_1d(ji) > 0._wp ) & 588 & t_s_1d(ji,jk) = ( zindtbis(ji,jm) - ztrid(ji,jm,3) * t_s_1d(ji,jk+1) ) / zdiagbis(ji,jm) 589 END DO 590 END DO 591 592 ! surface temperature 593 DO ji = 1, npti 594 IF( .NOT. l_T_converged(ji) ) THEN 575 595 ztsub(ji) = t_su_1d(ji) 576 596 IF( t_su_1d(ji) < rt0 ) THEN 577 t_su_1d(ji) = ( 578 & ( isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) *t_i_1d(ji,1) ) ) / zdiagbis(ji,jm_min(ji))597 t_su_1d(ji) = ( zindtbis(ji,jm_min(ji)) - ztrid(ji,jm_min(ji),3) * & 598 & ( isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1) ) ) / zdiagbis(ji,jm_min(ji)) 579 599 ENDIF 580 600 ENDIF 581 601 END DO 582 !clem: in order to have several layers of snow, there is a missing loop here for t_s_1d(1:nlay_s-1)583 602 ! 584 603 !-------------------------------------------------------------- … … 727 746 ! Solve the tridiagonal system with Gauss elimination method. 728 747 ! Thomas algorithm, from Computational fluid Dynamics, J.D. ANDERSON, McGraw-Hill 1984 729 jm_maxt = 0 730 jm_mint = nlay_i+5 731 DO ji = 1, npti 732 jm_mint = MIN(jm_min(ji),jm_mint) 733 jm_maxt = MAX(jm_max(ji),jm_maxt) 734 END DO 735 736 DO jk = jm_mint+1, jm_maxt 737 DO ji = 1, npti 738 jm = MIN(MAX(jm_min(ji)+1,jk),jm_max(ji)) 748 !!$ jm_maxt = 0 749 !!$ jm_mint = nlay_i+5 750 !!$ DO ji = 1, npti 751 !!$ jm_mint = MIN(jm_min(ji),jm_mint) 752 !!$ jm_maxt = MAX(jm_max(ji),jm_maxt) 753 !!$ END DO 754 !!$ 755 !!$ DO jk = jm_mint+1, jm_maxt 756 !!$ DO ji = 1, npti 757 !!$ jm = MIN(MAX(jm_min(ji)+1,jk),jm_max(ji)) 758 !!$ zdiagbis(ji,jm) = ztrid (ji,jm,2) - ztrid(ji,jm,1) * ztrid (ji,jm-1,3) / zdiagbis(ji,jm-1) 759 !!$ zindtbis(ji,jm) = zindterm(ji,jm) - ztrid(ji,jm,1) * zindtbis(ji,jm-1) / zdiagbis(ji,jm-1) 760 !!$ END DO 761 !!$ END DO 762 ! clem: maybe one should find a way to reverse this loop for mpi performance 763 DO ji = 1, npti 764 jm_mint = jm_min(ji) 765 jm_maxt = jm_max(ji) 766 DO jm = jm_mint+1, jm_maxt 739 767 zdiagbis(ji,jm) = ztrid (ji,jm,2) - ztrid(ji,jm,1) * ztrid (ji,jm-1,3) / zdiagbis(ji,jm-1) 740 zindtbis(ji,jm) = zindterm(ji,jm ) - ztrid(ji,jm,1) * zindtbis(ji,jm-1)/ zdiagbis(ji,jm-1)768 zindtbis(ji,jm) = zindterm(ji,jm ) - ztrid(ji,jm,1) * zindtbis(ji,jm-1 ) / zdiagbis(ji,jm-1) 741 769 END DO 742 770 END DO 743 771 744 772 ! ice temperatures 745 773 DO ji = 1, npti … … 761 789 ! snow temperatures 762 790 DO ji = 1, npti 763 ! Variable used after iterations791 ! Variables used after iterations 764 792 ! Value must be frozen after convergence for MPP independance reason 765 IF ( .NOT. l_T_converged(ji) ) THEN 766 IF( h_s_1d(ji) > 0._wp ) THEN 767 t_s_1d(ji,nlay_s) = ( zindtbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) * t_i_1d(ji,1) ) / zdiagbis(ji,nlay_s+1) 768 ENDIF 769 ENDIF 770 END DO 771 !clem: in order to have several layers of snow, there is a missing loop here for t_s_1d(1:nlay_s-1) 793 IF ( .NOT. l_T_converged(ji) .AND. h_s_1d(ji) > 0._wp ) & 794 & t_s_1d(ji,nlay_s) = ( zindtbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) * t_i_1d(ji,1) ) / zdiagbis(ji,nlay_s+1) 795 END DO 796 !!clem SNWLAY 797 DO jm = nlay_s, 2, -1 798 DO ji = 1, npti 799 jk = jm - 1 800 IF ( .NOT. l_T_converged(ji) .AND. h_s_1d(ji) > 0._wp ) & 801 & t_s_1d(ji,jk) = ( zindtbis(ji,jm) - ztrid(ji,jm,3) * t_s_1d(ji,jk+1) ) / zdiagbis(ji,jm) 802 END DO 803 END DO 772 804 ! 773 805 !-------------------------------------------------------------- … … 923 955 !--- Snow-ice interfacial temperature (diagnostic SIMIP) 924 956 IF( h_s_1d(ji) >= zhs_ssl ) THEN 925 t_si_1d(ji) = ( rn_cnd_s * h_i_1d(ji) * r1_nlay_i * t_s_1d(ji, 1) &926 & + ztcond_i(ji,1) * h_s_1d(ji) * r1_nlay_s * t_i_1d(ji,1) ) &957 t_si_1d(ji) = ( rn_cnd_s * h_i_1d(ji) * r1_nlay_i * t_s_1d(ji,nlay_s) & 958 & + ztcond_i(ji,1) * h_s_1d(ji) * r1_nlay_s * t_i_1d(ji,1) ) & 927 959 & / ( rn_cnd_s * h_i_1d(ji) * r1_nlay_i & 928 960 & + ztcond_i(ji,1) * h_s_1d(ji) * r1_nlay_s ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/iceupdate.F90
r13643 r14046 94 94 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 95 95 !!--------------------------------------------------------------------- 96 IF( ln_timing ) CALL timing_start('ice _update')96 IF( ln_timing ) CALL timing_start('iceupdate') 97 97 98 98 IF( kt == nit000 .AND. lwp ) THEN … … 154 154 ! ice-ocean mass flux 155 155 wfx_ice(ji,jj) = wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj) & 156 & + wfx_opw(ji,jj) + wfx_dyn(ji,jj) + wfx_res(ji,jj) + wfx_lam(ji,jj) + wfx_pnd(ji,jj)156 & + wfx_opw(ji,jj) + wfx_dyn(ji,jj) + wfx_res(ji,jj) + wfx_lam(ji,jj) 157 157 158 158 ! snw-ocean mass flux … … 160 160 161 161 ! total mass flux at the ocean/ice interface 162 fmmflx(ji,jj) = - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_ err_sub(ji,jj) ! ice-ocean mass flux saved at least for biogeochemical model163 emp (ji,jj) = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_ err_sub(ji,jj) ! atm-ocean + ice-ocean mass flux162 fmmflx(ji,jj) = - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_pnd(ji,jj) - wfx_err_sub(ji,jj) ! ice-ocean mass flux saved at least for biogeochemical model 163 emp (ji,jj) = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_pnd(ji,jj) - wfx_err_sub(ji,jj) ! atm-ocean + ice-ocean mass flux 164 164 165 165 ! Salt flux at the ocean surface … … 172 172 snwice_mass_b(ji,jj) = snwice_mass(ji,jj) ! save mass from the previous ice time step 173 173 ! ! new mass per unit area 174 snwice_mass (ji,jj) = tmask(ji,jj,1) * ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) )174 snwice_mass (ji,jj) = tmask(ji,jj,1) * ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj) + rhow * (vt_ip(ji,jj) + vt_il(ji,jj)) ) 175 175 ! ! time evolution of snow+ice mass 176 176 snwice_fmass (ji,jj) = ( snwice_mass(ji,jj) - snwice_mass_b(ji,jj) ) * r1_Dt_ice … … 286 286 IF( ln_icectl ) CALL ice_prt (kt, iiceprt, jiceprt, 3, 'Final state ice_update') ! prints 287 287 IF( sn_cfctl%l_prtctl ) CALL ice_prt3D ('iceupdate') ! prints 288 IF( ln_timing ) CALL timing_stop ('ice _update')! timing288 IF( ln_timing ) CALL timing_stop ('iceupdate') ! timing 289 289 ! 290 290 END SUBROUTINE ice_update_flx … … 324 324 REAL(wp) :: zflagi ! - - 325 325 !!--------------------------------------------------------------------- 326 IF( ln_timing ) CALL timing_start('ice_update _tau')326 IF( ln_timing ) CALL timing_start('ice_update') 327 327 328 328 IF( kt == nit000 .AND. lwp ) THEN … … 376 376 CALL lbc_lnk_multi( 'iceupdate', utau, 'U', -1.0_wp, vtau, 'V', -1.0_wp ) ! lateral boundary condition 377 377 ! 378 IF( ln_timing ) CALL timing_stop('ice_update _tau')378 IF( ln_timing ) CALL timing_stop('ice_update') 379 379 ! 380 380 END SUBROUTINE ice_update_tau -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icevar.F90
r13472 r14046 236 236 z1_zhmax = 1._wp / hi_max(jpl) 237 237 WHERE( h_i(:,:,jpl) > zhmax ) ! bound h_i by hi_max (i.e. 99 m) with associated update of ice area 238 h_i (:,:,jpl) = zhmax238 h_i (:,:,jpl) = zhmax 239 239 a_i (:,:,jpl) = v_i(:,:,jpl) * z1_zhmax 240 240 z1_a_i(:,:,jpl) = zhmax * z1_v_i(:,:,jpl) … … 252 252 ELSEWHERE( h_il(:,:,:) >= zhl_max ) ; a_ip_eff(:,:,:) = 0._wp ! lid is very thick. Cover all the pond up with ice and snow 253 253 ELSEWHERE ; a_ip_eff(:,:,:) = a_ip_frac(:,:,:) * & ! lid is in between. Expose part of the pond 254 & ( h_il(:,:,:) - zhl_min) / ( zhl_max - zhl_min )254 & ( zhl_max - h_il(:,:,:) ) / ( zhl_max - zhl_min ) 255 255 END WHERE 256 256 ! … … 534 534 DO_2D( 1, 1, 1, 1 ) 535 535 ! update exchanges with ocean 536 sfx_res(ji,jj) = sfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * sv_i(ji,jj,jl) * rhoi * r1_Dt_ice 537 wfx_res(ji,jj) = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_i (ji,jj,jl) * rhoi * r1_Dt_ice 538 wfx_res(ji,jj) = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_s (ji,jj,jl) * rhos * r1_Dt_ice 536 sfx_res(ji,jj) = sfx_res(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * sv_i(ji,jj,jl) * rhoi * r1_Dt_ice 537 wfx_res(ji,jj) = wfx_res(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * v_i (ji,jj,jl) * rhoi * r1_Dt_ice 538 wfx_res(ji,jj) = wfx_res(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * v_s (ji,jj,jl) * rhos * r1_Dt_ice 539 wfx_pnd(ji,jj) = wfx_pnd(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * ( v_ip(ji,jj,jl)+v_il(ji,jj,jl) ) * rhow * r1_Dt_ice 539 540 ! 540 541 a_i (ji,jj,jl) = a_i (ji,jj,jl) * zswitch(ji,jj) … … 551 552 v_ip (ji,jj,jl) = v_ip (ji,jj,jl) * zswitch(ji,jj) 552 553 v_il (ji,jj,jl) = v_il (ji,jj,jl) * zswitch(ji,jj) 554 h_ip (ji,jj,jl) = h_ip (ji,jj,jl) * zswitch(ji,jj) 555 h_il (ji,jj,jl) = h_il (ji,jj,jl) * zswitch(ji,jj) 553 556 ! 554 557 END_2D … … 635 638 psv_i (ji,jj,jl) = 0._wp 636 639 ENDIF 640 IF( pv_ip(ji,jj,jl) < 0._wp .OR. pv_il(ji,jj,jl) < 0._wp .OR. pa_ip(ji,jj,jl) <= 0._wp ) THEN 641 wfx_pnd(ji,jj) = wfx_pnd(ji,jj) + pv_il(ji,jj,jl) * rhow * z1_dt 642 pv_il (ji,jj,jl) = 0._wp 643 ENDIF 644 IF( pv_ip(ji,jj,jl) < 0._wp .OR. pa_ip(ji,jj,jl) <= 0._wp ) THEN 645 wfx_pnd(ji,jj) = wfx_pnd(ji,jj) + pv_ip(ji,jj,jl) * rhow * z1_dt 646 pv_ip (ji,jj,jl) = 0._wp 647 ENDIF 637 648 END_2D 638 649 ! … … 643 654 WHERE( pa_i (:,:,:) < 0._wp ) pa_i (:,:,:) = 0._wp 644 655 WHERE( pa_ip (:,:,:) < 0._wp ) pa_ip (:,:,:) = 0._wp 645 WHERE( pv_ip (:,:,:) < 0._wp ) pv_ip (:,:,:) = 0._wp ! in theory one should change wfx_pnd(-) and wfx_sum(+)646 WHERE( pv_il (:,:,:) < 0._wp ) pv_il (:,:,:) = 0._wp ! but it does not change conservation, so keep it this way is ok647 656 ! 648 657 END SUBROUTINE ice_var_zapneg … … 675 684 WHERE( pe_i (1:npti,:,:) < 0._wp ) pe_i (1:npti,:,:) = 0._wp ! e_i must be >= 0 676 685 WHERE( pe_s (1:npti,:,:) < 0._wp ) pe_s (1:npti,:,:) = 0._wp ! e_s must be >= 0 677 IF( ln_pnd_LEV ) THEN686 IF( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN 678 687 WHERE( pa_ip(1:npti,:) < 0._wp ) pa_ip(1:npti,:) = 0._wp ! a_ip must be >= 0 679 688 WHERE( pv_ip(1:npti,:) < 0._wp ) pv_ip(1:npti,:) = 0._wp ! v_ip must be >= 0 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/ICE/icewri.F90
r13472 r14046 160 160 IF( iom_use('icebrv_cat' ) ) CALL iom_put( 'icebrv_cat' , bv_i * 100. * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! brine volume 161 161 IF( iom_use('iceapnd_cat' ) ) CALL iom_put( 'iceapnd_cat' , a_ip * zmsk00l ) ! melt pond frac for categories 162 IF( iom_use('icevpnd_cat' ) ) CALL iom_put( 'icevpnd_cat' , v_ip * zmsk00l ) ! melt pond volume for categories 162 163 IF( iom_use('icehpnd_cat' ) ) CALL iom_put( 'icehpnd_cat' , h_ip * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond thickness for categories 163 164 IF( iom_use('icehlid_cat' ) ) CALL iom_put( 'icehlid_cat' , h_il * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond lid thickness for categories 164 IF( iom_use('iceafpnd_cat') ) CALL iom_put( 'iceafpnd_cat', a_ip_frac * zmsk00l ) ! melt pond frac for categories165 IF( iom_use('iceafpnd_cat') ) CALL iom_put( 'iceafpnd_cat', a_ip_frac * zmsk00l ) ! melt pond frac per ice area for categories 165 166 IF( iom_use('iceaepnd_cat') ) CALL iom_put( 'iceaepnd_cat', a_ip_eff * zmsk00l ) ! melt pond effective frac for categories 166 167 IF( iom_use('icealb_cat' ) ) CALL iom_put( 'icealb_cat' , alb_ice * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice albedo for categories -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ASM/asminc.F90
r13295 r14046 26 26 USE par_oce ! Ocean space and time domain variables 27 27 USE dom_oce ! Ocean space and time domain 28 USE domain, ONLY : dom_tile 28 29 USE domvvl ! domain: variable volume level 29 30 USE ldfdyn ! lateral diffusion: eddy viscosity coefficients … … 518 519 ! 519 520 INTEGER :: ji, jj, jk 520 INTEGER :: it 521 INTEGER :: it, itile 521 522 REAL(wp) :: zincwgt ! IAU weight for current time step 522 REAL (wp), DIMENSION(jpi,jpj,jpk) :: fzptnz ! 3d freezing point values523 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: fzptnz ! 3d freezing point values 523 524 !!---------------------------------------------------------------------- 524 525 ! 525 526 ! freezing point calculation taken from oc_fz_pt (but calculated for all depths) 526 527 ! used to prevent the applied increments taking the temperature below the local freezing point 527 DO jk = 1, jpkm1 528 CALL eos_fzp( pts(:,:,jk,jp_sal,Kmm), fzptnz(:,:,jk), gdept(:,:,jk,Kmm) ) 529 END DO 528 IF( ln_temnofreeze ) THEN 529 DO jk = 1, jpkm1 530 CALL eos_fzp( pts(:,:,jk,jp_sal,Kmm), fzptnz(:,:,jk), gdept(:,:,jk,Kmm) ) 531 END DO 532 ENDIF 530 533 ! 531 534 ! !-------------------------------------- … … 538 541 zincwgt = wgtiau(it) / rn_Dt ! IAU weight for the current time step 539 542 ! 540 IF(lwp) THEN 541 WRITE(numout,*) 542 WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 543 WRITE(numout,*) '~~~~~~~~~~~~' 543 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 544 IF(lwp) THEN 545 WRITE(numout,*) 546 WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 547 WRITE(numout,*) '~~~~~~~~~~~~' 548 ENDIF 544 549 ENDIF 545 550 ! … … 548 553 IF (ln_temnofreeze) THEN 549 554 ! Do not apply negative increments if the temperature will fall below freezing 550 WHERE(t_bkginc( :,:,jk) > 0.0_wp .OR. &551 & pts( :,:,jk,jp_tem,Kmm) + pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * wgtiau(it) > fzptnz(:,:,jk) )552 pts( :,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt555 WHERE(t_bkginc(A2D(0),jk) > 0.0_wp .OR. & 556 & pts(A2D(0),jk,jp_tem,Kmm) + pts(A2D(0),jk,jp_tem,Krhs) + t_bkginc(A2D(0),jk) * wgtiau(it) > fzptnz(:,:,jk) ) 557 pts(A2D(0),jk,jp_tem,Krhs) = pts(A2D(0),jk,jp_tem,Krhs) + t_bkginc(A2D(0),jk) * zincwgt 553 558 END WHERE 554 559 ELSE 555 pts(:,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt 560 DO_2D( 0, 0, 0, 0 ) 561 pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) + t_bkginc(ji,jj,jk) * zincwgt 562 END_2D 556 563 ENDIF 557 564 IF (ln_salfix) THEN 558 565 ! Do not apply negative increments if the salinity will fall below a specified 559 566 ! minimum value salfixmin 560 WHERE(s_bkginc( :,:,jk) > 0.0_wp .OR. &561 & pts( :,:,jk,jp_sal,Kmm) + pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * wgtiau(it) > salfixmin )562 pts( :,:,jk,jp_sal,Krhs) = pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * zincwgt567 WHERE(s_bkginc(A2D(0),jk) > 0.0_wp .OR. & 568 & pts(A2D(0),jk,jp_sal,Kmm) + pts(A2D(0),jk,jp_sal,Krhs) + s_bkginc(A2D(0),jk) * wgtiau(it) > salfixmin ) 569 pts(A2D(0),jk,jp_sal,Krhs) = pts(A2D(0),jk,jp_sal,Krhs) + s_bkginc(A2D(0),jk) * zincwgt 563 570 END WHERE 564 571 ELSE 565 pts(:,:,jk,jp_sal,Krhs) = pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * zincwgt 572 DO_2D( 0, 0, 0, 0 ) 573 pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) + s_bkginc(ji,jj,jk) * zincwgt 574 END_2D 566 575 ENDIF 567 576 END DO … … 569 578 ENDIF 570 579 ! 571 IF ( kt == nitiaufin_r + 1 ) THEN ! For bias crcn to work 572 DEALLOCATE( t_bkginc ) 573 DEALLOCATE( s_bkginc ) 580 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 581 IF ( kt == nitiaufin_r + 1 ) THEN ! For bias crcn to work 582 DEALLOCATE( t_bkginc ) 583 DEALLOCATE( s_bkginc ) 584 ENDIF 574 585 ENDIF 575 586 ! !-------------------------------------- … … 584 595 IF (ln_temnofreeze) THEN 585 596 ! Do not apply negative increments if the temperature will fall below freezing 586 WHERE( t_bkginc( :,:,:) > 0.0_wp .OR. pts(:,:,:,jp_tem,Kmm) + t_bkginc(:,:,:) > fzptnz(:,:,:) )587 pts( :,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:)597 WHERE( t_bkginc(A2D(0),:) > 0.0_wp .OR. pts(A2D(0),:,jp_tem,Kmm) + t_bkginc(A2D(0),:) > fzptnz(:,:,:) ) 598 pts(A2D(0),:,jp_tem,Kmm) = t_bkg(A2D(0),:) + t_bkginc(A2D(0),:) 588 599 END WHERE 589 600 ELSE 590 pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:) 601 DO_3D( 0, 0, 0, 0, 1, jpk ) 602 pts(ji,jj,jk,jp_tem,Kmm) = t_bkg(ji,jj,jk) + t_bkginc(ji,jj,jk) 603 END_3D 591 604 ENDIF 592 605 IF (ln_salfix) THEN 593 606 ! Do not apply negative increments if the salinity will fall below a specified 594 607 ! minimum value salfixmin 595 WHERE( s_bkginc( :,:,:) > 0.0_wp .OR. pts(:,:,:,jp_sal,Kmm) + s_bkginc(:,:,:) > salfixmin )596 pts( :,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:)608 WHERE( s_bkginc(A2D(0),:) > 0.0_wp .OR. pts(A2D(0),:,jp_sal,Kmm) + s_bkginc(A2D(0),:) > salfixmin ) 609 pts(A2D(0),:,jp_sal,Kmm) = s_bkg(A2D(0),:) + s_bkginc(A2D(0),:) 597 610 END WHERE 598 611 ELSE 599 pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:) 600 ENDIF 601 602 pts(:,:,:,:,Kbb) = pts(:,:,:,:,Kmm) ! Update before fields 612 DO_3D( 0, 0, 0, 0, 1, jpk ) 613 pts(ji,jj,jk,jp_sal,Kmm) = s_bkg(ji,jj,jk) + s_bkginc(ji,jj,jk) 614 END_3D 615 ENDIF 616 617 DO_3D( 0, 0, 0, 0, 1, jpk ) 618 pts(ji,jj,jk,:,Kbb) = pts(ji,jj,jk,:,Kmm) ! Update before fields 619 END_3D 603 620 604 621 CALL eos( pts(:,:,:,:,Kbb), rhd, rhop, gdept_0(:,:,:) ) ! Before potential and in situ densities … … 607 624 !!gm 608 625 609 IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav) & 610 & CALL zps_hde ( kt, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, & ! Partial steps: before horizontal gradient 611 & rhd, gru , grv ) ! of t, s, rd at the last ocean level 612 IF( ln_zps .AND. .NOT. lk_c1d .AND. ln_isfcav) & 613 & CALL zps_hde_isf( nit000, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF) 614 & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the last ocean level 615 616 DEALLOCATE( t_bkginc ) 617 DEALLOCATE( s_bkginc ) 618 DEALLOCATE( t_bkg ) 619 DEALLOCATE( s_bkg ) 626 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from zps_hde*) 627 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 628 itile = ntile 629 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Use full domain 630 631 IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav) & 632 & CALL zps_hde ( kt, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, & ! Partial steps: before horizontal gradient 633 & rhd, gru , grv ) ! of t, s, rd at the last ocean level 634 IF( ln_zps .AND. .NOT. lk_c1d .AND. ln_isfcav) & 635 & CALL zps_hde_isf( nit000, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF) 636 & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the last ocean level 637 638 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = itile ) ! Revert to tile domain 639 ENDIF 640 641 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 642 DEALLOCATE( t_bkginc ) 643 DEALLOCATE( s_bkginc ) 644 DEALLOCATE( t_bkg ) 645 DEALLOCATE( s_bkg ) 646 ENDIF 647 ! 620 648 ENDIF 621 649 ! … … 829 857 INTEGER, INTENT(in), OPTIONAL :: kindic ! flag for disabling the deallocation 830 858 ! 859 INTEGER :: ji, jj 831 860 INTEGER :: it 832 861 REAL(wp) :: zincwgt ! IAU weight for current time step 833 862 #if defined key_si3 834 REAL(wp), DIMENSION( jpi,jpj) :: zofrld, zohicif, zseaicendg, zhicifinc863 REAL(wp), DIMENSION(A2D(nn_hls)) :: zofrld, zohicif, zseaicendg, zhicifinc 835 864 REAL(wp) :: zhicifmin = 0.5_wp ! ice minimum depth in metres 836 865 #endif … … 847 876 ! note this is not a tendency so should not be divided by rn_Dt (as with the tracer and other increments) 848 877 ! 849 IF(lwp) THEN 850 WRITE(numout,*) 851 WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 852 WRITE(numout,*) '~~~~~~~~~~~~' 878 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 879 IF(lwp) THEN 880 WRITE(numout,*) 881 WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 882 WRITE(numout,*) '~~~~~~~~~~~~' 883 ENDIF 853 884 ENDIF 854 885 ! … … 856 887 ! 857 888 #if defined key_si3 858 zofrld (:,:) = 1._wp - at_i(:,:) 859 zohicif(:,:) = hm_i(:,:) 860 ! 861 at_i (:,:) = 1. - MIN( MAX( 1.-at_i (:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 862 at_i_b(:,:) = 1. - MIN( MAX( 1.-at_i_b(:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 863 fr_i(:,:) = at_i(:,:) ! adjust ice fraction 864 ! 865 zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:)) ! find out actual sea ice nudge applied 889 DO_2D( 0, 0, 0, 0 ) 890 zofrld (ji,jj) = 1._wp - at_i(ji,jj) 891 zohicif(ji,jj) = hm_i(ji,jj) 892 ! 893 at_i (ji,jj) = 1. - MIN( MAX( 1.-at_i (ji,jj) - seaice_bkginc(ji,jj) * zincwgt, 0.0_wp), 1.0_wp) 894 at_i_b(ji,jj) = 1. - MIN( MAX( 1.-at_i_b(ji,jj) - seaice_bkginc(ji,jj) * zincwgt, 0.0_wp), 1.0_wp) 895 fr_i(ji,jj) = at_i(ji,jj) ! adjust ice fraction 896 ! 897 zseaicendg(ji,jj) = zofrld(ji,jj) - (1. - at_i(ji,jj)) ! find out actual sea ice nudge applied 898 END_2D 866 899 ! 867 900 ! Nudge sea ice depth to bring it up to a required minimum depth 868 WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i( :,:) < zhicifmin )869 zhicifinc(:,:) = (zhicifmin - hm_i( :,:)) * zincwgt901 WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(A2D(0)) < zhicifmin ) 902 zhicifinc(:,:) = (zhicifmin - hm_i(A2D(0))) * zincwgt 870 903 ELSEWHERE 871 904 zhicifinc(:,:) = 0.0_wp … … 873 906 ! 874 907 ! nudge ice depth 875 hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:) 908 DO_2D( 0, 0, 0, 0 ) 909 hm_i (ji,jj) = hm_i (ji,jj) + zhicifinc(ji,jj) 910 END_2D 876 911 ! 877 912 ! seaice salinity balancing (to add) … … 880 915 #if defined key_cice && defined key_asminc 881 916 ! Sea-ice : CICE case. Pass ice increment tendency into CICE 882 ndaice_da(:,:) = seaice_bkginc(:,:) * zincwgt / rn_Dt 883 #endif 884 ! 885 IF ( kt == nitiaufin_r ) THEN 886 DEALLOCATE( seaice_bkginc ) 917 DO_2D( 0, 0, 0, 0 ) 918 ndaice_da(ji,jj) = seaice_bkginc(ji,jj) * zincwgt / rn_Dt 919 END_2D 920 #endif 921 ! 922 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 923 IF ( kt == nitiaufin_r ) THEN 924 DEALLOCATE( seaice_bkginc ) 925 ENDIF 887 926 ENDIF 888 927 ! … … 890 929 ! 891 930 #if defined key_cice && defined key_asminc 892 ndaice_da(:,:) = 0._wp ! Sea-ice : CICE case. Zero ice increment tendency into CICE 931 DO_2D( 0, 0, 0, 0 ) 932 ndaice_da(ji,jj) = 0._wp ! Sea-ice : CICE case. Zero ice increment tendency into CICE 933 END_2D 893 934 #endif 894 935 ! … … 905 946 ! 906 947 #if defined key_si3 907 zofrld (:,:) = 1._wp - at_i(:,:) 908 zohicif(:,:) = hm_i(:,:) 909 ! 910 ! Initialize the now fields the background + increment 911 at_i(:,:) = 1. - MIN( MAX( 1.-at_i(:,:) - seaice_bkginc(:,:), 0.0_wp), 1.0_wp) 912 at_i_b(:,:) = at_i(:,:) 913 fr_i(:,:) = at_i(:,:) ! adjust ice fraction 914 ! 915 zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:)) ! find out actual sea ice nudge applied 948 DO_2D( 0, 0, 0, 0 ) 949 zofrld (ji,jj) = 1._wp - at_i(ji,jj) 950 zohicif(ji,jj) = hm_i(ji,jj) 951 ! 952 ! Initialize the now fields the background + increment 953 at_i(ji,jj) = 1. - MIN( MAX( 1.-at_i(ji,jj) - seaice_bkginc(ji,jj), 0.0_wp), 1.0_wp) 954 at_i_b(ji,jj) = at_i(ji,jj) 955 fr_i(ji,jj) = at_i(ji,jj) ! adjust ice fraction 956 ! 957 zseaicendg(ji,jj) = zofrld(ji,jj) - (1. - at_i(ji,jj)) ! find out actual sea ice nudge applied 958 END_2D 916 959 ! 917 960 ! Nudge sea ice depth to bring it up to a required minimum depth 918 WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i( :,:) < zhicifmin )919 zhicifinc(:,:) = zhicifmin - hm_i( :,:)961 WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(A2D(0)) < zhicifmin ) 962 zhicifinc(:,:) = zhicifmin - hm_i(A2D(0)) 920 963 ELSEWHERE 921 964 zhicifinc(:,:) = 0.0_wp … … 923 966 ! 924 967 ! nudge ice depth 925 hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:) 968 DO_2D( 0, 0, 0, 0 ) 969 hm_i(ji,jj) = hm_i (ji,jj) + zhicifinc(ji,jj) 970 END_2D 926 971 ! 927 972 ! seaice salinity balancing (to add) … … 930 975 #if defined key_cice && defined key_asminc 931 976 ! Sea-ice : CICE case. Pass ice increment tendency into CICE 932 ndaice_da(:,:) = seaice_bkginc(:,:) / rn_Dt 933 #endif 934 IF ( .NOT. PRESENT(kindic) ) THEN 935 DEALLOCATE( seaice_bkginc ) 936 END IF 977 DO_2D( 0, 0, 0, 0 ) 978 ndaice_da(ji,jj) = seaice_bkginc(ji,jj) / rn_Dt 979 END_2D 980 #endif 981 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 982 IF ( .NOT. PRESENT(kindic) ) THEN 983 DEALLOCATE( seaice_bkginc ) 984 END IF 985 ENDIF 937 986 ! 938 987 ELSE 939 988 ! 940 989 #if defined key_cice && defined key_asminc 941 ndaice_da(:,:) = 0._wp ! Sea-ice : CICE case. Zero ice increment tendency into CICE 990 DO_2D( 0, 0, 0, 0 ) 991 ndaice_da(ji,jj) = 0._wp ! Sea-ice : CICE case. Zero ice increment tendency into CICE 992 END_2D 942 993 #endif 943 994 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/BDY/bdytra.F90
r13527 r14046 13 13 !!---------------------------------------------------------------------- 14 14 USE oce ! ocean dynamics and tracers variables 15 USE dom_oce ! ocean space and time domain variables 15 USE dom_oce ! ocean space and time domain variables 16 16 USE bdy_oce ! ocean open boundary conditions 17 17 USE bdylib ! for orlanski library routines … … 157 157 INTEGER :: ib_bdy ! Loop index 158 158 !!---------------------------------------------------------------------- 159 IF( ntile /= 0 .AND. ntile /= 1 ) RETURN ! Do only for the full domain 159 160 ! 160 161 IF( ln_timing ) CALL timing_start('bdy_tra_dmp') -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/C1D/step_c1d.F90
r13237 r14046 104 104 IF( ln_tradmp ) CALL tra_dmp( kstp, Nbb, Nnn, ts, Nrhs ) ! internal damping trends- tracers 105 105 IF(.NOT.ln_linssh)CALL tra_adv( kstp, Nbb, Nnn, ts, Nrhs ) ! horizontal & vertical advection 106 IF( ln_zdfmfc ) CALL tra_mfc( kstp, Nbb , ts, Nrhs ) ! Mass Flux Convection 106 107 IF( ln_zdfosm ) CALL tra_osm( kstp, Nnn , ts, Nrhs ) ! OSMOSIS non-local tracer fluxes 107 108 CALL tra_zdf( kstp, Nbb, Nnn, Nrhs, ts, Naa ) ! vertical mixing … … 122 123 CALL dyn_atf ( kstp, Nbb, Nnn, Naa , uu, vv, e3t, e3u, e3v ) ! time filtering of "now" fields 123 124 IF(.NOT.ln_linssh)CALL ssh_atf ( kstp, Nbb, Nnn, Naa , ssh ) ! time filtering of "now" sea surface height 125 IF( kstp == nit000 .AND. ln_linssh) THEN 126 ssh(:,:,Naa) = ssh(:,:,Nnn) ! init ssh after in ln_linssh case 127 ENDIF 124 128 ! 125 129 ! Swap time levels -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DIA/diaar5.F90
r13497 r14046 34 34 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,: ) :: thick0 ! ocean thickness (interior domain) 35 35 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sn0 ! initial salinity 36 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: hstr_adv, hstr_ldf 36 37 37 38 LOGICAL :: l_ar5 … … 54 55 !!---------------------------------------------------------------------- 55 56 ! 56 ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , STAT=dia_ar5_alloc ) 57 ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , & 58 & hstr_adv(jpi,jpj,jpts,2), hstr_ldf(jpi,jpj,jpts,2), STAT=dia_ar5_alloc ) 57 59 ! 58 60 CALL mpp_sum ( 'diaar5', dia_ar5_alloc ) … … 304 306 END SUBROUTINE dia_ar5 305 307 306 307 SUBROUTINE dia_ar5_hst( ktra, cptr, puflx, pvflx ) 308 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support, will not output haloes) 309 SUBROUTINE dia_ar5_hst( ktra, cptr, puflx, pvflx ) 308 310 !!---------------------------------------------------------------------- 309 311 !! *** ROUTINE dia_ar5_htr *** … … 314 316 INTEGER , INTENT(in ) :: ktra ! tracer index 315 317 CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf' 316 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in) :: puflx ! u-flux of advection/diffusion317 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in) :: pvflx ! v-flux of advection/diffusion318 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: puflx ! u-flux of advection/diffusion 319 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: pvflx ! v-flux of advection/diffusion 318 320 ! 319 321 INTEGER :: ji, jj, jk 320 REAL(wp), DIMENSION(jpi,jpj) :: z2d 321 322 323 IF( cptr /= 'adv' .AND. cptr /= 'ldf' ) RETURN 324 IF( ktra /= jp_tem .AND. ktra /= jp_sal ) RETURN 325 326 IF( cptr == 'adv' ) THEN 327 DO_2D( 0, 0, 0, 0 ) 328 hstr_adv(ji,jj,ktra,1) = puflx(ji,jj,1) 329 hstr_adv(ji,jj,ktra,2) = pvflx(ji,jj,1) 330 END_2D 331 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 332 hstr_adv(ji,jj,ktra,1) = hstr_adv(ji,jj,ktra,1) + puflx(ji,jj,jk) 333 hstr_adv(ji,jj,ktra,2) = hstr_adv(ji,jj,ktra,2) + pvflx(ji,jj,jk) 334 END_3D 335 ELSE IF( cptr == 'ldf' ) THEN 336 DO_2D( 0, 0, 0, 0 ) 337 hstr_ldf(ji,jj,ktra,1) = puflx(ji,jj,1) 338 hstr_ldf(ji,jj,ktra,2) = pvflx(ji,jj,1) 339 END_2D 340 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 341 hstr_ldf(ji,jj,ktra,1) = hstr_ldf(ji,jj,ktra,1) + puflx(ji,jj,jk) 342 hstr_ldf(ji,jj,ktra,2) = hstr_ldf(ji,jj,ktra,2) + pvflx(ji,jj,jk) 343 END_3D 344 ENDIF 345 346 IF( ntile == 0 .OR. ntile == nijtile ) THEN 347 IF( cptr == 'adv' ) THEN 348 IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * hstr_adv(:,:,ktra,1) ) ! advective heat transport in i-direction 349 IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0 * hstr_adv(:,:,ktra,1) ) ! advective salt transport in i-direction 350 IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * hstr_adv(:,:,ktra,2) ) ! advective heat transport in j-direction 351 IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0 * hstr_adv(:,:,ktra,2) ) ! advective salt transport in j-direction 352 ENDIF 353 IF( cptr == 'ldf' ) THEN 354 IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * hstr_ldf(:,:,ktra,1) ) ! diffusive heat transport in i-direction 355 IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0 * hstr_ldf(:,:,ktra,1) ) ! diffusive salt transport in i-direction 356 IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * hstr_ldf(:,:,ktra,2) ) ! diffusive heat transport in j-direction 357 IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0 * hstr_ldf(:,:,ktra,2) ) ! diffusive salt transport in j-direction 358 ENDIF 359 ENDIF 322 360 323 z2d(:,:) = puflx(:,:,1)324 DO_3D( 0, 0, 0, 0, 1, jpkm1 )325 z2d(ji,jj) = z2d(ji,jj) + puflx(ji,jj,jk)326 END_3D327 CALL lbc_lnk( 'diaar5', z2d, 'U', -1.0_wp )328 IF( cptr == 'adv' ) THEN329 IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in i-direction330 IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0 * z2d ) ! advective salt transport in i-direction331 ENDIF332 IF( cptr == 'ldf' ) THEN333 IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * z2d ) ! diffusive heat transport in i-direction334 IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0 * z2d ) ! diffusive salt transport in i-direction335 ENDIF336 !337 z2d(:,:) = pvflx(:,:,1)338 DO_3D( 0, 0, 0, 0, 1, jpkm1 )339 z2d(ji,jj) = z2d(ji,jj) + pvflx(ji,jj,jk)340 END_3D341 CALL lbc_lnk( 'diaar5', z2d, 'V', -1.0_wp )342 IF( cptr == 'adv' ) THEN343 IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in j-direction344 IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0 * z2d ) ! advective salt transport in j-direction345 ENDIF346 IF( cptr == 'ldf' ) THEN347 IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * z2d ) ! diffusive heat transport in j-direction348 IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0 * z2d ) ! diffusive salt transport in j-direction349 ENDIF350 351 361 END SUBROUTINE dia_ar5_hst 352 362 … … 371 381 & iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) .OR. & 372 382 & iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) .OR. & 383 & iom_use( 'uadv_heattr' ) .OR. iom_use( 'udiff_heattr' ) .OR. & 384 & iom_use( 'uadv_salttr' ) .OR. iom_use( 'udiff_salttr' ) .OR. & 385 & iom_use( 'vadv_heattr' ) .OR. iom_use( 'vdiff_heattr' ) .OR. & 386 & iom_use( 'vadv_salttr' ) .OR. iom_use( 'vdiff_salttr' ) .OR. & 373 387 & iom_use( 'rhop' ) ) L_ar5 = .TRUE. 374 388 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DIA/diahsb.F90
r13286 r14046 267 267 IF(lwp) WRITE(numout,*) ' dia_hsb_rst : read hsb restart at it= ', kt,' date= ', ndastp 268 268 IF(lwp) WRITE(numout,*) 269 CALL iom_get( numror, 'frc_v', frc_v , ldxios = lrxios)270 CALL iom_get( numror, 'frc_t', frc_t , ldxios = lrxios)271 CALL iom_get( numror, 'frc_s', frc_s , ldxios = lrxios)269 CALL iom_get( numror, 'frc_v', frc_v ) 270 CALL iom_get( numror, 'frc_t', frc_t ) 271 CALL iom_get( numror, 'frc_s', frc_s ) 272 272 IF( ln_linssh ) THEN 273 CALL iom_get( numror, 'frc_wn_t', frc_wn_t , ldxios = lrxios)274 CALL iom_get( numror, 'frc_wn_s', frc_wn_s , ldxios = lrxios)273 CALL iom_get( numror, 'frc_wn_t', frc_wn_t ) 274 CALL iom_get( numror, 'frc_wn_s', frc_wn_s ) 275 275 ENDIF 276 CALL iom_get( numror, jpdom_auto, 'surf_ini' , surf_ini , ldxios = lrxios) ! ice sheet coupling277 CALL iom_get( numror, jpdom_auto, 'ssh_ini' , ssh_ini , ldxios = lrxios)278 CALL iom_get( numror, jpdom_auto, 'e3t_ini' , e3t_ini , ldxios = lrxios)279 CALL iom_get( numror, jpdom_auto, 'tmask_ini' , tmask_ini , ldxios = lrxios)280 CALL iom_get( numror, jpdom_auto, 'hc_loc_ini', hc_loc_ini , ldxios = lrxios)281 CALL iom_get( numror, jpdom_auto, 'sc_loc_ini', sc_loc_ini , ldxios = lrxios)276 CALL iom_get( numror, jpdom_auto, 'surf_ini' , surf_ini ) ! ice sheet coupling 277 CALL iom_get( numror, jpdom_auto, 'ssh_ini' , ssh_ini ) 278 CALL iom_get( numror, jpdom_auto, 'e3t_ini' , e3t_ini ) 279 CALL iom_get( numror, jpdom_auto, 'tmask_ini' , tmask_ini ) 280 CALL iom_get( numror, jpdom_auto, 'hc_loc_ini', hc_loc_ini ) 281 CALL iom_get( numror, jpdom_auto, 'sc_loc_ini', sc_loc_ini ) 282 282 IF( ln_linssh ) THEN 283 CALL iom_get( numror, jpdom_auto, 'ssh_hc_loc_ini', ssh_hc_loc_ini , ldxios = lrxios)284 CALL iom_get( numror, jpdom_auto, 'ssh_sc_loc_ini', ssh_sc_loc_ini , ldxios = lrxios)283 CALL iom_get( numror, jpdom_auto, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) 284 CALL iom_get( numror, jpdom_auto, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) 285 285 ENDIF 286 286 ELSE … … 323 323 IF(lwp) WRITE(numout,*) 324 324 ! 325 IF( lwxios ) CALL iom_swap( cwxios_context ) 326 CALL iom_rstput( kt, nitrst, numrow, 'frc_v', frc_v, ldxios = lwxios ) 327 CALL iom_rstput( kt, nitrst, numrow, 'frc_t', frc_t, ldxios = lwxios ) 328 CALL iom_rstput( kt, nitrst, numrow, 'frc_s', frc_s, ldxios = lwxios ) 325 CALL iom_rstput( kt, nitrst, numrow, 'frc_v', frc_v ) 326 CALL iom_rstput( kt, nitrst, numrow, 'frc_t', frc_t ) 327 CALL iom_rstput( kt, nitrst, numrow, 'frc_s', frc_s ) 329 328 IF( ln_linssh ) THEN 330 CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_t', frc_wn_t , ldxios = lwxios)331 CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s , ldxios = lwxios)329 CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_t', frc_wn_t ) 330 CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s ) 332 331 ENDIF 333 CALL iom_rstput( kt, nitrst, numrow, 'surf_ini' , surf_ini , ldxios = lwxios) ! ice sheet coupling334 CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini' , ssh_ini , ldxios = lwxios)335 CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini' , e3t_ini , ldxios = lwxios)336 CALL iom_rstput( kt, nitrst, numrow, 'tmask_ini' , tmask_ini , ldxios = lwxios)337 CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini , ldxios = lwxios)338 CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini , ldxios = lwxios)332 CALL iom_rstput( kt, nitrst, numrow, 'surf_ini' , surf_ini ) ! ice sheet coupling 333 CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini' , ssh_ini ) 334 CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini' , e3t_ini ) 335 CALL iom_rstput( kt, nitrst, numrow, 'tmask_ini' , tmask_ini ) 336 CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini ) 337 CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini ) 339 338 IF( ln_linssh ) THEN 340 CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini , ldxios = lwxios)341 CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini , ldxios = lwxios)339 CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) 340 CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) 342 341 ENDIF 343 IF( lwxios ) CALL iom_swap( cxios_context )344 342 ! 345 343 ENDIF … … 385 383 IF( .NOT. ln_diahsb ) RETURN 386 384 387 IF(lwxios) THEN388 ! define variables in restart file when writing with XIOS389 CALL iom_set_rstw_var_active('frc_v')390 CALL iom_set_rstw_var_active('frc_t')391 CALL iom_set_rstw_var_active('frc_s')392 CALL iom_set_rstw_var_active('surf_ini')393 CALL iom_set_rstw_var_active('ssh_ini')394 CALL iom_set_rstw_var_active('e3t_ini')395 CALL iom_set_rstw_var_active('hc_loc_ini')396 CALL iom_set_rstw_var_active('sc_loc_ini')397 IF( ln_linssh ) THEN398 CALL iom_set_rstw_var_active('ssh_hc_loc_ini')399 CALL iom_set_rstw_var_active('ssh_sc_loc_ini')400 CALL iom_set_rstw_var_active('frc_wn_t')401 CALL iom_set_rstw_var_active('frc_wn_s')402 ENDIF403 ENDIF404 385 ! ------------------- ! 405 386 ! 1 - Allocate memory ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DIA/diaptr.F90
r13557 r14046 22 22 USE oce ! ocean dynamics and active tracers 23 23 USE dom_oce ! ocean space and time domain 24 USE domain, ONLY : dom_tile 24 25 USE phycst ! physical constants 25 26 ! … … 32 33 PRIVATE 33 34 35 INTERFACE ptr_sum 36 MODULE PROCEDURE ptr_sum_3d, ptr_sum_2d 37 END INTERFACE 38 34 39 INTERFACE ptr_sj 35 40 MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d … … 39 44 PUBLIC dia_ptr_hst ! called from tra_ldf/tra_adv routines 40 45 41 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) 42 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) 43 44 LOGICAL, PUBLIC :: l_diaptr !: tracers trend flag 46 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) 47 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) 48 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: pvtr_int, pzon_int !: Other zonal integrals 49 50 LOGICAL, PUBLIC :: l_diaptr !: tracers trend flag 51 INTEGER, PARAMETER :: jp_msk = 3 52 INTEGER, PARAMETER :: jp_vtr = 4 45 53 46 54 REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup … … 51 59 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S) 52 60 53 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:) :: p_fval1d54 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d55 56 61 LOGICAL :: ll_init = .TRUE. !: tracers trend flag 57 62 58 63 !! * Substitutions 59 64 # include "do_loop_substitute.h90" … … 72 77 INTEGER , INTENT(in) :: kt ! ocean time-step index 73 78 INTEGER , INTENT(in) :: Kmm ! time level index 74 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport 79 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport 80 !!---------------------------------------------------------------------- 81 ! 82 IF( ln_timing ) CALL timing_start('dia_ptr') 83 84 IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init ! -> will define l_diaptr and nbasin 85 ! 86 IF( l_diaptr ) THEN 87 ! Calculate zonal integrals 88 IF( PRESENT( pvtr ) ) THEN 89 CALL dia_ptr_zint( Kmm, pvtr ) 90 ELSE 91 CALL dia_ptr_zint( Kmm ) 92 ENDIF 93 94 ! Calculate diagnostics only when zonal integrals have finished 95 IF( ntile == 0 .OR. ntile == nijtile ) CALL dia_ptr_iom(kt, Kmm, pvtr) 96 ENDIF 97 98 IF( ln_timing ) CALL timing_stop('dia_ptr') 99 ! 100 END SUBROUTINE dia_ptr 101 102 103 SUBROUTINE dia_ptr_iom( kt, Kmm, pvtr ) 104 !!---------------------------------------------------------------------- 105 !! *** ROUTINE dia_ptr_iom *** 106 !!---------------------------------------------------------------------- 107 !! ** Purpose : Calculate diagnostics and send to XIOS 108 !!---------------------------------------------------------------------- 109 INTEGER , INTENT(in) :: kt ! ocean time-step index 110 INTEGER , INTENT(in) :: Kmm ! time level index 111 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport 75 112 ! 76 113 INTEGER :: ji, jj, jk, jn ! dummy loop indices 77 REAL(wp) :: zsfc,zvfc ! local scalar78 114 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 79 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace80 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace81 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace82 115 REAL(wp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace 83 116 ! … … 90 123 !!---------------------------------------------------------------------- 91 124 ! 92 IF( ln_timing ) CALL timing_start('dia_ptr')93 94 IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init ! -> will define l_diaptr and nbasin95 !96 IF( .NOT. l_diaptr ) THEN97 IF( ln_timing ) CALL timing_stop('dia_ptr')98 RETURN99 ENDIF100 !101 125 ALLOCATE( z3dtr(jpi,jpj,nbasin) ) 102 ! 126 103 127 IF( PRESENT( pvtr ) ) THEN 104 128 IF( iom_use( 'zomsf' ) ) THEN ! effective MSF 105 129 ALLOCATE( z4d1(jpi,jpj,jpk,nbasin) ) 130 ! 106 131 DO jn = 1, nbasin ! by sub-basins 107 z4d1(1,:,:,jn) = p tr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )! zonal cumulative effective transport excluding closed seas108 DO jk = jpkm1, 1, -1 132 z4d1(1,:,:,jn) = pvtr_int(:,:,jp_vtr,jn) ! zonal cumulative effective transport excluding closed seas 133 DO jk = jpkm1, 1, -1 109 134 z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn) ! effective j-Stream-Function (MSF) 110 135 END DO 111 DO ji = 1, jpi136 DO ji = 2, jpi 112 137 z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) 113 138 ENDDO 114 139 END DO 115 140 CALL iom_put( 'zomsf', z4d1 * rc_sv ) 141 ! 116 142 DEALLOCATE( z4d1 ) 117 143 ENDIF 144 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 145 ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin), & 146 & zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) ) 147 ! 148 DO jn = 1, nbasin 149 sjk(:,:,jn) = pvtr_int(:,:,jp_msk,jn) 150 r1_sjk(:,:,jn) = 0._wp 151 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 152 ! i-mean T and S, j-Stream-Function, basin 153 zt_jk(:,:,jn) = pvtr_int(:,:,jp_tem,jn) * r1_sjk(:,:,jn) 154 zs_jk(:,:,jn) = pvtr_int(:,:,jp_sal,jn) * r1_sjk(:,:,jn) 155 v_msf(:,:,jn) = pvtr_int(:,:,jp_vtr,jn) 156 hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 157 hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) 158 ! 159 ENDDO 160 DO jn = 1, nbasin 161 z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 162 DO ji = 2, jpi 163 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 164 ENDDO 165 ENDDO 166 CALL iom_put( 'sophtove', z3dtr ) 167 DO jn = 1, nbasin 168 z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 169 DO ji = 2, jpi 170 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 171 ENDDO 172 ENDDO 173 CALL iom_put( 'sopstove', z3dtr ) 174 ! 175 DEALLOCATE( sjk, r1_sjk, v_msf, zt_jk, zs_jk ) 176 ENDIF 177 178 IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 179 ! Calculate barotropic heat and salt transport here 180 ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) ) 181 ! 182 DO jn = 1, nbasin 183 sjk(:,1,jn) = SUM( pvtr_int(:,:,jp_msk,jn), 2 ) 184 r1_sjk(:,1,jn) = 0._wp 185 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 186 ! 187 zvsum(:) = SUM( pvtr_int(:,:,jp_vtr,jn), 2 ) 188 ztsum(:) = SUM( pvtr_int(:,:,jp_tem,jn), 2 ) 189 zssum(:) = SUM( pvtr_int(:,:,jp_sal,jn), 2 ) 190 hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 191 hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) 192 ! 193 ENDDO 194 DO jn = 1, nbasin 195 z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 196 DO ji = 2, jpi 197 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 198 ENDDO 199 ENDDO 200 CALL iom_put( 'sophtbtr', z3dtr ) 201 DO jn = 1, nbasin 202 z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 203 DO ji = 2, jpi 204 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 205 ENDDO 206 ENDDO 207 CALL iom_put( 'sopstbtr', z3dtr ) 208 ! 209 DEALLOCATE( sjk, r1_sjk ) 210 ENDIF 211 ! 212 hstr_ove(:,:,:) = 0._wp ! Zero before next timestep 213 hstr_btr(:,:,:) = 0._wp 214 pvtr_int(:,:,:,:) = 0._wp 215 ELSE 216 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface 217 ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) ) 218 ! 219 DO jn = 1, nbasin 220 z4d1(1,:,:,jn) = pzon_int(:,:,jp_msk,jn) 221 DO ji = 2, jpi 222 z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) 223 ENDDO 224 ENDDO 225 CALL iom_put( 'zosrf', z4d1 ) 226 ! 227 DO jn = 1, nbasin 228 z4d2(1,:,:,jn) = pzon_int(:,:,jp_tem,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) 229 DO ji = 2, jpi 230 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 231 ENDDO 232 ENDDO 233 CALL iom_put( 'zotem', z4d2 ) 234 ! 235 DO jn = 1, nbasin 236 z4d2(1,:,:,jn) = pzon_int(:,:,jp_sal,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) 237 DO ji = 2, jpi 238 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 239 ENDDO 240 ENDDO 241 CALL iom_put( 'zosal', z4d2 ) 242 ! 243 DEALLOCATE( z4d1, z4d2 ) 244 ENDIF 245 ! 246 ! ! Advective and diffusive heat and salt transport 247 IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN 248 ! 249 DO jn = 1, nbasin 250 z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 251 DO ji = 2, jpi 252 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 253 ENDDO 254 ENDDO 255 CALL iom_put( 'sophtadv', z3dtr ) 256 DO jn = 1, nbasin 257 z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 258 DO ji = 2, jpi 259 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 260 ENDDO 261 ENDDO 262 CALL iom_put( 'sopstadv', z3dtr ) 263 ENDIF 264 ! 265 IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN 266 ! 267 DO jn = 1, nbasin 268 z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 269 DO ji = 2, jpi 270 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 271 ENDDO 272 ENDDO 273 CALL iom_put( 'sophtldf', z3dtr ) 274 DO jn = 1, nbasin 275 z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 276 DO ji = 2, jpi 277 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 278 ENDDO 279 ENDDO 280 CALL iom_put( 'sopstldf', z3dtr ) 281 ENDIF 282 ! 283 IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN 284 ! 285 DO jn = 1, nbasin 286 z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 287 DO ji = 2, jpi 288 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 289 ENDDO 290 ENDDO 291 CALL iom_put( 'sophteiv', z3dtr ) 292 DO jn = 1, nbasin 293 z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 294 DO ji = 2, jpi 295 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 296 ENDDO 297 ENDDO 298 CALL iom_put( 'sopsteiv', z3dtr ) 299 ENDIF 300 ! 301 IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 302 DO jn = 1, nbasin 303 z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 304 DO ji = 2, jpi 305 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 306 ENDDO 307 ENDDO 308 CALL iom_put( 'sophtvtr', z3dtr ) 309 DO jn = 1, nbasin 310 z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 311 DO ji = 2, jpi 312 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 313 ENDDO 314 ENDDO 315 CALL iom_put( 'sopstvtr', z3dtr ) 316 ENDIF 317 ! 318 IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN 319 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Use full domain 320 CALL iom_get_var( 'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml 321 z2d(:,:) = ptr_ci_2d( z2d(:,:) ) 322 CALL iom_put( 'uocetr_vsum_cumul', z2d ) 323 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = nijtile ) ! Revert to tile domain 324 ENDIF 325 ! 326 hstr_adv(:,:,:) = 0._wp ! Zero before next timestep 327 hstr_ldf(:,:,:) = 0._wp 328 hstr_eiv(:,:,:) = 0._wp 329 hstr_vtr(:,:,:) = 0._wp 330 pzon_int(:,:,:,:) = 0._wp 331 ENDIF 332 ! 333 DEALLOCATE( z3dtr ) 334 ! 335 END SUBROUTINE dia_ptr_iom 336 337 338 SUBROUTINE dia_ptr_zint( Kmm, pvtr ) 339 !!---------------------------------------------------------------------- 340 !! *** ROUTINE dia_ptr_zint *** 341 !!---------------------------------------------------------------------- 342 !! ** Purpose : i and i-k sum operations on arrays 343 !! 344 !! ** Method : - Call ptr_sjk (i sum) or ptr_sj (i-k sum) to perform the sum operation 345 !! - Call ptr_sum to add this result to the sum over tiles 346 !! 347 !! ** Action : pvtr_int - terms for volume streamfunction, heat/salt transport barotropic/overturning terms 348 !! pzon_int - terms for i mean temperature/salinity 349 !!---------------------------------------------------------------------- 350 INTEGER , INTENT(in) :: Kmm ! time level index 351 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport 352 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zmask ! 3D workspace 353 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zts ! 4D workspace 354 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: sjk, v_msf ! Zonal sum: i-k surface area, j-effective transport 355 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt_jk, zs_jk ! Zonal sum: i-k surface area * (T, S) 356 REAL(wp) :: zsfc, zvfc ! i-k surface area 357 INTEGER :: ji, jj, jk, jn ! dummy loop indices 358 !!---------------------------------------------------------------------- 359 360 IF( PRESENT( pvtr ) ) THEN 361 ! i sum of effective j transport excluding closed seas 362 IF( iom_use( 'zomsf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 363 ALLOCATE( v_msf(A1Dj(nn_hls),jpk,nbasin) ) 364 365 DO jn = 1, nbasin 366 v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) 367 ENDDO 368 369 CALL ptr_sum( pvtr_int(:,:,jp_vtr,:), v_msf(:,:,:) ) 370 371 DEALLOCATE( v_msf ) 372 ENDIF 373 374 ! i sum of j surface area, j surface area - temperature/salinity product on V grid 118 375 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 119 376 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 120 ! define fields multiplied by scalar 377 ALLOCATE( zmask(A2D(nn_hls),jpk), zts(A2D(nn_hls),jpk,jpts), & 378 & sjk(A1Dj(nn_hls),jpk,nbasin), & 379 & zt_jk(A1Dj(nn_hls),jpk,nbasin), zs_jk(A1Dj(nn_hls),jpk,nbasin) ) 380 121 381 zmask(:,:,:) = 0._wp 122 382 zts(:,:,:,:) = 0._wp 383 123 384 DO_3D( 1, 0, 1, 1, 1, jpkm1 ) 124 385 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 125 386 zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc 126 zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc 387 zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid 127 388 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 128 389 END_3D 129 ENDIF 130 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 131 DO jn = 1, nbasin 132 ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin), & 133 & zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) ) 134 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 135 r1_sjk(:,:,jn) = 0._wp 136 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 137 ! i-mean T and S, j-Stream-Function, basin 138 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 139 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 140 v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) 141 hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 142 hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) 143 DEALLOCATE( sjk, r1_sjk, v_msf, zt_jk, zs_jk ) 144 ! 145 ENDDO 146 DO jn = 1, nbasin 147 z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 148 DO ji = 1, jpi 149 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 150 ENDDO 151 ENDDO 152 CALL iom_put( 'sophtove', z3dtr ) 153 DO jn = 1, nbasin 154 z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 155 DO ji = 1, jpi 156 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 157 ENDDO 158 ENDDO 159 CALL iom_put( 'sopstove', z3dtr ) 160 ENDIF 161 162 IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 163 ! Calculate barotropic heat and salt transport here 164 DO jn = 1, nbasin 165 ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) ) 166 sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 167 r1_sjk(:,1,jn) = 0._wp 168 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 169 ! 170 zvsum(:) = ptr_sj( pvtr(:,:,:), btmsk34(:,:,jn) ) 171 ztsum(:) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 172 zssum(:) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 173 hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 174 hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) 175 DEALLOCATE( sjk, r1_sjk ) 176 ! 177 ENDDO 178 DO jn = 1, nbasin 179 z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 180 DO ji = 1, jpi 181 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 182 ENDDO 183 ENDDO 184 CALL iom_put( 'sophtbtr', z3dtr ) 185 DO jn = 1, nbasin 186 z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 187 DO ji = 1, jpi 188 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 189 ENDDO 190 ENDDO 191 CALL iom_put( 'sopstbtr', z3dtr ) 192 ENDIF 193 ! 390 391 DO jn = 1, nbasin 392 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:) , btmsk(:,:,jn) ) 393 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 394 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 395 ENDDO 396 397 CALL ptr_sum( pvtr_int(:,:,jp_msk,:), sjk(:,:,:) ) 398 CALL ptr_sum( pvtr_int(:,:,jp_tem,:), zt_jk(:,:,:) ) 399 CALL ptr_sum( pvtr_int(:,:,jp_sal,:), zs_jk(:,:,:) ) 400 401 DEALLOCATE( zmask, zts, sjk, zt_jk, zs_jk ) 402 ENDIF 194 403 ELSE 195 ! 196 zmask(:,:,:) = 0._wp 197 zts(:,:,:,:) = 0._wp 198 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface 199 ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) ) 404 ! i sum of j surface area - temperature/salinity product on T grid 405 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN 406 ALLOCATE( zmask(A2D(nn_hls),jpk), zts(A2D(nn_hls),jpk,jpts), & 407 & sjk(A1Dj(nn_hls),jpk,nbasin), & 408 & zt_jk(A1Dj(nn_hls),jpk,nbasin), zs_jk(A1Dj(nn_hls),jpk,nbasin) ) 409 410 zmask(:,:,:) = 0._wp 411 zts(:,:,:,:) = 0._wp 412 200 413 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 201 414 zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) … … 204 417 zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc 205 418 END_3D 206 ! 207 DO jn = 1, nbasin 208 zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 209 DO ji = 1, jpi 210 zmask(ji,:,:) = zmask(1,:,:) 211 ENDDO 212 z4d1(:,:,:,jn) = zmask(:,:,:) 213 ENDDO 214 CALL iom_put( 'zosrf', z4d1 ) 215 ! 216 DO jn = 1, nbasin 217 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 218 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) 219 DO ji = 1, jpi 220 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 221 ENDDO 222 ENDDO 223 CALL iom_put( 'zotem', z4d2 ) 224 ! 225 DO jn = 1, nbasin 226 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 227 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) 228 DO ji = 1, jpi 229 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 230 ENDDO 231 ENDDO 232 CALL iom_put( 'zosal', z4d2 ) 233 DEALLOCATE( z4d1, z4d2 ) 234 ! 235 ENDIF 236 ! 237 ! ! Advective and diffusive heat and salt transport 238 IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN 239 ! 240 DO jn = 1, nbasin 241 z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 242 DO ji = 1, jpi 243 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 244 ENDDO 245 ENDDO 246 CALL iom_put( 'sophtadv', z3dtr ) 247 DO jn = 1, nbasin 248 z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 249 DO ji = 1, jpi 250 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 251 ENDDO 252 ENDDO 253 CALL iom_put( 'sopstadv', z3dtr ) 254 ENDIF 255 ! 256 IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN 257 ! 258 DO jn = 1, nbasin 259 z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 260 DO ji = 1, jpi 261 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 262 ENDDO 263 ENDDO 264 CALL iom_put( 'sophtldf', z3dtr ) 265 DO jn = 1, nbasin 266 z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 267 DO ji = 1, jpi 268 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 269 ENDDO 270 ENDDO 271 CALL iom_put( 'sopstldf', z3dtr ) 272 ENDIF 273 ! 274 IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN 275 ! 276 DO jn = 1, nbasin 277 z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 278 DO ji = 1, jpi 279 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 280 ENDDO 281 ENDDO 282 CALL iom_put( 'sophteiv', z3dtr ) 283 DO jn = 1, nbasin 284 z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 285 DO ji = 1, jpi 286 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 287 ENDDO 288 ENDDO 289 CALL iom_put( 'sopsteiv', z3dtr ) 290 ENDIF 291 ! 419 420 DO jn = 1, nbasin 421 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:) , btmsk(:,:,jn) ) 422 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 423 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 424 ENDDO 425 426 CALL ptr_sum( pzon_int(:,:,jp_msk,:), sjk(:,:,:) ) 427 CALL ptr_sum( pzon_int(:,:,jp_tem,:), zt_jk(:,:,:) ) 428 CALL ptr_sum( pzon_int(:,:,jp_sal,:), zs_jk(:,:,:) ) 429 430 DEALLOCATE( zmask, zts, sjk, zt_jk, zs_jk ) 431 ENDIF 432 433 ! i-k sum of j surface area - temperature/salinity product on V grid 292 434 IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 435 ALLOCATE( zts(A2D(nn_hls),jpk,jpts) ) 436 293 437 zts(:,:,:,:) = 0._wp 438 294 439 DO_3D( 1, 0, 1, 1, 1, jpkm1 ) 295 440 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) … … 297 442 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 298 443 END_3D 299 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 300 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 301 DO jn = 1, nbasin 302 z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 303 DO ji = 1, jpi 304 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 305 ENDDO 306 ENDDO 307 CALL iom_put( 'sophtvtr', z3dtr ) 308 DO jn = 1, nbasin 309 z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 310 DO ji = 1, jpi 311 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 312 ENDDO 313 ENDDO 314 CALL iom_put( 'sopstvtr', z3dtr ) 315 ENDIF 316 ! 317 IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN 318 CALL iom_get_var( 'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml 319 z2d(:,:) = ptr_ci_2d( z2d(:,:) ) 320 CALL iom_put( 'uocetr_vsum_cumul', z2d ) 321 ENDIF 322 ! 444 445 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 446 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 447 448 DEALLOCATE( zts ) 449 ENDIF 323 450 ENDIF 324 ! 325 DEALLOCATE( z3dtr ) 326 ! 327 IF( ln_timing ) CALL timing_stop('dia_ptr') 328 ! 329 END SUBROUTINE dia_ptr 451 END SUBROUTINE dia_ptr_zint 330 452 331 453 … … 340 462 REAL(wp), DIMENSION(jpi,jpj) :: zmsk 341 463 !!---------------------------------------------------------------------- 342 464 343 465 ! l_diaptr is defined with iom_use 344 466 ! --> dia_ptr_init must be done after the call to iom_init … … 347 469 & iom_use( 'zosrf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 348 470 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR. & 349 & iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. & 471 & iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. & 350 472 & iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR. & 351 & iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) 352 473 & iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) 474 353 475 IF(lwp) THEN ! Control print 354 476 WRITE(numout,*) … … 398 520 hstr_btr(:,:,:) = 0._wp ! 399 521 hstr_vtr(:,:,:) = 0._wp ! 522 pvtr_int(:,:,:,:) = 0._wp 523 pzon_int(:,:,:,:) = 0._wp 400 524 ! 401 525 ll_init = .FALSE. … … 415 539 INTEGER , INTENT(in ) :: ktra ! tracer index 416 540 CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv' 417 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pvflx ! 3D input array of advection/diffusion 541 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: pvflx ! 3D input array of advection/diffusion 542 REAL(wp), DIMENSION(A1Dj(nn_hls),nbasin) :: zsj ! 418 543 INTEGER :: jn ! 419 544 545 DO jn = 1, nbasin 546 zsj(:,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 547 ENDDO 420 548 ! 421 549 IF( cptr == 'adv' ) THEN 422 IF( ktra == jp_tem ) THEN 423 DO jn = 1, nbasin 424 hstr_adv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 425 ENDDO 426 ENDIF 427 IF( ktra == jp_sal ) THEN 428 DO jn = 1, nbasin 429 hstr_adv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 430 ENDDO 431 ENDIF 550 IF( ktra == jp_tem ) CALL ptr_sum( hstr_adv(:,jp_tem,:), zsj(:,:) ) 551 IF( ktra == jp_sal ) CALL ptr_sum( hstr_adv(:,jp_sal,:), zsj(:,:) ) 552 ELSE IF( cptr == 'ldf' ) THEN 553 IF( ktra == jp_tem ) CALL ptr_sum( hstr_ldf(:,jp_tem,:), zsj(:,:) ) 554 IF( ktra == jp_sal ) CALL ptr_sum( hstr_ldf(:,jp_sal,:), zsj(:,:) ) 555 ELSE IF( cptr == 'eiv' ) THEN 556 IF( ktra == jp_tem ) CALL ptr_sum( hstr_eiv(:,jp_tem,:), zsj(:,:) ) 557 IF( ktra == jp_sal ) CALL ptr_sum( hstr_eiv(:,jp_sal,:), zsj(:,:) ) 558 ELSE IF( cptr == 'vtr' ) THEN 559 IF( ktra == jp_tem ) CALL ptr_sum( hstr_vtr(:,jp_tem,:), zsj(:,:) ) 560 IF( ktra == jp_sal ) CALL ptr_sum( hstr_vtr(:,jp_sal,:), zsj(:,:) ) 432 561 ENDIF 433 562 ! 434 IF( cptr == 'ldf' ) THEN 435 IF( ktra == jp_tem ) THEN 436 DO jn = 1, nbasin 437 hstr_ldf(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 438 ENDDO 439 ENDIF 440 IF( ktra == jp_sal ) THEN 441 DO jn = 1, nbasin 442 hstr_ldf(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 443 ENDDO 444 ENDIF 563 END SUBROUTINE dia_ptr_hst 564 565 566 SUBROUTINE ptr_sum_2d( phstr, pva ) 567 !!---------------------------------------------------------------------- 568 !! *** ROUTINE ptr_sum_2d *** 569 !!---------------------------------------------------------------------- 570 !! ** Purpose : Add two 2D arrays with (j,nbasin) dimensions 571 !! 572 !! ** Method : - phstr = phstr + pva 573 !! - Call mpp_sum if the final tile 574 !! 575 !! ** Action : phstr 576 !!---------------------------------------------------------------------- 577 REAL(wp), DIMENSION(jpj,nbasin) , INTENT(inout) :: phstr ! 578 REAL(wp), DIMENSION(A1Dj(nn_hls),nbasin), INTENT(in) :: pva ! 579 INTEGER :: jj 580 #if defined key_mpp_mpi 581 INTEGER, DIMENSION(1) :: ish1d 582 INTEGER, DIMENSION(2) :: ish2d 583 REAL(wp), DIMENSION(jpj*nbasin) :: zwork 584 #endif 585 586 DO jj = ntsj, ntej 587 phstr(jj,:) = phstr(jj,:) + pva(jj,:) 588 END DO 589 590 #if defined key_mpp_mpi 591 IF( ntile == 0 .OR. ntile == nijtile ) THEN 592 ish1d(1) = jpj*nbasin 593 ish2d(1) = jpj ; ish2d(2) = nbasin 594 zwork(:) = RESHAPE( phstr(:,:), ish1d ) 595 CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) 596 phstr(:,:) = RESHAPE( zwork, ish2d ) 445 597 ENDIF 446 ! 447 IF( cptr == 'eiv' ) THEN 448 IF( ktra == jp_tem ) THEN 449 DO jn = 1, nbasin 450 hstr_eiv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 451 ENDDO 452 ENDIF 453 IF( ktra == jp_sal ) THEN 454 DO jn = 1, nbasin 455 hstr_eiv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 456 ENDDO 457 ENDIF 598 #endif 599 END SUBROUTINE ptr_sum_2d 600 601 602 SUBROUTINE ptr_sum_3d( phstr, pva ) 603 !!---------------------------------------------------------------------- 604 !! *** ROUTINE ptr_sum_3d *** 605 !!---------------------------------------------------------------------- 606 !! ** Purpose : Add two 3D arrays with (j,k,nbasin) dimensions 607 !! 608 !! ** Method : - phstr = phstr + pva 609 !! - Call mpp_sum if the final tile 610 !! 611 !! ** Action : phstr 612 !!---------------------------------------------------------------------- 613 REAL(wp), DIMENSION(jpj,jpk,nbasin) , INTENT(inout) :: phstr ! 614 REAL(wp), DIMENSION(A1Dj(nn_hls),jpk,nbasin), INTENT(in) :: pva ! 615 INTEGER :: jj, jk 616 #if defined key_mpp_mpi 617 INTEGER, DIMENSION(1) :: ish1d 618 INTEGER, DIMENSION(3) :: ish3d 619 REAL(wp), DIMENSION(jpj*jpk*nbasin) :: zwork 620 #endif 621 622 DO jk = 1, jpk 623 DO jj = ntsj, ntej 624 phstr(jj,jk,:) = phstr(jj,jk,:) + pva(jj,jk,:) 625 END DO 626 END DO 627 628 #if defined key_mpp_mpi 629 IF( ntile == 0 .OR. ntile == nijtile ) THEN 630 ish1d(1) = jpj*jpk*nbasin 631 ish3d(1) = jpj ; ish3d(2) = jpk ; ish3d(3) = nbasin 632 zwork(:) = RESHAPE( phstr(:,:,:), ish1d ) 633 CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) 634 phstr(:,:,:) = RESHAPE( zwork, ish3d ) 458 635 ENDIF 459 ! 460 IF( cptr == 'vtr' ) THEN 461 IF( ktra == jp_tem ) THEN 462 DO jn = 1, nbasin 463 hstr_vtr(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 464 ENDDO 465 ENDIF 466 IF( ktra == jp_sal ) THEN 467 DO jn = 1, nbasin 468 hstr_vtr(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 469 ENDDO 470 ENDIF 471 ENDIF 472 ! 473 END SUBROUTINE dia_ptr_hst 636 #endif 637 END SUBROUTINE ptr_sum_3d 474 638 475 639 … … 479 643 !!---------------------------------------------------------------------- 480 644 INTEGER :: dia_ptr_alloc ! return value 481 INTEGER, DIMENSION( 3) :: ierr645 INTEGER, DIMENSION(2) :: ierr 482 646 !!---------------------------------------------------------------------- 483 647 ierr(:) = 0 … … 491 655 & hstr_ldf(jpj,jpts,nbasin), hstr_vtr(jpj,jpts,nbasin), STAT=ierr(1) ) 492 656 ! 493 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 657 ALLOCATE( pvtr_int(jpj,jpk,jpts+2,nbasin), & 658 & pzon_int(jpj,jpk,jpts+1,nbasin), STAT=ierr(2) ) 494 659 ! 495 660 dia_ptr_alloc = MAXVAL( ierr ) … … 511 676 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 512 677 !!---------------------------------------------------------------------- 513 REAL(wp), INTENT(in), DIMENSION( jpi,jpj,jpk) :: pvflx ! mask flux array at V-point514 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) 678 REAL(wp), INTENT(in), DIMENSION(A2D(nn_hls),jpk) :: pvflx ! mask flux array at V-point 679 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 515 680 ! 516 681 INTEGER :: ji, jj, jk ! dummy loop arguments 517 INTEGER :: ijpj ! ??? 518 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 682 REAL(wp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value 519 683 !!-------------------------------------------------------------------- 520 684 ! 521 p_fval => p_fval1d522 523 ijpj = jpj524 685 p_fval(:) = 0._wp 525 686 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 526 687 p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 527 688 END_3D 528 #if defined key_mpp_mpi529 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl)530 #endif531 !532 689 END FUNCTION ptr_sj_3d 533 690 … … 544 701 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 545 702 !!---------------------------------------------------------------------- 546 REAL(wp) , INTENT(in), DIMENSION( jpi,jpj):: pvflx ! mask flux array at V-point703 REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls)) :: pvflx ! mask flux array at V-point 547 704 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 548 705 ! 549 706 INTEGER :: ji,jj ! dummy loop arguments 550 INTEGER :: ijpj ! ??? 551 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 707 REAL(wp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value 552 708 !!-------------------------------------------------------------------- 553 ! 554 p_fval => p_fval1d 555 556 ijpj = jpj 709 ! 557 710 p_fval(:) = 0._wp 558 711 DO_2D( 0, 0, 0, 0 ) 559 712 p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) 560 713 END_2D 561 #if defined key_mpp_mpi562 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl )563 #endif564 !565 714 END FUNCTION ptr_sj_2d 566 715 … … 588 737 p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) 589 738 END_2D 590 CALL lbc_lnk( 'diaptr', p_fval, 'U', -1.0_wp )591 739 END DO 592 740 ! … … 607 755 !! 608 756 IMPLICIT none 609 REAL(wp) , INTENT(in), DIMENSION( jpi,jpj,jpk) :: pta ! mask flux array at V-point610 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) 757 REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls),jpk) :: pta ! mask flux array at V-point 758 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 611 759 !! 612 760 INTEGER :: ji, jj, jk ! dummy loop arguments 613 REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value 614 #if defined key_mpp_mpi 615 INTEGER, DIMENSION(1) :: ish 616 INTEGER, DIMENSION(2) :: ish2 617 INTEGER :: ijpjjpk 618 REAL(wp), DIMENSION(jpj*jpk) :: zwork ! mask flux array at V-point 619 #endif 761 REAL(wp), DIMENSION(A1Dj(nn_hls),jpk) :: p_fval ! return function value 620 762 !!-------------------------------------------------------------------- 621 763 ! 622 p_fval => p_fval2d623 624 764 p_fval(:,:) = 0._wp 625 765 ! … … 627 767 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 628 768 END_3D 629 !630 #if defined key_mpp_mpi631 ijpjjpk = jpj*jpk632 ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk633 zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )634 CALL mpp_sum( 'diaptr', zwork, ijpjjpk, ncomm_znl )635 p_fval(:,:) = RESHAPE( zwork, ish2 )636 #endif637 !638 769 END FUNCTION ptr_sjk 639 770 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/daymod.F90
r13558 r14046 149 149 CALL day( nit000 ) 150 150 ! 151 IF( lwxios ) THEN152 ! define variables in restart file when writing with XIOS153 CALL iom_set_rstw_var_active('kt')154 CALL iom_set_rstw_var_active('ndastp')155 CALL iom_set_rstw_var_active('adatrj')156 CALL iom_set_rstw_var_active('ntime')157 ENDIF158 159 151 END SUBROUTINE day_init 160 152 … … 324 316 325 317 IF( TRIM(cdrw) == 'READ' ) THEN 326 327 318 IF( iom_varid( numror, 'kt', ldstop = .FALSE. ) > 0 ) THEN 328 319 ! Get Calendar informations 329 CALL iom_get( numror, 'kt', zkt , ldxios = lrxios) ! last time-step of previous run320 CALL iom_get( numror, 'kt', zkt ) ! last time-step of previous run 330 321 IF(lwp) THEN 331 322 WRITE(numout,*) ' *** Info read in restart : ' … … 346 337 IF ( nrstdt == 2 ) THEN 347 338 ! read the parameters corresponding to nit000 - 1 (last time step of previous run) 348 CALL iom_get( numror, 'ndastp', zndastp , ldxios = lrxios)339 CALL iom_get( numror, 'ndastp', zndastp ) 349 340 ndastp = NINT( zndastp ) 350 CALL iom_get( numror, 'adatrj', adatrj , ldxios = lrxios)351 CALL iom_get( numror, 'ntime' , ktime , ldxios = lrxios)341 CALL iom_get( numror, 'adatrj', adatrj ) 342 CALL iom_get( numror, 'ntime' , ktime ) 352 343 nn_time0 = NINT(ktime) 353 344 ! calculate start time in hours and minutes … … 410 401 ENDIF 411 402 ! calendar control 412 IF( lwxios ) CALL iom_swap( cwxios_context ) 413 CALL iom_rstput( kt, nitrst, numrow, 'kt' , REAL( kt , wp) , ldxios = lwxios ) ! time-step 414 CALL iom_rstput( kt, nitrst, numrow, 'ndastp' , REAL( ndastp, wp) , ldxios = lwxios ) ! date 415 CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj , ldxios = lwxios ) ! number of elapsed days since 403 CALL iom_rstput( kt, nitrst, numrow, 'kt' , REAL( kt , wp) ) ! time-step 404 CALL iom_rstput( kt, nitrst, numrow, 'ndastp' , REAL( ndastp, wp) ) ! date 405 CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj ) ! number of elapsed days since 416 406 ! ! the begining of the run [s] 417 CALL iom_rstput( kt, nitrst, numrow, 'ntime' , REAL( nn_time0, wp), ldxios = lwxios ) ! time 418 IF( lwxios ) CALL iom_swap( cxios_context ) 407 CALL iom_rstput( kt, nitrst, numrow, 'ntime' , REAL( nn_time0, wp) ) ! time 419 408 ENDIF 420 409 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/dom_oce.F90
r13557 r14046 74 74 LOGICAL, PUBLIC :: l_Iperio, l_Jperio ! should we explicitely take care I/J periodicity 75 75 76 ! Tiling namelist 77 LOGICAL, PUBLIC :: ln_tile 78 INTEGER :: nn_ltile_i, nn_ltile_j 79 80 ! Domain tiling (all tiles) 81 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntsi_a !: start of internal part of tile domain 82 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntsj_a ! 83 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntei_a !: end of internal part of tile domain 84 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ntej_a ! 85 76 86 ! !: domain MPP decomposition parameters 77 87 INTEGER , PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom … … 87 97 INTEGER, PUBLIC :: noea, nowe !: index of the local neighboring processors in 88 98 INTEGER, PUBLIC :: noso, nono !: east, west, south and north directions 99 INTEGER, PUBLIC :: nones, nonws !: north-east, north-west directions for sending 100 INTEGER, PUBLIC :: noses, nosws !: south-east, south-west directions for sending 101 INTEGER, PUBLIC :: noner, nonwr !: north-east, north-west directions for receiving 102 INTEGER, PUBLIC :: noser, noswr !: south-east, south-west directions for receiving 89 103 INTEGER, PUBLIC :: nidom !: ??? 90 104 … … 296 310 ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) , & 297 311 & e3w(jpi,jpj,jpk,jpt) , e3uw(jpi,jpj,jpk,jpt) , e3vw(jpi,jpj,jpk,jpt) , STAT=ierr(ii) ) 298 #endif 312 #endif 299 313 ! 300 314 ii = ii+1 301 315 ALLOCATE( r3t (jpi,jpj,jpt) , r3u (jpi,jpj,jpt) , r3v (jpi,jpj,jpt) , r3f (jpi,jpj) , & 302 & r3t_f(jpi,jpj) , r3u_f(jpi,jpj) , r3v_f(jpi,jpj) , STAT=ierr(ii) ) 316 & r3t_f(jpi,jpj) , r3u_f(jpi,jpj) , r3v_f(jpi,jpj) , STAT=ierr(ii) ) 303 317 ! 304 318 ii = ii+1 … … 317 331 ! 318 332 ii = ii+1 319 ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii) ) 333 ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii) ) 320 334 ! 321 335 ii = ii+1 … … 323 337 ! 324 338 ii = ii+1 325 ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , & 339 ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , & 326 340 & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) , & 327 341 & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , STAT=ierr(ii) ) … … 331 345 ! 332 346 ii = ii+1 333 ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , & 347 ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , & 334 348 & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 335 349 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/domain.F90
r13558 r14046 45 45 USE closea , ONLY : dom_clo ! closed seas 46 46 ! 47 USE prtctl ! Print control (prt_ctl_info routine) 47 48 USE in_out_manager ! I/O manager 48 49 USE iom ! I/O library … … 55 56 PUBLIC dom_init ! called by nemogcm.F90 56 57 PUBLIC domain_cfg ! called by nemogcm.F90 58 PUBLIC dom_tile ! called by step.F90 57 59 58 60 !!------------------------------------------------------------------------- … … 63 65 CONTAINS 64 66 65 SUBROUTINE dom_init( Kbb, Kmm, Kaa , cdstr)67 SUBROUTINE dom_init( Kbb, Kmm, Kaa ) 66 68 !!---------------------------------------------------------------------- 67 69 !! *** ROUTINE dom_init *** … … 79 81 !!---------------------------------------------------------------------- 80 82 INTEGER , INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices 81 CHARACTER (len=*), INTENT(in) :: cdstr ! model: NEMO or SAS. Determines core restart variables82 83 ! 83 84 INTEGER :: ji, jj, jk, jt ! dummy loop indices … … 120 121 WRITE(numout,*) ' cn_cfg = ', TRIM( cn_cfg ), ' nn_cfg = ', nn_cfg 121 122 ENDIF 123 nn_wxios = 0 124 ln_xios_read = .FALSE. 122 125 ! 123 126 ! !== Reference coordinate system ==! 124 127 ! 125 CALL dom_glo ! global domain versus local domain 126 CALL dom_nam ! read namelist ( namrun, namdom ) 127 ! 128 IF( lwxios ) THEN 129 !define names for restart write and set core output (restart.F90) 130 CALL iom_set_rst_vars(rst_wfields) 131 CALL iom_set_rstw_core(cdstr) 132 ENDIF 133 !reset namelist for SAS 134 IF(cdstr == 'SAS') THEN 135 IF(lrxios) THEN 136 IF(lwp) write(numout,*) 'Disable reading restart file using XIOS for SAS' 137 lrxios = .FALSE. 138 ENDIF 139 ENDIF 128 CALL dom_glo ! global domain versus local domain 129 CALL dom_nam ! read namelist ( namrun, namdom ) 130 CALL dom_tile( ntsi, ntsj, ntei, ntej ) ! Tile domain 131 140 132 ! 141 133 CALL dom_hgr ! Horizontal mesh … … 285 277 286 278 279 SUBROUTINE dom_tile( ktsi, ktsj, ktei, ktej, ktile ) 280 !!---------------------------------------------------------------------- 281 !! *** ROUTINE dom_tile *** 282 !! 283 !! ** Purpose : Set tile domain variables 284 !! 285 !! ** Action : - ktsi, ktsj : start of internal part of domain 286 !! - ktei, ktej : end of internal part of domain 287 !! - ntile : current tile number 288 !! - nijtile : total number of tiles 289 !!---------------------------------------------------------------------- 290 INTEGER, INTENT(out) :: ktsi, ktsj, ktei, ktej ! Tile domain indices 291 INTEGER, INTENT(in), OPTIONAL :: ktile ! Tile number 292 INTEGER :: jt ! dummy loop argument 293 INTEGER :: iitile, ijtile ! Local integers 294 CHARACTER (len=11) :: charout 295 !!---------------------------------------------------------------------- 296 IF( PRESENT(ktile) .AND. ln_tile ) THEN 297 ntile = ktile ! Set domain indices for tile 298 ktsi = ntsi_a(ktile) 299 ktsj = ntsj_a(ktile) 300 ktei = ntei_a(ktile) 301 ktej = ntej_a(ktile) 302 303 IF(sn_cfctl%l_prtctl) THEN 304 WRITE(charout, FMT="('ntile =', I4)") ktile 305 CALL prt_ctl_info( charout ) 306 ENDIF 307 ELSE 308 ntile = 0 ! Initialise to full domain 309 nijtile = 1 310 ktsi = Nis0 311 ktsj = Njs0 312 ktei = Nie0 313 ktej = Nje0 314 315 IF( ln_tile ) THEN ! Calculate tile domain indices 316 iitile = Ni_0 / nn_ltile_i ! Number of tiles 317 ijtile = Nj_0 / nn_ltile_j 318 IF( MOD( Ni_0, nn_ltile_i ) /= 0 ) iitile = iitile + 1 319 IF( MOD( Nj_0, nn_ltile_j ) /= 0 ) ijtile = ijtile + 1 320 321 nijtile = iitile * ijtile 322 ALLOCATE( ntsi_a(0:nijtile), ntsj_a(0:nijtile), ntei_a(0:nijtile), ntej_a(0:nijtile) ) 323 324 ntsi_a(0) = ktsi ! Full domain 325 ntsj_a(0) = ktsj 326 ntei_a(0) = ktei 327 ntej_a(0) = ktej 328 329 DO jt = 1, nijtile ! Tile domains 330 ntsi_a(jt) = Nis0 + nn_ltile_i * MOD(jt - 1, iitile) 331 ntsj_a(jt) = Njs0 + nn_ltile_j * ((jt - 1) / iitile) 332 ntei_a(jt) = MIN(ntsi_a(jt) + nn_ltile_i - 1, Nie0) 333 ntej_a(jt) = MIN(ntsj_a(jt) + nn_ltile_j - 1, Nje0) 334 ENDDO 335 ENDIF 336 337 IF(lwp) THEN ! control print 338 WRITE(numout,*) 339 WRITE(numout,*) 'dom_tile : Domain tiling decomposition' 340 WRITE(numout,*) '~~~~~~~~' 341 IF( ln_tile ) THEN 342 WRITE(numout,*) iitile, 'tiles in i' 343 WRITE(numout,*) ' Starting indices' 344 WRITE(numout,*) ' ', (ntsi_a(jt), jt=1, iitile) 345 WRITE(numout,*) ' Ending indices' 346 WRITE(numout,*) ' ', (ntei_a(jt), jt=1, iitile) 347 WRITE(numout,*) ijtile, 'tiles in j' 348 WRITE(numout,*) ' Starting indices' 349 WRITE(numout,*) ' ', (ntsj_a(jt), jt=1, nijtile, iitile) 350 WRITE(numout,*) ' Ending indices' 351 WRITE(numout,*) ' ', (ntej_a(jt), jt=1, nijtile, iitile) 352 ELSE 353 WRITE(numout,*) 'No domain tiling' 354 WRITE(numout,*) ' i indices =', ktsi, ':', ktei 355 WRITE(numout,*) ' j indices =', ktsj, ':', ktej 356 ENDIF 357 ENDIF 358 ENDIF 359 END SUBROUTINE dom_tile 360 361 287 362 SUBROUTINE dom_nam 288 363 !!---------------------------------------------------------------------- … … 293 368 !! ** input : - namrun namelist 294 369 !! - namdom namelist 370 !! - namtile namelist 295 371 !! - namnc4 namelist ! "key_netcdf4" only 296 372 !!---------------------------------------------------------------------- … … 305 381 & ln_cfmeta, ln_xios_read, nn_wxios 306 382 NAMELIST/namdom/ ln_linssh, rn_Dt, rn_atfp, ln_crs, ln_meshmask 383 NAMELIST/namtile/ ln_tile, nn_ltile_i, nn_ltile_j 307 384 #if defined key_netcdf4 308 385 NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip … … 441 518 r1_Dt = 1._wp / rDt 442 519 520 READ ( numnam_ref, namtile, IOSTAT = ios, ERR = 905 ) 521 905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtile in reference namelist' ) 522 READ ( numnam_cfg, namtile, IOSTAT = ios, ERR = 906 ) 523 906 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtile in configuration namelist' ) 524 IF(lwm) WRITE( numond, namtile ) 525 526 IF(lwp) THEN 527 WRITE(numout,*) 528 WRITE(numout,*) ' Namelist : namtile --- Domain tiling decomposition' 529 WRITE(numout,*) ' Tiling (T) or not (F) ln_tile = ', ln_tile 530 WRITE(numout,*) ' Length of tile in i nn_ltile_i = ', nn_ltile_i 531 WRITE(numout,*) ' Length of tile in j nn_ltile_j = ', nn_ltile_j 532 WRITE(numout,*) 533 IF( ln_tile ) THEN 534 WRITE(numout,*) ' The domain will be decomposed into tiles of size', nn_ltile_i, 'x', nn_ltile_j 535 ELSE 536 WRITE(numout,*) ' Domain tiling will NOT be used' 537 ENDIF 538 ENDIF 539 443 540 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 444 541 lrxios = ln_xios_read.AND.ln_rstart -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/domqco.F90
r13295 r14046 91 91 ! 92 92 CALL dom_qco_zgr(Kbb, Kmm, Kaa) ! interpolation scale factor, depth and water column 93 !94 ! IF(lwxios) THEN ! define variables in restart file when writing with XIOS95 ! CALL iom_set_rstw_var_active('e3t_b')96 ! CALL iom_set_rstw_var_active('e3t_n')97 ! ENDIF98 93 ! 99 94 END SUBROUTINE dom_qco_init … … 217 212 ! 218 213 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 219 CALL iom_get( numror, jpdom_auto, 'sshb' , ssh(:,:,Kbb) , ldxios = lrxios)220 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) , ldxios = lrxios)214 CALL iom_get( numror, jpdom_auto, 'sshb' , ssh(:,:,Kbb) ) 215 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) ) 221 216 ! needed to restart if land processor not computed 222 217 IF(lwp) write(numout,*) 'qe_rst_read : ssh(:,:,Kbb) and ssh(:,:,Kmm) found in restart files' … … 232 227 IF(lwp) write(numout,*) 'sshn set equal to sshb.' 233 228 IF(lwp) write(numout,*) 'neuler is forced to 0' 234 CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb) , ldxios = lrxios)229 CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb) ) 235 230 ssh(:,:,Kmm) = ssh(:,:,Kbb) 236 231 l_1st_euler = .TRUE. … … 239 234 IF(lwp) write(numout,*) 'sshb set equal to sshn.' 240 235 IF(lwp) write(numout,*) 'neuler is forced to 0' 241 CALL iom_get( numror, jpdom_auto, 'sshn', ssh(:,:,Kmm) , ldxios = lrxios)236 CALL iom_get( numror, jpdom_auto, 'sshn', ssh(:,:,Kmm) ) 242 237 ssh(:,:,Kbb) = ssh(:,:,Kmm) 243 238 l_1st_euler = .TRUE. -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/domutl.F90
r13458 r14046 21 21 PRIVATE 22 22 23 INTERFACE is_tile 24 MODULE PROCEDURE is_tile_2d, is_tile_3d, is_tile_4d 25 END INTERFACE is_tile 26 23 27 PUBLIC dom_ngb ! routine called in iom.F90 module 24 28 PUBLIC dom_uniq ! Called by dommsk and domwri 29 PUBLIC is_tile 25 30 26 31 !!---------------------------------------------------------------------- … … 109 114 ! 110 115 END SUBROUTINE dom_uniq 111 116 117 118 FUNCTION is_tile_2d( pt ) 119 !! 120 REAL(wp), DIMENSION(:,:), INTENT(in) :: pt 121 INTEGER :: is_tile_2d 122 !! 123 IF( ln_tile .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN 124 is_tile_2d = 1 125 ELSE 126 is_tile_2d = 0 127 ENDIF 128 END FUNCTION is_tile_2d 129 130 131 FUNCTION is_tile_3d( pt ) 132 !! 133 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pt 134 INTEGER :: is_tile_3d 135 !! 136 IF( ln_tile .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN 137 is_tile_3d = 1 138 ELSE 139 is_tile_3d = 0 140 ENDIF 141 END FUNCTION is_tile_3d 142 143 144 FUNCTION is_tile_4d( pt ) 145 !! 146 REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: pt 147 INTEGER :: is_tile_4d 148 !! 149 IF( ln_tile .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN 150 is_tile_4d = 1 151 ELSE 152 is_tile_4d = 0 153 ENDIF 154 END FUNCTION is_tile_4d 155 112 156 !!====================================================================== 113 157 END MODULE domutl -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/domvvl.F90
r13497 r14046 282 282 ENDIF 283 283 ! 284 IF(lwxios) THEN285 ! define variables in restart file when writing with XIOS286 CALL iom_set_rstw_var_active('e3t_b')287 CALL iom_set_rstw_var_active('e3t_n')288 ! ! ----------------------- !289 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases !290 ! ! ----------------------- !291 CALL iom_set_rstw_var_active('tilde_e3t_b')292 CALL iom_set_rstw_var_active('tilde_e3t_n')293 END IF294 ! ! -------------!295 IF( ln_vvl_ztilde ) THEN ! z_tilde case !296 ! ! ------------ !297 CALL iom_set_rstw_var_active('hdiv_lf')298 ENDIF299 !300 ENDIF301 !302 284 END SUBROUTINE dom_vvl_zgr 303 285 … … 440 422 ! (stored for tracer advction and continuity equation) 441 423 CALL lbc_lnk_multi( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) 442 443 424 ! 4 - Time stepping of baroclinic scale factors 444 425 ! --------------------------------------------- … … 803 784 IF( ln_rstart ) THEN !* Read the restart file 804 785 CALL rst_read_open ! open the restart file if necessary 805 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) , ldxios = lrxios)786 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) ) 806 787 ! 807 788 id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) … … 816 797 ! 817 798 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 818 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lrxios)819 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lrxios)799 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 800 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 820 801 ! needed to restart if land processor not computed 821 802 IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' … … 831 812 IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 832 813 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 833 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lrxios)814 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 834 815 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 835 816 l_1st_euler = .true. … … 838 819 IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 839 820 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 840 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lrxios)821 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 841 822 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 842 823 l_1st_euler = .true. … … 863 844 ! ! ----------------------- ! 864 845 IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist 865 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) , ldxios = lrxios)866 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) , ldxios = lrxios)846 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 847 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 867 848 ELSE ! one at least array is missing 868 849 tilde_e3t_b(:,:,:) = 0.0_wp … … 873 854 ! ! ------------ ! 874 855 IF( id5 > 0 ) THEN ! required array exists 875 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) , ldxios = lrxios)856 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) 876 857 ELSE ! array is missing 877 858 hdiv_lf(:,:,:) = 0.0_wp … … 946 927 ! ! =================== 947 928 IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 948 IF( lwxios ) CALL iom_swap( cwxios_context )949 929 ! ! --------- ! 950 930 ! ! all cases ! 951 931 ! ! --------- ! 952 CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lwxios)953 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lwxios)932 CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) ) 933 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) ) 954 934 ! ! ----------------------- ! 955 935 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases ! 956 936 ! ! ----------------------- ! 957 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:) , ldxios = lwxios)958 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:) , ldxios = lwxios)937 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:)) 938 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:)) 959 939 END IF 960 940 ! ! -------------! 961 941 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 962 942 ! ! ------------ ! 963 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:) , ldxios = lwxios)943 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:)) 964 944 ENDIF 965 945 ! 966 IF( lwxios ) CALL iom_swap( cxios_context )967 946 ENDIF 968 947 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DOM/dtatsd.F90
r13497 r14046 18 18 USE phycst ! physical constants 19 19 USE dom_oce ! ocean space and time domain 20 USE domain, ONLY : dom_tile 20 21 USE fldread ! read input fields 21 22 ! … … 135 136 !! ** Action : ptsd T-S data on medl mesh and interpolated at time-step kt 136 137 !!---------------------------------------------------------------------- 137 INTEGER 138 REAL(wp), DIMENSION( jpi,jpj,jpk,jpts), INTENT( out) :: ptsd ! T & S data138 INTEGER , INTENT(in ) :: kt ! ocean time-step 139 REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT( out) :: ptsd ! T & S data 139 140 ! 140 141 INTEGER :: ji, jj, jk, jl, jkk ! dummy loop indicies 141 142 INTEGER :: ik, il0, il1, ii0, ii1, ij0, ij1 ! local integers 143 INTEGER :: itile 142 144 REAL(wp):: zl, zi ! local scalars 143 145 REAL(wp), DIMENSION(jpk) :: ztp, zsp ! 1D workspace 144 146 !!---------------------------------------------------------------------- 145 147 ! 146 CALL fld_read( kt, 1, sf_tsd ) !== read T & S data at kt time step ==! 148 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only for the full domain 149 itile = ntile 150 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Use full domain 151 CALL fld_read( kt, 1, sf_tsd ) !== read T & S data at kt time step ==! 147 152 ! 148 153 ! 149 154 !!gm This should be removed from the code ===>>>> T & S files has to be changed 150 ! 151 ! !== ORCA_R2 configuration and T & S damping ==! 152 IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 153 IF( nn_cfg == 2 .AND. ln_tsd_dmp ) THEN ! some hand made alterations 154 ! 155 ij0 = 101 + nn_hls ; ij1 = 109 + nn_hls ! Reduced T & S in the Alboran Sea 156 ii0 = 141 + nn_hls - 1 ; ii1 = 155 + nn_hls - 1 157 DO jj = mj0(ij0), mj1(ij1) 158 DO ji = mi0(ii0), mi1(ii1) 159 sf_tsd(jp_tem)%fnow(ji,jj,13:13) = sf_tsd(jp_tem)%fnow(ji,jj,13:13) - 0.20_wp 160 sf_tsd(jp_tem)%fnow(ji,jj,14:15) = sf_tsd(jp_tem)%fnow(ji,jj,14:15) - 0.35_wp 161 sf_tsd(jp_tem)%fnow(ji,jj,16:25) = sf_tsd(jp_tem)%fnow(ji,jj,16:25) - 0.40_wp 162 ! 163 sf_tsd(jp_sal)%fnow(ji,jj,13:13) = sf_tsd(jp_sal)%fnow(ji,jj,13:13) - 0.15_wp 164 sf_tsd(jp_sal)%fnow(ji,jj,14:15) = sf_tsd(jp_sal)%fnow(ji,jj,14:15) - 0.25_wp 165 sf_tsd(jp_sal)%fnow(ji,jj,16:17) = sf_tsd(jp_sal)%fnow(ji,jj,16:17) - 0.30_wp 166 sf_tsd(jp_sal)%fnow(ji,jj,18:25) = sf_tsd(jp_sal)%fnow(ji,jj,18:25) - 0.35_wp 155 ! 156 ! !== ORCA_R2 configuration and T & S damping ==! 157 IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 158 IF( nn_cfg == 2 .AND. ln_tsd_dmp ) THEN ! some hand made alterations 159 ! 160 ij0 = 101 + nn_hls ; ij1 = 109 + nn_hls ! Reduced T & S in the Alboran Sea 161 ii0 = 141 + nn_hls - 1 ; ii1 = 155 + nn_hls - 1 162 DO jj = mj0(ij0), mj1(ij1) 163 DO ji = mi0(ii0), mi1(ii1) 164 sf_tsd(jp_tem)%fnow(ji,jj,13:13) = sf_tsd(jp_tem)%fnow(ji,jj,13:13) - 0.20_wp 165 sf_tsd(jp_tem)%fnow(ji,jj,14:15) = sf_tsd(jp_tem)%fnow(ji,jj,14:15) - 0.35_wp 166 sf_tsd(jp_tem)%fnow(ji,jj,16:25) = sf_tsd(jp_tem)%fnow(ji,jj,16:25) - 0.40_wp 167 ! 168 sf_tsd(jp_sal)%fnow(ji,jj,13:13) = sf_tsd(jp_sal)%fnow(ji,jj,13:13) - 0.15_wp 169 sf_tsd(jp_sal)%fnow(ji,jj,14:15) = sf_tsd(jp_sal)%fnow(ji,jj,14:15) - 0.25_wp 170 sf_tsd(jp_sal)%fnow(ji,jj,16:17) = sf_tsd(jp_sal)%fnow(ji,jj,16:17) - 0.30_wp 171 sf_tsd(jp_sal)%fnow(ji,jj,18:25) = sf_tsd(jp_sal)%fnow(ji,jj,18:25) - 0.35_wp 172 END DO 167 173 END DO 168 END DO 169 ij0 = 87 + nn_hls ; ij1 = 96 + nn_hls ! Reduced temperature in Red Sea 170 ii0 = 148 + nn_hls - 1 ; ii1 = 160 + nn_hls - 1 171 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 4:10 ) = 7.0_wp 172 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 11:13 ) = 6.5_wp 173 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 14:20 ) = 6.0_wp 174 ENDIF 175 ENDIF 174 ij0 = 87 + nn_hls ; ij1 = 96 + nn_hls ! Reduced temperature in Red Sea 175 ii0 = 148 + nn_hls - 1 ; ii1 = 160 + nn_hls - 1 176 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 4:10 ) = 7.0_wp 177 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 11:13 ) = 6.5_wp 178 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 14:20 ) = 6.0_wp 179 ENDIF 180 ENDIF 176 181 !!gm end 177 ! 178 ptsd(:,:,:,jp_tem) = sf_tsd(jp_tem)%fnow(:,:,:) ! NO mask 179 ptsd(:,:,:,jp_sal) = sf_tsd(jp_sal)%fnow(:,:,:) 182 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = itile ) ! Revert to tile domain 183 ENDIF 184 ! 185 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 186 ptsd(ji,jj,jk,jp_tem) = sf_tsd(jp_tem)%fnow(ji,jj,jk) ! NO mask 187 ptsd(ji,jj,jk,jp_sal) = sf_tsd(jp_sal)%fnow(ji,jj,jk) 188 END_3D 180 189 ! 181 190 IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! 182 191 ! 183 IF( kt == nit000 .AND. lwp )THEN 184 WRITE(numout,*) 185 WRITE(numout,*) 'dta_tsd: interpolates T & S data onto the s- or mixed s-z-coordinate mesh' 186 ENDIF 187 ! 188 DO_2D( 1, 1, 1, 1 ) ! vertical interpolation of T & S 192 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 193 IF( kt == nit000 .AND. lwp )THEN 194 WRITE(numout,*) 195 WRITE(numout,*) 'dta_tsd: interpolates T & S data onto the s- or mixed s-z-coordinate mesh' 196 ENDIF 197 ENDIF 198 ! 199 ! NOTE: [tiling-comms-merge] This fix was necessary to take out tra_adv lbc_lnk statements in the zps case, but did not work in the zco case 200 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! vertical interpolation of T & S 189 201 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points 190 202 zl = gdept_0(ji,jj,jk) … … 215 227 ELSE !== z- or zps- coordinate ==! 216 228 ! 217 ptsd(:,:,:,jp_tem) = ptsd(:,:,:,jp_tem) * tmask(:,:,:) ! Mask 218 ptsd(:,:,:,jp_sal) = ptsd(:,:,:,jp_sal) * tmask(:,:,:) 229 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 230 ptsd(ji,jj,jk,jp_tem) = ptsd(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) ! Mask 231 ptsd(ji,jj,jk,jp_sal) = ptsd(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 232 END_3D 219 233 ! 220 234 IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level 221 DO_2D( 1, 1, 1, 1 ) 235 ! NOTE: [tiling-comms-merge] This fix was necessary to take out tra_adv lbc_lnk statements in the zps case 236 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 222 237 ik = mbkt(ji,jj) 223 238 IF( ik > 1 ) THEN -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DYN/dynhpg.F90
r13889 r14046 322 322 INTEGER :: iku, ikv ! temporary integers 323 323 REAL(wp) :: zcoef0, zcoef1, zcoef2, zcoef3 ! temporary scalars 324 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 325 REAL(wp), DIMENSION(jpi,jpj) :: zgtsu, zgtsv, zgru, zgrv 324 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 325 REAL(wp), DIMENSION(jpi,jpj,jpts) :: zgtsu, zgtsv 326 REAL(wp), DIMENSION(jpi,jpj) :: zgru, zgrv 326 327 !!---------------------------------------------------------------------- 327 328 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DYN/dynspg.F90
r13497 r14046 6 6 !! History : 1.0 ! 2005-12 (C. Talandier, G. Madec, V. Garnier) Original code 7 7 !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option 8 !! 4.2 ! 2020-12 (G. Madec, E. Clementi) add Bernoulli Head for 9 !! wave coupling 8 10 !!---------------------------------------------------------------------- 9 11 … … 19 21 USE sbc_ice , ONLY : snwice_mass, snwice_mass_b 20 22 USE sbcapr ! surface boundary condition: atmospheric pressure 23 USE sbcwave, ONLY : bhd_wave 21 24 USE dynspg_exp ! surface pressure gradient (dyn_spg_exp routine) 22 25 USE dynspg_ts ! surface pressure gradient (dyn_spg_ts routine) … … 143 146 ENDIF 144 147 ! 148 IF( ln_wave .and. ln_bern_srfc ) THEN !== Add J terms: depth-independent Bernoulli head 149 DO_2D( 0, 0, 0, 0 ) 150 spgu(ji,jj) = spgu(ji,jj) + ( bhd_wave(ji+1,jj) - bhd_wave(ji,jj) ) / e1u(ji,jj) !++ bhd_wave from wave model in m2/s2 [BHD parameters in WW3] 151 spgv(ji,jj) = spgv(ji,jj) + ( bhd_wave(ji,jj+1) - bhd_wave(ji,jj) ) / e2v(ji,jj) 152 END_2D 153 ENDIF 154 ! 145 155 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Add all terms to the general trend 146 156 puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + spgu(ji,jj) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DYN/dynspg_ts.F90
r13546 r14046 900 900 ! ! --------------- 901 901 IF( ln_rstart .AND. ln_bt_fw .AND. (.NOT.l_1st_euler) ) THEN !* Read the restart file 902 CALL iom_get( numror, jpdom_auto, 'ub2_b' , ub2_b (:,:), cd_type = 'U', psgn = -1._wp , ldxios = lrxios)903 CALL iom_get( numror, jpdom_auto, 'vb2_b' , vb2_b (:,:), cd_type = 'V', psgn = -1._wp , ldxios = lrxios)904 CALL iom_get( numror, jpdom_auto, 'un_bf' , un_bf (:,:), cd_type = 'U', psgn = -1._wp , ldxios = lrxios)905 CALL iom_get( numror, jpdom_auto, 'vn_bf' , vn_bf (:,:), cd_type = 'V', psgn = -1._wp , ldxios = lrxios)902 CALL iom_get( numror, jpdom_auto, 'ub2_b' , ub2_b (:,:), cd_type = 'U', psgn = -1._wp ) 903 CALL iom_get( numror, jpdom_auto, 'vb2_b' , vb2_b (:,:), cd_type = 'V', psgn = -1._wp ) 904 CALL iom_get( numror, jpdom_auto, 'un_bf' , un_bf (:,:), cd_type = 'U', psgn = -1._wp ) 905 CALL iom_get( numror, jpdom_auto, 'vn_bf' , vn_bf (:,:), cd_type = 'V', psgn = -1._wp ) 906 906 IF( .NOT.ln_bt_av ) THEN 907 CALL iom_get( numror, jpdom_auto, 'sshbb_e' , sshbb_e(:,:), cd_type = 'T', psgn = 1._wp , ldxios = lrxios)908 CALL iom_get( numror, jpdom_auto, 'ubb_e' , ubb_e(:,:), cd_type = 'U', psgn = -1._wp , ldxios = lrxios)909 CALL iom_get( numror, jpdom_auto, 'vbb_e' , vbb_e(:,:), cd_type = 'V', psgn = -1._wp , ldxios = lrxios)910 CALL iom_get( numror, jpdom_auto, 'sshb_e' , sshb_e(:,:), cd_type = 'T', psgn = 1._wp , ldxios = lrxios)911 CALL iom_get( numror, jpdom_auto, 'ub_e' , ub_e(:,:), cd_type = 'U', psgn = -1._wp , ldxios = lrxios)912 CALL iom_get( numror, jpdom_auto, 'vb_e' , vb_e(:,:), cd_type = 'V', psgn = -1._wp , ldxios = lrxios)907 CALL iom_get( numror, jpdom_auto, 'sshbb_e' , sshbb_e(:,:), cd_type = 'T', psgn = 1._wp ) 908 CALL iom_get( numror, jpdom_auto, 'ubb_e' , ubb_e(:,:), cd_type = 'U', psgn = -1._wp ) 909 CALL iom_get( numror, jpdom_auto, 'vbb_e' , vbb_e(:,:), cd_type = 'V', psgn = -1._wp ) 910 CALL iom_get( numror, jpdom_auto, 'sshb_e' , sshb_e(:,:), cd_type = 'T', psgn = 1._wp ) 911 CALL iom_get( numror, jpdom_auto, 'ub_e' , ub_e(:,:), cd_type = 'U', psgn = -1._wp ) 912 CALL iom_get( numror, jpdom_auto, 'vb_e' , vb_e(:,:), cd_type = 'V', psgn = -1._wp ) 913 913 ENDIF 914 914 #if defined key_agrif 915 915 ! Read time integrated fluxes 916 916 IF ( .NOT.Agrif_Root() ) THEN 917 CALL iom_get( numror, jpdom_auto, 'ub2_i_b' , ub2_i_b(:,:), cd_type = 'U', psgn = -1._wp , ldxios = lrxios)918 CALL iom_get( numror, jpdom_auto, 'vb2_i_b' , vb2_i_b(:,:), cd_type = 'V', psgn = -1._wp , ldxios = lrxios)917 CALL iom_get( numror, jpdom_auto, 'ub2_i_b' , ub2_i_b(:,:), cd_type = 'U', psgn = -1._wp ) 918 CALL iom_get( numror, jpdom_auto, 'vb2_i_b' , vb2_i_b(:,:), cd_type = 'V', psgn = -1._wp ) 919 919 ELSE 920 920 ub2_i_b(:,:) = 0._wp ; vb2_i_b(:,:) = 0._wp ! used in the 1st update of agrif … … 935 935 ! ! ------------------- 936 936 IF(lwp) WRITE(numout,*) '---- ts_rst ----' 937 IF( lwxios ) CALL iom_swap( cwxios_context ) 938 CALL iom_rstput( kt, nitrst, numrow, 'ub2_b' , ub2_b (:,:), ldxios = lwxios ) 939 CALL iom_rstput( kt, nitrst, numrow, 'vb2_b' , vb2_b (:,:), ldxios = lwxios ) 940 CALL iom_rstput( kt, nitrst, numrow, 'un_bf' , un_bf (:,:), ldxios = lwxios ) 941 CALL iom_rstput( kt, nitrst, numrow, 'vn_bf' , vn_bf (:,:), ldxios = lwxios ) 937 CALL iom_rstput( kt, nitrst, numrow, 'ub2_b' , ub2_b (:,:) ) 938 CALL iom_rstput( kt, nitrst, numrow, 'vb2_b' , vb2_b (:,:) ) 939 CALL iom_rstput( kt, nitrst, numrow, 'un_bf' , un_bf (:,:) ) 940 CALL iom_rstput( kt, nitrst, numrow, 'vn_bf' , vn_bf (:,:) ) 942 941 ! 943 942 IF (.NOT.ln_bt_av) THEN 944 CALL iom_rstput( kt, nitrst, numrow, 'sshbb_e' , sshbb_e(:,:) , ldxios = lwxios)945 CALL iom_rstput( kt, nitrst, numrow, 'ubb_e' , ubb_e(:,:) , ldxios = lwxios)946 CALL iom_rstput( kt, nitrst, numrow, 'vbb_e' , vbb_e(:,:) , ldxios = lwxios)947 CALL iom_rstput( kt, nitrst, numrow, 'sshb_e' , sshb_e(:,:) , ldxios = lwxios)948 CALL iom_rstput( kt, nitrst, numrow, 'ub_e' , ub_e(:,:) , ldxios = lwxios)949 CALL iom_rstput( kt, nitrst, numrow, 'vb_e' , vb_e(:,:) , ldxios = lwxios)943 CALL iom_rstput( kt, nitrst, numrow, 'sshbb_e' , sshbb_e(:,:) ) 944 CALL iom_rstput( kt, nitrst, numrow, 'ubb_e' , ubb_e(:,:) ) 945 CALL iom_rstput( kt, nitrst, numrow, 'vbb_e' , vbb_e(:,:) ) 946 CALL iom_rstput( kt, nitrst, numrow, 'sshb_e' , sshb_e(:,:) ) 947 CALL iom_rstput( kt, nitrst, numrow, 'ub_e' , ub_e(:,:) ) 948 CALL iom_rstput( kt, nitrst, numrow, 'vb_e' , vb_e(:,:) ) 950 949 ENDIF 951 950 #if defined key_agrif 952 951 ! Save time integrated fluxes 953 952 IF ( .NOT.Agrif_Root() ) THEN 954 CALL iom_rstput( kt, nitrst, numrow, 'ub2_i_b' , ub2_i_b(:,:) , ldxios = lwxios)955 CALL iom_rstput( kt, nitrst, numrow, 'vb2_i_b' , vb2_i_b(:,:) , ldxios = lwxios)953 CALL iom_rstput( kt, nitrst, numrow, 'ub2_i_b' , ub2_i_b(:,:) ) 954 CALL iom_rstput( kt, nitrst, numrow, 'vb2_i_b' , vb2_i_b(:,:) ) 956 955 ENDIF 957 956 #endif 958 IF( lwxios ) CALL iom_swap( cxios_context )959 957 ENDIF 960 958 ! … … 1048 1046 ! ! read restart when needed 1049 1047 CALL ts_rst( nit000, 'READ' ) 1050 !1051 IF( lwxios ) THEN1052 ! define variables in restart file when writing with XIOS1053 CALL iom_set_rstw_var_active('ub2_b')1054 CALL iom_set_rstw_var_active('vb2_b')1055 CALL iom_set_rstw_var_active('un_bf')1056 CALL iom_set_rstw_var_active('vn_bf')1057 !1058 IF (.NOT.ln_bt_av) THEN1059 CALL iom_set_rstw_var_active('sshbb_e')1060 CALL iom_set_rstw_var_active('ubb_e')1061 CALL iom_set_rstw_var_active('vbb_e')1062 CALL iom_set_rstw_var_active('sshb_e')1063 CALL iom_set_rstw_var_active('ub_e')1064 CALL iom_set_rstw_var_active('vb_e')1065 ENDIF1066 #if defined key_agrif1067 ! Save time integrated fluxes1068 IF ( .NOT.Agrif_Root() ) THEN1069 CALL iom_set_rstw_var_active('ub2_i_b')1070 CALL iom_set_rstw_var_active('vb2_i_b')1071 ENDIF1072 #endif1073 ENDIF1074 1048 ! 1075 1049 END SUBROUTINE dyn_spg_ts_init -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DYN/dynvor.F90
r13546 r14046 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.2 ! 2020-12 (G. Madec, E. Clementi) add vortex force trends (ln_vortex_force=T) 23 24 !!---------------------------------------------------------------------- 24 25 … … 37 38 USE trddyn ! trend manager: dynamics 38 39 USE sbcwave ! Surface Waves (add Stokes-Coriolis force) 39 USE sbc_oce , ONLY : ln_stcor! use Stoke-Coriolis force40 USE sbc_oce, ONLY : ln_stcor, ln_vortex_force ! use Stoke-Coriolis force 40 41 ! 41 42 USE lbclnk ! ocean lateral boundary conditions (or mpp link) … … 121 122 ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) ) 122 123 ! 123 ztrdu(:,:,:) = puu(:,:,:,Krhs) !* planetary vorticity trend (including Stokes-Coriolis force)124 ztrdu(:,:,:) = puu(:,:,:,Krhs) !* planetary vorticity trend 124 125 ztrdv(:,:,:) = pvv(:,:,:,Krhs) 125 126 SELECT CASE( nvor_scheme ) 126 127 CASE( np_ENS ) ; CALL vor_ens( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! enstrophy conserving scheme 127 IF( ln_stcor ) CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend128 128 CASE( np_ENE, np_MIX ) ; CALL vor_ene( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme 129 IF( ln_stcor ) CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend130 129 CASE( np_ENT ) ; CALL vor_enT( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme (T-pts) 131 IF( ln_stcor ) CALL vor_enT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend132 130 CASE( np_EET ) ; CALL vor_eeT( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy conserving scheme (een with e3t) 133 IF( ln_stcor ) CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend134 131 CASE( np_EEN ) ; CALL vor_een( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! energy & enstrophy scheme 135 IF( ln_stcor ) CALL vor_een( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend136 132 END SELECT 137 133 ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) … … 161 157 CASE( np_ENT ) !* energy conserving scheme (T-pts) 162 158 CALL vor_enT( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend 163 IF( ln_stcor ) CALL vor_enT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 159 IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN 160 CALL vor_enT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 161 ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN 162 CALL vor_enT( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force 163 ENDIF 164 164 CASE( np_EET ) !* energy conserving scheme (een scheme using e3t) 165 165 CALL vor_eeT( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend 166 IF( ln_stcor ) CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 166 IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN 167 CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 168 ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN 169 CALL vor_eeT( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force 170 ENDIF 167 171 CASE( np_ENE ) !* energy conserving scheme 168 172 CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend 169 IF( ln_stcor ) CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 173 IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN 174 CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 175 ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN 176 CALL vor_ene( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force 177 ENDIF 170 178 CASE( np_ENS ) !* enstrophy conserving scheme 171 179 CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend 172 IF( ln_stcor ) CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 180 181 IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN 182 CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 183 ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN 184 CALL vor_ens( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force 185 ENDIF 173 186 CASE( np_MIX ) !* mixed ene-ens scheme 174 187 CALL vor_ens( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! relative vorticity or metric trend (ens) 175 188 CALL vor_ene( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! planetary vorticity trend (ene) 176 IF( ln_stcor ) CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 189 IF( ln_stcor ) CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 190 IF( ln_vortex_force ) CALL vor_ens( kt, Kmm, nrvm, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add vortex force 177 191 CASE( np_EEN ) !* energy and enstrophy conserving scheme 178 192 CALL vor_een( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! total vorticity trend 179 IF( ln_stcor ) CALL vor_een( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 193 IF( ln_stcor .AND. .NOT. ln_vortex_force ) THEN 194 CALL vor_een( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend 195 ELSE IF( ln_stcor .AND. ln_vortex_force ) THEN 196 CALL vor_een( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) ) ! add the Stokes-Coriolis trend and vortex force 197 ENDIF 180 198 END SELECT 181 199 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/DYN/dynzad.F90
r13497 r14046 16 16 USE trd_oce ! trends: ocean variables 17 17 USE trddyn ! trend manager: dynamics 18 USE sbcwave, ONLY: wsd ! Surface Waves (add vertical Stokes-drift) 18 19 ! 19 20 USE in_out_manager ! I/O manager … … 79 80 DO jk = 2, jpkm1 ! Vertical momentum advection at level w and u- and v- vertical 80 81 DO_2D( 0, 1, 0, 1 ) ! vertical fluxes 82 IF( ln_vortex_force ) THEN 83 zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * ( ww(ji,jj,jk) + wsd(ji,jj,jk) ) 84 ELSE 81 85 zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) 86 ENDIF 82 87 END_2D 83 88 DO_2D( 0, 0, 0, 0 ) ! vertical momentum advection at w-point -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/IOM/in_out_manager.F90
r13286 r14046 89 89 LOGICAL :: lrst_abl !: logical to control the abl restart write 90 90 INTEGER :: numror = 0 !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90) 91 INTEGER :: numrir !: logical unit for ice restart (read) 92 INTEGER :: numrar !: logical unit for abl restart (read) 93 INTEGER :: numrow !: logical unit for ocean restart (write) 94 INTEGER :: numriw !: logical unit for ice restart (write) 95 INTEGER :: numraw !: logical unit for abl restart (write) 91 INTEGER :: numrir = 0 !: logical unit for ice restart (read) 92 INTEGER :: numrar = 0 !: logical unit for abl restart (read) 93 INTEGER :: numrow = 0 !: logical unit for ocean restart (write) 94 INTEGER :: numriw = 0 !: logical unit for ice restart (write) 95 INTEGER :: numraw = 0 !: logical unit for abl restart (write) 96 INTEGER :: numrtr = 0 !: trc restart (read ) 97 INTEGER :: numrtw = 0 !: trc restart (write ) 98 INTEGER :: numrsr = 0 !: logical unit for sed restart (read) 99 INTEGER :: numrsw = 0 !: logical unit for sed restart (write) 100 96 101 INTEGER :: nrst_lst !: number of restart to output next 97 102 … … 165 170 LOGICAL :: lwp = .FALSE. !: boolean : true on the 1st processor only .OR. sn_cfctl%l_oceout=T 166 171 LOGICAL :: lsp_area = .TRUE. !: to make a control print over a specific area 167 CHARACTER(lc) :: cxios_context !: context name used in xios 168 CHARACTER(lc) :: crxios_context !: context name used in xios to read restart 169 CHARACTER(lc) :: cwxios_context !: context name used in xios to write restart file 172 CHARACTER(LEN=lc) :: cxios_context !: context name used in xios 173 CHARACTER(LEN=lc) :: cr_ocerst_cxt !: context name used in xios to read OCE restart 174 CHARACTER(LEN=lc) :: cw_ocerst_cxt !: context name used in xios to write OCE restart file 175 CHARACTER(LEN=lc) :: cr_icerst_cxt !: context name used in xios to read SI3 restart 176 CHARACTER(LEN=lc) :: cw_icerst_cxt !: context name used in xios to write SI3 restart file 177 CHARACTER(LEN=lc) :: cr_toprst_cxt !: context name used in xios to read TOP restart 178 CHARACTER(LEN=lc) :: cw_toprst_cxt !: context name used in xios to write TOP restart file 179 CHARACTER(LEN=lc) :: cr_sedrst_cxt !: context name used in xios to read SEDIMENT restart 180 CHARACTER(LEN=lc) :: cw_sedrst_cxt !: context name used in xios to write SEDIMENT restart file 181 182 183 170 184 171 185 !! * Substitutions -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/IOM/iom.F90
r13910 r14046 46 46 USE lib_fortran 47 47 USE diu_bulk, ONLY : ln_diurnal_only, ln_diurnal 48 USE iom_nf90 49 USE netcdf 48 50 49 51 IMPLICIT NONE … … 58 60 PUBLIC iom_chkatt, iom_getatt, iom_putatt, iom_getszuld, iom_rstput, iom_delay_rst, iom_put 59 61 PUBLIC iom_use, iom_context_finalize, iom_update_file_name, iom_miss_val 62 PUBLIC iom_xios_setid 60 63 61 64 PRIVATE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp … … 69 72 PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr 70 73 PRIVATE set_grid, set_grid_bounds, set_scalar, set_xmlatt, set_mooring, iom_sdate 71 PRIVATE iom_set_rst_context, iom_set_ rstw_active, iom_set_rstr_active74 PRIVATE iom_set_rst_context, iom_set_vars_active 72 75 # endif 73 PUBLIC iom_set_rstw_var_active, iom_set_rstw_core, iom_set_rst_vars 76 PRIVATE set_xios_context 77 PRIVATE iom_set_rstw_active 74 78 75 79 INTERFACE iom_get … … 101 105 CONTAINS 102 106 103 SUBROUTINE iom_init( cdname, fname, ld_closedef )107 SUBROUTINE iom_init( cdname, kdid, ld_closedef ) 104 108 !!---------------------------------------------------------------------- 105 109 !! *** ROUTINE *** … … 109 113 !!---------------------------------------------------------------------- 110 114 CHARACTER(len=*), INTENT(in) :: cdname 111 CHARACTER(len=*), OPTIONAL, INTENT(in) :: fname115 INTEGER , OPTIONAL, INTENT(in) :: kdid 112 116 LOGICAL , OPTIONAL, INTENT(in) :: ld_closedef 113 117 #if defined key_iomput … … 118 122 INTEGER :: irefyear, irefmonth, irefday 119 123 INTEGER :: ji 120 LOGICAL :: llrst_context ! is context related to restart 124 LOGICAL :: llrst_context ! is context related to restart 125 LOGICAL :: llrstr, llrstw 126 INTEGER :: inum 121 127 ! 122 128 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zt_bnds, zw_bnds 123 129 REAL(wp), DIMENSION(2,jpkam1) :: za_bnds ! ABL vertical boundaries 124 LOGICAL :: ll_closedef = .TRUE.130 LOGICAL :: ll_closedef 125 131 LOGICAL :: ll_exist 126 132 !!---------------------------------------------------------------------- 127 133 ! 134 ll_closedef = .TRUE. 128 135 IF ( PRESENT(ld_closedef) ) ll_closedef = ld_closedef 129 136 ! … … 134 141 CALL xios_context_initialize(TRIM(clname), mpi_comm_oce) 135 142 CALL iom_swap( cdname ) 136 llrst_context = (TRIM(cdname) == TRIM(crxios_context) .OR. TRIM(cdname) == TRIM(cwxios_context)) 143 144 llrstr = (cdname == cr_ocerst_cxt) .OR. (cdname == cr_icerst_cxt) 145 llrstr = llrstr .OR. (cdname == cr_toprst_cxt) 146 llrstr = llrstr .OR. (cdname == cr_sedrst_cxt) 147 148 llrstw = (cdname == cw_ocerst_cxt) .OR. (cdname == cw_icerst_cxt) 149 llrstw = llrstw .OR. (cdname == cw_toprst_cxt) 150 llrstw = llrstw .OR. (cdname == cw_sedrst_cxt) 151 152 llrst_context = llrstr .OR. llrstw 137 153 138 154 ! Calendar type is now defined in xml file … … 153 169 IF(.NOT.llrst_context) CALL set_scalar 154 170 ! 155 IF( TRIM(cdname) == TRIM(cxios_context)) THEN171 IF( cdname == cxios_context ) THEN 156 172 CALL set_grid( "T", glamt, gphit, .FALSE., .FALSE. ) 157 173 CALL set_grid( "U", glamu, gphiu, .FALSE., .FALSE. ) … … 197 213 ! vertical grid definition 198 214 IF(.NOT.llrst_context) THEN 199 200 201 202 215 CALL iom_set_axis_attr( "deptht", paxis = gdept_1d ) 216 CALL iom_set_axis_attr( "depthu", paxis = gdept_1d ) 217 CALL iom_set_axis_attr( "depthv", paxis = gdept_1d ) 218 CALL iom_set_axis_attr( "depthw", paxis = gdepw_1d ) 203 219 204 220 ! ABL 205 206 207 208 209 210 211 221 IF( .NOT. ALLOCATED(ght_abl) ) THEN ! force definition for xml files (xios) 222 ALLOCATE( ght_abl(jpka), ghw_abl(jpka), e3t_abl(jpka), e3w_abl(jpka) ) ! default allocation needed by iom 223 ght_abl(:) = -1._wp ; ghw_abl(:) = -1._wp 224 e3t_abl(:) = -1._wp ; e3w_abl(:) = -1._wp 225 ENDIF 226 CALL iom_set_axis_attr( "ght_abl", ght_abl(2:jpka) ) 227 CALL iom_set_axis_attr( "ghw_abl", ghw_abl(2:jpka) ) 212 228 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 229 ! Add vertical grid bounds 230 zt_bnds(2,: ) = gdept_1d(:) 231 zt_bnds(1,2:jpk ) = gdept_1d(1:jpkm1) 232 zt_bnds(1,1 ) = gdept_1d(1) - e3w_1d(1) 233 zw_bnds(1,: ) = gdepw_1d(:) 234 zw_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) 235 zw_bnds(2,jpk: ) = gdepw_1d(jpk) + e3t_1d(jpk) 236 CALL iom_set_axis_attr( "deptht", bounds=zw_bnds ) 237 CALL iom_set_axis_attr( "depthu", bounds=zw_bnds ) 238 CALL iom_set_axis_attr( "depthv", bounds=zw_bnds ) 239 CALL iom_set_axis_attr( "depthw", bounds=zt_bnds ) 240 241 ! ABL 242 za_bnds(1,:) = ghw_abl(1:jpkam1) 243 za_bnds(2,:) = ghw_abl(2:jpka ) 244 CALL iom_set_axis_attr( "ght_abl", bounds=za_bnds ) 245 za_bnds(1,:) = ght_abl(2:jpka ) 246 za_bnds(2,:) = ght_abl(2:jpka ) + e3w_abl(2:jpka) 247 CALL iom_set_axis_attr( "ghw_abl", bounds=za_bnds ) 248 249 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 234 250 # if defined key_si3 235 236 237 251 CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 252 ! SIMIP diagnostics (4 main arctic straits) 253 CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) 238 254 # endif 239 255 #if defined key_top 240 241 #endif 242 243 244 245 246 247 248 249 256 IF( ALLOCATED(profsed) ) CALL iom_set_axis_attr( "profsed", paxis = profsed ) 257 #endif 258 CALL iom_set_axis_attr( "icbcla", class_num ) 259 CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) ! strange syntaxe and idea... 260 CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) ) ! strange syntaxe and idea... 261 CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) ! strange syntaxe and idea... 262 ! for diaprt, we need to define an axis which size can be 1 (default) or 5 (if the file subbasins.nc exists) 263 INQUIRE( FILE = 'subbasins.nc', EXIST = ll_exist ) 264 nbasin = 1 + 4 * COUNT( (/ll_exist/) ) 265 CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,nbasin) /) ) 250 266 ENDIF 251 267 ! 252 268 ! automatic definitions of some of the xml attributs 253 IF( TRIM(cdname) == TRIM(crxios_context) ) THEN 254 !set names of the fields in restart file IF using XIOS to read data 255 CALL iom_set_rst_context(.TRUE.) 256 CALL iom_set_rst_vars(rst_rfields) 257 !set which fields are to be read from restart file 258 CALL iom_set_rstr_active() 259 ELSE IF( TRIM(cdname) == TRIM(cwxios_context) ) THEN 260 !set names of the fields in restart file IF using XIOS to write data 261 CALL iom_set_rst_context(.FALSE.) 262 CALL iom_set_rst_vars(rst_wfields) 263 !set which fields are to be written to a restart file 264 CALL iom_set_rstw_active(fname) 269 IF(llrstr) THEN 270 IF(PRESENT(kdid)) THEN 271 CALL iom_set_rst_context(.TRUE.) 272 !set which fields will be read from restart file 273 CALL iom_set_vars_active(kdid) 274 ELSE 275 CALL ctl_stop( 'iom_init:', 'restart read with XIOS: missing pointer to NETCDF file' ) 276 ENDIF 277 ELSE IF(llrstw) THEN 278 CALL iom_set_rstw_file(iom_file(kdid)%name) 265 279 ELSE 266 280 CALL set_xmlatt 267 281 ENDIF 268 282 ! … … 280 294 END SUBROUTINE iom_init 281 295 282 SUBROUTINE iom_init_closedef 296 SUBROUTINE iom_init_closedef(cdname) 283 297 !!---------------------------------------------------------------------- 284 298 !! *** SUBROUTINE iom_init_closedef *** … … 288 302 !! 289 303 !!---------------------------------------------------------------------- 290 304 CHARACTER(len=*), OPTIONAL, INTENT(IN) :: cdname 291 305 #if defined key_iomput 292 CALL xios_close_context_definition() 293 CALL xios_update_calendar( 0 ) 306 LOGICAL :: llrstw 307 308 llrstw = .FALSE. 309 IF(PRESENT(cdname)) THEN 310 llrstw = (cdname == cw_ocerst_cxt) 311 llrstw = llrstw .OR. (cdname == cw_icerst_cxt) 312 llrstw = llrstw .OR. (cdname == cw_toprst_cxt) 313 llrstw = llrstw .OR. (cdname == cw_sedrst_cxt) 314 ENDIF 315 316 IF( llrstw ) THEN 317 !set names of the fields in restart file IF using XIOS to write data 318 CALL iom_set_rst_context(.FALSE.) 319 CALL xios_close_context_definition() 320 ELSE 321 CALL xios_close_context_definition() 322 CALL xios_update_calendar( 0 ) 323 ENDIF 294 324 #else 295 325 IF( .FALSE. ) WRITE(numout,*) 'iom_init_closedef: should not see this' ! useless statement to avoid compilation warnings … … 298 328 END SUBROUTINE iom_init_closedef 299 329 300 SUBROUTINE iom_set_ rstw_var_active(field)330 SUBROUTINE iom_set_vars_active(idnum) 301 331 !!--------------------------------------------------------------------- 302 !! *** SUBROUTINE iom_set_rstw_var_active *** 303 !! 304 !! ** Purpose : enable variable in restart file when writing with XIOS 332 !! *** SUBROUTINE iom_set_vars_active *** 333 !! 334 !! ** Purpose : define filename in XIOS context for reading file, 335 !! enable variables present in a file for reading with XIOS 336 !! id of the file is assumed to be rrestart. 305 337 !!--------------------------------------------------------------------- 306 CHARACTER(len = *), INTENT(IN) :: field 307 INTEGER :: i 308 LOGICAL :: llis_set 309 CHARACTER(LEN=256) :: clinfo ! info character 310 338 INTEGER, INTENT(IN) :: idnum 339 311 340 #if defined key_iomput 312 llis_set = .FALSE. 313 314 DO i = 1, max_rst_fields 315 IF(TRIM(rst_wfields(i)%vname) == field) THEN 316 rst_wfields(i)%active = .TRUE. 317 llis_set = .TRUE. 318 EXIT 319 ENDIF 320 ENDDO 321 !Warn if variable is not in defined in rst_wfields 322 IF(.NOT.llis_set) THEN 323 WRITE(ctmp1,*) 'iom_set_rstw_var_active: variable ', field ,' is available for writing but not defined' 324 CALL ctl_stop( 'iom_set_rstw_var_active:', ctmp1 ) 325 ENDIF 326 #else 327 clinfo = 'iom_set_rstw_var_active: key_iomput is needed to use XIOS restart read/write functionality' 328 CALL ctl_stop('STOP', TRIM(clinfo)) 329 #endif 330 331 END SUBROUTINE iom_set_rstw_var_active 332 333 SUBROUTINE iom_set_rstr_active() 341 INTEGER :: ndims, nvars, natts, unlimitedDimId, dimlen, xtype,mdims 342 TYPE(xios_field) :: field_hdl 343 TYPE(xios_file) :: file_hdl 344 TYPE(xios_filegroup) :: filegroup_hdl 345 INTEGER :: dimids(4), jv,i, idim 346 CHARACTER(LEN=256) :: clinfo ! info character 347 INTEGER, ALLOCATABLE :: indimlens(:) 348 CHARACTER(LEN=nf90_max_name), ALLOCATABLE :: indimnames(:) 349 CHARACTER(LEN=nf90_max_name) :: dimname, varname 350 INTEGER :: iln 351 CHARACTER(LEN=lc) :: fname 352 LOGICAL :: lmeta 353 !metadata in restart file for restart read with XIOS 354 INTEGER, PARAMETER :: NMETA = 10 355 CHARACTER(LEN=lc) :: meta(NMETA) 356 357 358 meta(1) = "nav_lat" 359 meta(2) = "nav_lon" 360 meta(3) = "nav_lev" 361 meta(4) = "time_instant" 362 meta(5) = "time_instant_bounds" 363 meta(6) = "time_counter" 364 meta(7) = "time_counter_bounds" 365 meta(8) = "x" 366 meta(9) = "y" 367 meta(10) = "numcat" 368 369 clinfo = ' iom_set_vars_active, file: '//TRIM(iom_file(idnum)%name) 370 371 iln = INDEX( iom_file(idnum)%name, '.nc' ) 372 !XIOS doee not need .nc 373 IF(iln > 0) THEN 374 fname = iom_file(idnum)%name(1:iln-1) 375 ELSE 376 fname = iom_file(idnum)%name 377 ENDIF 378 379 !set name of the restart file and enable available fields 380 CALL xios_get_handle("file_definition", filegroup_hdl ) 381 CALL xios_add_child(filegroup_hdl, file_hdl, 'rrestart') 382 CALL xios_set_file_attr( "rrestart", name=fname, type="one_file", & 383 par_access="collective", enabled=.TRUE., mode="read", & 384 output_freq=xios_timestep ) 385 386 CALL iom_nf90_check( nf90_inquire(iom_file(idnum)%nfid, ndims, nvars, natts ), clinfo ) 387 ALLOCATE(indimlens(ndims), indimnames(ndims)) 388 CALL iom_nf90_check( nf90_inquire(iom_file(idnum)%nfid, unlimitedDimId = unlimitedDimId ), clinfo ) 389 390 DO idim = 1, ndims 391 CALL iom_nf90_check( nf90_inquire_dimension(iom_file(idnum)%nfid, idim, dimname, dimlen ), clinfo ) 392 indimlens(idim) = dimlen 393 indimnames(idim) = dimname 394 ENDDO 395 396 DO jv =1, nvars 397 lmeta = .FALSE. 398 CALL iom_nf90_check( nf90_inquire_variable(iom_file(idnum)%nfid, jv, varname, xtype, ndims, dimids, natts ), clinfo ) 399 DO i = 1, NMETA 400 IF(varname == meta(i)) THEN 401 lmeta = .TRUE. 402 ENDIF 403 ENDDO 404 IF(.NOT.lmeta) THEN 405 CALL xios_add_child(file_hdl, field_hdl, varname) 406 mdims = ndims 407 408 IF(ANY(dimids(1:ndims) == unlimitedDimId)) THEN 409 mdims = mdims - 1 410 ENDIF 411 412 IF(mdims == 3) THEN 413 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & 414 domain_ref="grid_N", & 415 axis_ref=iom_axis(indimlens(dimids(mdims))), & 416 prec = 8, operation = "instant" ) 417 ELSEIF(mdims == 2) THEN 418 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & 419 domain_ref="grid_N", prec = 8, & 420 operation = "instant" ) 421 ELSEIF(mdims == 1) THEN 422 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & 423 axis_ref=iom_axis(indimlens(dimids(mdims))), & 424 prec = 8, operation = "instant" ) 425 ELSEIF(mdims == 0) THEN 426 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & 427 scalar_ref = "grid_scalar", prec = 8, & 428 operation = "instant" ) 429 ELSE 430 WRITE(ctmp1,*) 'iom_set_vars_active: variable ', TRIM(varname) ,' incorrect number of dimensions' 431 CALL ctl_stop( 'iom_set_vars_active:', ctmp1 ) 432 ENDIF 433 ENDIF 434 ENDDO 435 DEALLOCATE(indimlens, indimnames) 436 #endif 437 END SUBROUTINE iom_set_vars_active 438 439 SUBROUTINE iom_set_rstw_file(cdrst_file) 334 440 !!--------------------------------------------------------------------- 335 !! *** SUBROUTINE iom_set_rstr_active *** 336 !! 337 !! ** Purpose : define file name in XIOS context for reading restart file, 338 !! enable variables present in restart file for reading with XIOS 441 !! *** SUBROUTINE iom_set_rstw_file *** 442 !! 443 !! ** Purpose : define file name in XIOS context for writing restart 339 444 !!--------------------------------------------------------------------- 340 341 !sets enabled = .TRUE. for each field in restart file 342 CHARACTER(len=256) :: rst_file 343 445 CHARACTER(len=*) :: cdrst_file 344 446 #if defined key_iomput 345 TYPE(xios_field) :: field_hdl 346 TYPE(xios_file) :: file_hdl 347 TYPE(xios_filegroup) :: filegroup_hdl 348 INTEGER :: i 349 CHARACTER(lc) :: clpath 350 351 clpath = TRIM(cn_ocerst_indir) 352 IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' 353 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 354 rst_file = TRIM(clpath)//TRIM(cn_ocerst_in) 355 ELSE 356 rst_file = TRIM(clpath)//TRIM(Agrif_CFixed())//'_'//TRIM(cn_ocerst_in) 357 ENDIF 447 TYPE(xios_file) :: file_hdl 448 TYPE(xios_filegroup) :: filegroup_hdl 449 358 450 !set name of the restart file and enable available fields 359 if(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS) to: ',rst_file 360 CALL xios_get_handle("file_definition", filegroup_hdl ) 361 CALL xios_add_child(filegroup_hdl, file_hdl, 'rrestart') 362 CALL xios_set_file_attr( "rrestart", name=trim(rst_file), type="one_file", & 363 par_access="collective", enabled=.TRUE., mode="read", & 364 output_freq=xios_timestep) 365 !define variables for restart context 366 DO i = 1, max_rst_fields 367 IF( TRIM(rst_rfields(i)%vname) /= "NO_NAME") THEN 368 IF( iom_varid( numror, TRIM(rst_rfields(i)%vname), ldstop = .FALSE. ) > 0 ) THEN 369 CALL xios_add_child(file_hdl, field_hdl, TRIM(rst_rfields(i)%vname)) 370 SELECT CASE (TRIM(rst_rfields(i)%grid)) 371 CASE ("grid_N_3D") 372 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & 373 domain_ref="grid_N", axis_ref="nav_lev", operation = "instant") 374 CASE ("grid_N") 375 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & 376 domain_ref="grid_N", operation = "instant") 377 CASE ("grid_vector") 378 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & 379 axis_ref="nav_lev", operation = "instant") 380 CASE ("grid_scalar") 381 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & 382 scalar_ref = "grid_scalar", operation = "instant") 383 END SELECT 384 IF(lwp) WRITE(numout,*) 'XIOS read: ', TRIM(rst_rfields(i)%vname), ' enabled in ', TRIM(rst_file) 385 ENDIF 386 ENDIF 387 END DO 388 #endif 389 END SUBROUTINE iom_set_rstr_active 390 391 SUBROUTINE iom_set_rstw_core(cdmdl) 392 !!--------------------------------------------------------------------- 393 !! *** SUBROUTINE iom_set_rstw_core *** 394 !! 395 !! ** Purpose : set variables which are always in restart file 396 !!--------------------------------------------------------------------- 397 CHARACTER (len=*), INTENT (IN) :: cdmdl ! model OPA or SAS 398 CHARACTER(LEN=256) :: clinfo ! info character 399 #if defined key_iomput 400 IF(cdmdl == "OPA") THEN 401 !from restart.F90 402 CALL iom_set_rstw_var_active("rn_Dt") 403 IF ( .NOT. ln_diurnal_only ) THEN 404 CALL iom_set_rstw_var_active('ub' ) 405 CALL iom_set_rstw_var_active('vb' ) 406 CALL iom_set_rstw_var_active('tb' ) 407 CALL iom_set_rstw_var_active('sb' ) 408 CALL iom_set_rstw_var_active('sshb') 409 ! 410 CALL iom_set_rstw_var_active('un' ) 411 CALL iom_set_rstw_var_active('vn' ) 412 CALL iom_set_rstw_var_active('tn' ) 413 CALL iom_set_rstw_var_active('sn' ) 414 CALL iom_set_rstw_var_active('sshn') 415 CALL iom_set_rstw_var_active('rhop') 416 ENDIF 417 IF(ln_diurnal) CALL iom_set_rstw_var_active('Dsst') 418 !from trasbc.F90 419 CALL iom_set_rstw_var_active('sbc_hc_b') 420 CALL iom_set_rstw_var_active('sbc_sc_b') 421 ENDIF 422 #else 423 clinfo = 'iom_set_rstw_core: key_iomput is needed to use XIOS restart read/write functionality' 424 CALL ctl_stop('STOP', TRIM(clinfo)) 425 #endif 426 END SUBROUTINE iom_set_rstw_core 427 428 SUBROUTINE iom_set_rst_vars(fields) 429 !!--------------------------------------------------------------------- 430 !! *** SUBROUTINE iom_set_rst_vars *** 431 !! 432 !! ** Purpose : Fill array fields with the information about all 433 !! possible variables and corresponding grids definition 434 !! for reading/writing restart with XIOS 435 !!--------------------------------------------------------------------- 436 TYPE(RST_FIELD), INTENT(INOUT) :: fields(max_rst_fields) 437 INTEGER :: i 438 439 i = 0 440 i = i + 1; fields(i)%vname="rn_Dt"; fields(i)%grid="grid_scalar" 441 i = i + 1; fields(i)%vname="un"; fields(i)%grid="grid_N_3D" 442 i = i + 1; fields(i)%vname="ub"; fields(i)%grid="grid_N_3D" 443 i = i + 1; fields(i)%vname="vn"; fields(i)%grid="grid_N_3D" 444 i = i + 1; fields(i)%vname="vb"; fields(i)%grid="grid_N_3D" 445 i = i + 1; fields(i)%vname="tn"; fields(i)%grid="grid_N_3D" 446 i = i + 1; fields(i)%vname="tb"; fields(i)%grid="grid_N_3D" 447 i = i + 1; fields(i)%vname="sn"; fields(i)%grid="grid_N_3D" 448 i = i + 1; fields(i)%vname="sb"; fields(i)%grid="grid_N_3D" 449 i = i + 1; fields(i)%vname="sshn"; fields(i)%grid="grid_N" 450 i = i + 1; fields(i)%vname="sshb"; fields(i)%grid="grid_N" 451 i = i + 1; fields(i)%vname="rhop"; fields(i)%grid="grid_N_3D" 452 i = i + 1; fields(i)%vname="kt"; fields(i)%grid="grid_scalar" 453 i = i + 1; fields(i)%vname="ndastp"; fields(i)%grid="grid_scalar" 454 i = i + 1; fields(i)%vname="adatrj"; fields(i)%grid="grid_scalar" 455 i = i + 1; fields(i)%vname="utau_b"; fields(i)%grid="grid_N" 456 i = i + 1; fields(i)%vname="vtau_b"; fields(i)%grid="grid_N" 457 i = i + 1; fields(i)%vname="qns_b"; fields(i)%grid="grid_N" 458 i = i + 1; fields(i)%vname="emp_b"; fields(i)%grid="grid_N" 459 i = i + 1; fields(i)%vname="sfx_b"; fields(i)%grid="grid_N" 460 i = i + 1; fields(i)%vname="en" ; fields(i)%grid="grid_N_3D" 461 i = i + 1; fields(i)%vname="avt_k"; fields(i)%grid="grid_N_3D" 462 i = i + 1; fields(i)%vname="avm_k"; fields(i)%grid="grid_N_3D" 463 i = i + 1; fields(i)%vname="dissl"; fields(i)%grid="grid_N_3D" 464 i = i + 1; fields(i)%vname="sbc_hc_b"; fields(i)%grid="grid_N" 465 i = i + 1; fields(i)%vname="sbc_sc_b"; fields(i)%grid="grid_N" 466 i = i + 1; fields(i)%vname="qsr_hc_b"; fields(i)%grid="grid_N_3D" 467 i = i + 1; fields(i)%vname="fraqsr_1lev"; fields(i)%grid="grid_N" 468 i = i + 1; fields(i)%vname="greenland_icesheet_mass" 469 fields(i)%grid="grid_scalar" 470 i = i + 1; fields(i)%vname="greenland_icesheet_timelapsed" 471 fields(i)%grid="grid_scalar" 472 i = i + 1; fields(i)%vname="greenland_icesheet_mass_roc" 473 fields(i)%grid="grid_scalar" 474 i = i + 1; fields(i)%vname="antarctica_icesheet_mass" 475 fields(i)%grid="grid_scalar" 476 i = i + 1; fields(i)%vname="antarctica_icesheet_timelapsed" 477 fields(i)%grid="grid_scalar" 478 i = i + 1; fields(i)%vname="antarctica_icesheet_mass_roc" 479 fields(i)%grid="grid_scalar" 480 i = i + 1; fields(i)%vname="frc_v"; fields(i)%grid="grid_scalar" 481 i = i + 1; fields(i)%vname="frc_t"; fields(i)%grid="grid_scalar" 482 i = i + 1; fields(i)%vname="frc_s"; fields(i)%grid="grid_scalar" 483 i = i + 1; fields(i)%vname="frc_wn_t"; fields(i)%grid="grid_scalar" 484 i = i + 1; fields(i)%vname="frc_wn_s"; fields(i)%grid="grid_scalar" 485 i = i + 1; fields(i)%vname="ssh_ini"; fields(i)%grid="grid_N" 486 i = i + 1; fields(i)%vname="e3t_ini"; fields(i)%grid="grid_N_3D" 487 i = i + 1; fields(i)%vname="hc_loc_ini"; fields(i)%grid="grid_N_3D" 488 i = i + 1; fields(i)%vname="sc_loc_ini"; fields(i)%grid="grid_N_3D" 489 i = i + 1; fields(i)%vname="ssh_hc_loc_ini"; fields(i)%grid="grid_N" 490 i = i + 1; fields(i)%vname="ssh_sc_loc_ini"; fields(i)%grid="grid_N" 491 i = i + 1; fields(i)%vname="tilde_e3t_b"; fields(i)%grid="grid_N" 492 i = i + 1; fields(i)%vname="tilde_e3t_n"; fields(i)%grid="grid_N" 493 i = i + 1; fields(i)%vname="hdiv_lf"; fields(i)%grid="grid_N" 494 i = i + 1; fields(i)%vname="ub2_b"; fields(i)%grid="grid_N" 495 i = i + 1; fields(i)%vname="vb2_b"; fields(i)%grid="grid_N" 496 i = i + 1; fields(i)%vname="sshbb_e"; fields(i)%grid="grid_N" 497 i = i + 1; fields(i)%vname="ubb_e"; fields(i)%grid="grid_N" 498 i = i + 1; fields(i)%vname="vbb_e"; fields(i)%grid="grid_N" 499 i = i + 1; fields(i)%vname="sshb_e"; fields(i)%grid="grid_N" 500 i = i + 1; fields(i)%vname="ub_e"; fields(i)%grid="grid_N" 501 i = i + 1; fields(i)%vname="vb_e"; fields(i)%grid="grid_N" 502 i = i + 1; fields(i)%vname="fwf_isf_b"; fields(i)%grid="grid_N" 503 i = i + 1; fields(i)%vname="isf_sc_b"; fields(i)%grid="grid_N" 504 i = i + 1; fields(i)%vname="isf_hc_b"; fields(i)%grid="grid_N" 505 i = i + 1; fields(i)%vname="ssh_ibb"; fields(i)%grid="grid_N" 506 i = i + 1; fields(i)%vname="rnf_b"; fields(i)%grid="grid_N" 507 i = i + 1; fields(i)%vname="rnf_hc_b"; fields(i)%grid="grid_N" 508 i = i + 1; fields(i)%vname="rnf_sc_b"; fields(i)%grid="grid_N" 509 i = i + 1; fields(i)%vname="nn_fsbc"; fields(i)%grid="grid_scalar" 510 i = i + 1; fields(i)%vname="ssu_m"; fields(i)%grid="grid_N" 511 i = i + 1; fields(i)%vname="ssv_m"; fields(i)%grid="grid_N" 512 i = i + 1; fields(i)%vname="sst_m"; fields(i)%grid="grid_N" 513 i = i + 1; fields(i)%vname="sss_m"; fields(i)%grid="grid_N" 514 i = i + 1; fields(i)%vname="ssh_m"; fields(i)%grid="grid_N" 515 i = i + 1; fields(i)%vname="e3t_m"; fields(i)%grid="grid_N" 516 i = i + 1; fields(i)%vname="frq_m"; fields(i)%grid="grid_N" 517 i = i + 1; fields(i)%vname="avmb"; fields(i)%grid="grid_vector" 518 i = i + 1; fields(i)%vname="avtb"; fields(i)%grid="grid_vector" 519 i = i + 1; fields(i)%vname="ub2_i_b"; fields(i)%grid="grid_N" 520 i = i + 1; fields(i)%vname="vb2_i_b"; fields(i)%grid="grid_N" 521 i = i + 1; fields(i)%vname="ntime"; fields(i)%grid="grid_scalar" 522 i = i + 1; fields(i)%vname="Dsst"; fields(i)%grid="grid_scalar" 523 i = i + 1; fields(i)%vname="tmask"; fields(i)%grid="grid_N_3D" 524 i = i + 1; fields(i)%vname="umask"; fields(i)%grid="grid_N_3D" 525 i = i + 1; fields(i)%vname="vmask"; fields(i)%grid="grid_N_3D" 526 i = i + 1; fields(i)%vname="smask"; fields(i)%grid="grid_N_3D" 527 i = i + 1; fields(i)%vname="gdepw_n"; fields(i)%grid="grid_N_3D" 528 i = i + 1; fields(i)%vname="e3t_n"; fields(i)%grid="grid_N_3D" 529 i = i + 1; fields(i)%vname="e3u_n"; fields(i)%grid="grid_N_3D" 530 i = i + 1; fields(i)%vname="e3v_n"; fields(i)%grid="grid_N_3D" 531 i = i + 1; fields(i)%vname="surf_ini"; fields(i)%grid="grid_N" 532 i = i + 1; fields(i)%vname="e3t_b"; fields(i)%grid="grid_N_3D" 533 i = i + 1; fields(i)%vname="hmxl_n"; fields(i)%grid="grid_N_3D" 534 i = i + 1; fields(i)%vname="un_bf"; fields(i)%grid="grid_N" 535 i = i + 1; fields(i)%vname="vn_bf"; fields(i)%grid="grid_N" 536 i = i + 1; fields(i)%vname="hbl"; fields(i)%grid="grid_N" 537 i = i + 1; fields(i)%vname="hbli"; fields(i)%grid="grid_N" 538 i = i + 1; fields(i)%vname="wn"; fields(i)%grid="grid_N_3D" 539 540 IF( i-1 > max_rst_fields) THEN 541 WRITE(ctmp1,*) 'E R R O R : iom_set_rst_vars SIZE of RST_FIELD array is too small' 542 CALL ctl_stop( 'iom_set_rst_vars:', ctmp1 ) 543 ENDIF 544 END SUBROUTINE iom_set_rst_vars 545 546 547 SUBROUTINE iom_set_rstw_active(cdrst_file) 451 IF(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS write) to: ', TRIM(cdrst_file) 452 CALL xios_get_handle("file_definition", filegroup_hdl ) 453 CALL xios_add_child(filegroup_hdl, file_hdl, 'wrestart') 454 IF(nxioso.eq.1) THEN 455 CALL xios_set_file_attr( "wrestart", type="one_file", enabled=.TRUE.,& 456 mode="write", output_freq=xios_timestep) 457 IF(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in one_file mode' 458 ELSE 459 CALL xios_set_file_attr( "wrestart", type="multiple_file", enabled=.TRUE.,& 460 mode="write", output_freq=xios_timestep) 461 IF(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in multiple_file mode' 462 ENDIF 463 CALL xios_set_file_attr( "wrestart", name=trim(cdrst_file)) 464 #endif 465 END SUBROUTINE iom_set_rstw_file 466 467 468 SUBROUTINE iom_set_rstw_active(sdfield, rd0, rs0, rd1, rs1, rd2, rs2, rd3, rs3) 548 469 !!--------------------------------------------------------------------- 549 470 !! *** SUBROUTINE iom_set_rstw_active *** … … 553 474 !!--------------------------------------------------------------------- 554 475 !sets enabled = .TRUE. for each field in restart file 555 CHARACTER(len=*) :: cdrst_file 476 CHARACTER(len = *), INTENT(IN) :: sdfield 477 REAL(dp), OPTIONAL, INTENT(IN) :: rd0 478 REAL(sp), OPTIONAL, INTENT(IN) :: rs0 479 REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:) :: rd1 480 REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:) :: rs1 481 REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:, :) :: rd2 482 REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:, :) :: rs2 483 REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:, :, :) :: rd3 484 REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:, :, :) :: rs3 556 485 #if defined key_iomput 557 TYPE(xios_field) :: field_hdl 558 TYPE(xios_file) :: file_hdl 559 TYPE(xios_filegroup) :: filegroup_hdl 560 INTEGER :: i 561 CHARACTER(lc) :: clpath 562 563 !set name of the restart file and enable available fields 564 IF(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS write) to: ',cdrst_file 565 CALL xios_get_handle("file_definition", filegroup_hdl ) 566 CALL xios_add_child(filegroup_hdl, file_hdl, 'wrestart') 567 IF(nxioso.eq.1) THEN 568 CALL xios_set_file_attr( "wrestart", type="one_file", enabled=.TRUE.,& 569 mode="write", output_freq=xios_timestep) 570 if(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in one_file mode' 571 ELSE 572 CALL xios_set_file_attr( "wrestart", type="multiple_file", enabled=.TRUE.,& 573 mode="write", output_freq=xios_timestep) 574 if(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in multiple_file mode' 575 ENDIF 576 CALL xios_set_file_attr( "wrestart", name=trim(cdrst_file)) 486 TYPE(xios_field) :: field_hdl 487 TYPE(xios_file) :: file_hdl 488 489 CALL xios_get_handle("wrestart", file_hdl) 577 490 !define fields for restart context 578 DO i = 1, max_rst_fields 579 IF( rst_wfields(i)%active ) THEN 580 CALL xios_add_child(file_hdl, field_hdl, TRIM(rst_wfields(i)%vname)) 581 SELECT CASE (TRIM(rst_wfields(i)%grid)) 582 CASE ("grid_N_3D") 583 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & 584 domain_ref="grid_N", axis_ref="nav_lev", prec = 8, operation = "instant") 585 CASE ("grid_N") 586 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & 587 domain_ref="grid_N", prec = 8, operation = "instant") 588 CASE ("grid_vector") 589 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & 590 axis_ref="nav_lev", prec = 8, operation = "instant") 591 CASE ("grid_scalar") 592 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & 593 scalar_ref = "grid_scalar", prec = 8, operation = "instant") 594 END SELECT 595 ENDIF 596 END DO 491 CALL xios_add_child(file_hdl, field_hdl, sdfield) 492 493 IF(PRESENT(rd3)) THEN 494 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 495 domain_ref = "grid_N", & 496 axis_ref = iom_axis(size(rd3, 3)), & 497 prec = 8, operation = "instant" ) 498 ELSEIF(PRESENT(rs3)) THEN 499 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 500 domain_ref = "grid_N", & 501 axis_ref = iom_axis(size(rd3, 3)), & 502 prec = 4, operation = "instant" ) 503 ELSEIF(PRESENT(rd2)) THEN 504 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 505 domain_ref = "grid_N", prec = 8, & 506 operation = "instant" ) 507 ELSEIF(PRESENT(rs2)) THEN 508 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 509 domain_ref = "grid_N", prec = 4, & 510 operation = "instant" ) 511 ELSEIF(PRESENT(rd1)) THEN 512 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 513 axis_ref = iom_axis(size(rd1, 1)), & 514 prec = 8, operation = "instant" ) 515 ELSEIF(PRESENT(rs1)) THEN 516 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 517 axis_ref = iom_axis(size(rd1, 1)), & 518 prec = 4, operation = "instant" ) 519 ELSEIF(PRESENT(rd0)) THEN 520 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 521 scalar_ref = "grid_scalar", prec = 8, & 522 operation = "instant" ) 523 ELSEIF(PRESENT(rs0)) THEN 524 CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 525 scalar_ref = "grid_scalar", prec = 4, & 526 operation = "instant" ) 527 ENDIF 597 528 #endif 598 529 END SUBROUTINE iom_set_rstw_active 599 530 531 FUNCTION iom_axis(idlev) result(axis_ref) 532 !!--------------------------------------------------------------------- 533 !! *** FUNCTION iom_axis *** 534 !! 535 !! ** Purpose : Used for grid definition when XIOS is used to read/write 536 !! restart. Returns axis corresponding to the number of levels 537 !! given as an input variable. Axes are defined in routine 538 !! iom_set_rst_context 539 !!--------------------------------------------------------------------- 540 INTEGER, INTENT(IN) :: idlev 541 CHARACTER(len=lc) :: axis_ref 542 CHARACTER(len=12) :: str 543 IF(idlev == jpk) THEN 544 axis_ref="nav_lev" 545 #if defined key_si3 546 ELSEIF(idlev == jpl) THEN 547 axis_ref="numcat" 548 #endif 549 ELSE 550 write(str, *) idlev 551 CALL ctl_stop( 'iom_axis', 'Definition for axis with '//TRIM(ADJUSTL(str))//' levels missing') 552 ENDIF 553 END FUNCTION iom_axis 554 555 FUNCTION iom_xios_setid(cdname) result(kid) 556 !!--------------------------------------------------------------------- 557 !! *** FUNCTION *** 558 !! 559 !! ** Purpose : this function returns first available id to keep information about file 560 !! sets filename in iom_file structure and sets name 561 !! of XIOS context depending on cdcomp 562 !! corresponds to iom_nf90_open 563 !!--------------------------------------------------------------------- 564 CHARACTER(len=*), INTENT(in ) :: cdname ! File name 565 INTEGER :: kid ! identifier of the opened file 566 INTEGER :: jl 567 568 kid = 0 569 DO jl = jpmax_files, 1, -1 570 IF( iom_file(jl)%nfid == 0 ) kid = jl 571 ENDDO 572 573 iom_file(kid)%name = TRIM(cdname) 574 iom_file(kid)%nfid = 1 575 iom_file(kid)%nvars = 0 576 iom_file(kid)%irec = -1 577 578 END FUNCTION iom_xios_setid 579 600 580 SUBROUTINE iom_set_rst_context(ld_rstr) 601 !!---------------------------------------------------------------------581 !!--------------------------------------------------------------------- 602 582 !! *** SUBROUTINE iom_set_rst_context *** 603 583 !! … … 606 586 !! 607 587 !!--------------------------------------------------------------------- 608 LOGICAL, INTENT(IN) :: ld_rstr 609 !ld_rstr is true for restart context. There is no need to define grid for 610 !restart read, because it's read from file 588 LOGICAL, INTENT(IN) :: ld_rstr 589 INTEGER :: ji 611 590 #if defined key_iomput 612 TYPE(xios_domaingroup) :: domaingroup_hdl613 TYPE(xios_domain) :: domain_hdl614 TYPE(xios_axisgroup) :: axisgroup_hdl615 TYPE(xios_axis) :: axis_hdl616 TYPE(xios_scalar) :: scalar_hdl617 TYPE(xios_scalargroup) :: scalargroup_hdl618 619 CALL xios_get_handle("domain_definition",domaingroup_hdl)620 CALL xios_add_child(domaingroup_hdl, domain_hdl, "grid_N")621 CALL set_grid("N", glamt, gphit, .TRUE., ld_rstr)591 TYPE(xios_domaingroup) :: domaingroup_hdl 592 TYPE(xios_domain) :: domain_hdl 593 TYPE(xios_axisgroup) :: axisgroup_hdl 594 TYPE(xios_axis) :: axis_hdl 595 TYPE(xios_scalar) :: scalar_hdl 596 TYPE(xios_scalargroup) :: scalargroup_hdl 597 598 CALL xios_get_handle("domain_definition",domaingroup_hdl) 599 CALL xios_add_child(domaingroup_hdl, domain_hdl, "grid_N") 600 CALL set_grid("N", glamt, gphit, .TRUE., ld_rstr) 622 601 623 CALL xios_get_handle("axis_definition",axisgroup_hdl)624 CALL xios_add_child(axisgroup_hdl, axis_hdl, "nav_lev")602 CALL xios_get_handle("axis_definition",axisgroup_hdl) 603 CALL xios_add_child(axisgroup_hdl, axis_hdl, "nav_lev") 625 604 !AGRIF fails to compile when unit= is in call to xios_set_axis_attr 626 ! CALL xios_set_axis_attr( "nav_lev", long_name="Vertical levels", unit="m", positive="down") 627 CALL xios_set_axis_attr( "nav_lev", long_name="Vertical levels in meters", positive="down") 628 CALL iom_set_axis_attr( "nav_lev", paxis = gdept_1d ) 629 630 CALL xios_get_handle("scalar_definition", scalargroup_hdl) 631 CALL xios_add_child(scalargroup_hdl, scalar_hdl, "grid_scalar") 605 ! CALL xios_set_axis_attr( "nav_lev", long_name="Vertical levels", unit="m", positive="down") 606 CALL xios_set_axis_attr( "nav_lev", long_name = "Vertical levels in meters", positive = "down") 607 CALL iom_set_axis_attr( "nav_lev", paxis = gdept_1d ) 608 #if defined key_si3 609 CALL xios_add_child(axisgroup_hdl, axis_hdl, "numcat") 610 CALL iom_set_axis_attr( "numcat", (/ (REAL(ji,wp), ji=1,jpl) /) ) 611 #endif 612 CALL xios_get_handle("scalar_definition", scalargroup_hdl) 613 CALL xios_add_child(scalargroup_hdl, scalar_hdl, "grid_scalar") 632 614 #endif 633 615 END SUBROUTINE iom_set_rst_context 616 617 618 SUBROUTINE set_xios_context(kdid, cdcont) 619 !!--------------------------------------------------------------------- 620 !! *** SUBROUTINE iom_set_rst_context *** 621 !! 622 !! ** Purpose : set correct XIOS context based on kdid 623 !! 624 !!--------------------------------------------------------------------- 625 INTEGER, INTENT(IN) :: kdid ! Identifier of the file 626 CHARACTER(LEN=lc), INTENT(OUT) :: cdcont ! name of the context for XIOS read/write 627 628 cdcont = "NONE" 629 630 IF(lrxios) THEN 631 IF(kdid == numror) THEN 632 cdcont = cr_ocerst_cxt 633 ELSEIF(kdid == numrir) THEN 634 cdcont = cr_icerst_cxt 635 ELSEIF(kdid == numrtr) THEN 636 cdcont = cr_toprst_cxt 637 ELSEIF(kdid == numrsr) THEN 638 cdcont = cr_sedrst_cxt 639 ENDIF 640 ENDIF 641 642 IF(lwxios) THEN 643 IF(kdid == numrow) THEN 644 cdcont = cw_ocerst_cxt 645 ELSEIF(kdid == numriw) THEN 646 cdcont = cw_icerst_cxt 647 ELSEIF(kdid == numrtw) THEN 648 cdcont = cw_toprst_cxt 649 ELSEIF(kdid == numrsw) THEN 650 cdcont = cw_sedrst_cxt 651 ENDIF 652 ENDIF 653 END SUBROUTINE set_xios_context 654 634 655 635 656 SUBROUTINE iom_swap( cdname ) … … 642 663 #if defined key_iomput 643 664 TYPE(xios_context) :: nemo_hdl 644 645 665 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 646 666 CALL xios_get_handle(TRIM(cdname),nemo_hdl) … … 892 912 !! INTERFACE iom_get 893 913 !!---------------------------------------------------------------------- 894 SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime , ldxios)914 SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime ) 895 915 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 896 916 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable … … 898 918 REAL(dp) :: ztmp_pvar ! tmp var to read field 899 919 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 900 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart901 920 ! 902 921 INTEGER :: idvar ! variable id … … 906 925 CHARACTER(LEN=100) :: clname ! file name 907 926 CHARACTER(LEN=1) :: cldmspc ! 908 LOGICAL :: llxios 909 ! 910 llxios = .FALSE. 911 IF( PRESENT(ldxios) ) llxios = ldxios 912 913 IF(.NOT.llxios) THEN ! read data using default library 927 CHARACTER(LEN=lc) :: context 928 ! 929 CALL set_xios_context(kiomid, context) 930 931 IF(context == "NONE") THEN ! read data using default library 914 932 itime = 1 915 933 IF( PRESENT(ktime) ) itime = ktime … … 934 952 #if defined key_iomput 935 953 IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 936 CALL iom_swap( TRIM(crxios_context))954 CALL iom_swap(context) 937 955 CALL xios_recv_field( trim(cdvar), pvar) 938 CALL iom_swap( TRIM(cxios_context))956 CALL iom_swap(cxios_context) 939 957 #else 940 958 WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) … … 944 962 END SUBROUTINE iom_g0d_sp 945 963 946 SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime , ldxios)964 SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime ) 947 965 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 948 966 CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable 949 967 REAL(dp) , INTENT( out) :: pvar ! read field 950 968 INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number 951 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart952 969 ! 953 970 INTEGER :: idvar ! variable id … … 957 974 CHARACTER(LEN=100) :: clname ! file name 958 975 CHARACTER(LEN=1) :: cldmspc ! 959 LOGICAL :: llxios 960 ! 961 llxios = .FALSE. 962 IF( PRESENT(ldxios) ) llxios = ldxios 963 964 IF(.NOT.llxios) THEN ! read data using default library 976 CHARACTER(LEN=lc) :: context 977 ! 978 CALL set_xios_context(kiomid, context) 979 980 IF(context == "NONE") THEN ! read data using default library 965 981 itime = 1 966 982 IF( PRESENT(ktime) ) itime = ktime … … 984 1000 #if defined key_iomput 985 1001 IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 986 CALL iom_swap( TRIM(crxios_context))1002 CALL iom_swap(context) 987 1003 CALL xios_recv_field( trim(cdvar), pvar) 988 CALL iom_swap( TRIM(cxios_context))1004 CALL iom_swap(cxios_context) 989 1005 #else 990 1006 WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) … … 994 1010 END SUBROUTINE iom_g0d_dp 995 1011 996 SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount , ldxios)1012 SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) 997 1013 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 998 1014 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 1003 1019 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading 1004 1020 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis 1005 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS1006 1021 ! 1007 1022 IF( kiomid > 0 ) THEN … … 1009 1024 ALLOCATE(ztmp_pvar(size(pvar,1))) 1010 1025 CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=ztmp_pvar, & 1011 & ktime=ktime, kstart=kstart, kcount=kcount, & 1012 & ldxios=ldxios ) 1026 & ktime=ktime, kstart=kstart, kcount=kcount ) 1013 1027 pvar = ztmp_pvar 1014 1028 DEALLOCATE(ztmp_pvar) … … 1018 1032 1019 1033 1020 SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount , ldxios)1034 SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) 1021 1035 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1022 1036 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 1026 1040 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading 1027 1041 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis 1028 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS1029 1042 ! 1030 1043 IF( kiomid > 0 ) THEN 1031 1044 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=pvar, & 1032 & ktime=ktime, kstart=kstart, kcount=kcount, & 1033 & ldxios=ldxios ) 1045 & ktime=ktime, kstart=kstart, kcount=kcount) 1034 1046 ENDIF 1035 1047 END SUBROUTINE iom_g1d_dp 1036 1048 1037 SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount , ldxios)1049 SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount) 1038 1050 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1039 1051 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 1047 1059 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading 1048 1060 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis 1049 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS1050 1061 ! 1051 1062 IF( kiomid > 0 ) THEN … … 1054 1065 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = ztmp_pvar , ktime = ktime, & 1055 1066 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1056 & kstart = kstart , kcount = kcount , ldxios=ldxios)1067 & kstart = kstart , kcount = kcount ) 1057 1068 pvar = ztmp_pvar 1058 1069 DEALLOCATE(ztmp_pvar) … … 1061 1072 END SUBROUTINE iom_g2d_sp 1062 1073 1063 SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount , ldxios)1074 SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount) 1064 1075 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1065 1076 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 1072 1083 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kstart ! start axis position of the reading 1073 1084 INTEGER , INTENT(in ), DIMENSION(2), OPTIONAL :: kcount ! number of points in each axis 1074 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS1075 1085 ! 1076 1086 IF( kiomid > 0 ) THEN 1077 1087 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar , pv_r2d = pvar , ktime = ktime, & 1078 1088 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1079 & kstart = kstart , kcount = kcount , ldxios=ldxios)1089 & kstart = kstart , kcount = kcount ) 1080 1090 ENDIF 1081 1091 END SUBROUTINE iom_g2d_dp 1082 1092 1083 SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount , ldxios)1093 SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount ) 1084 1094 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1085 1095 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 1093 1103 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading 1094 1104 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis 1095 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS1096 1105 ! 1097 1106 IF( kiomid > 0 ) THEN … … 1100 1109 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = ztmp_pvar , ktime = ktime, & 1101 1110 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1102 & kstart = kstart , kcount = kcount , ldxios=ldxios)1111 & kstart = kstart , kcount = kcount ) 1103 1112 pvar = ztmp_pvar 1104 1113 DEALLOCATE(ztmp_pvar) … … 1107 1116 END SUBROUTINE iom_g3d_sp 1108 1117 1109 SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount , ldxios)1118 SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount ) 1110 1119 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 1111 1120 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 1118 1127 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kstart ! start axis position of the reading 1119 1128 INTEGER , INTENT(in ), DIMENSION(3), OPTIONAL :: kcount ! number of points in each axis 1120 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS1121 1129 ! 1122 1130 IF( kiomid > 0 ) THEN … … 1124 1132 CALL iom_get_123d( kiomid, kdom, cdvar , pv_r3d = pvar , ktime = ktime, & 1125 1133 & cd_type = cd_type, psgn = psgn , kfill = kfill, & 1126 & kstart = kstart , kcount = kcount , ldxios=ldxios)1134 & kstart = kstart , kcount = kcount ) 1127 1135 END IF 1128 1136 ENDIF … … 1132 1140 1133 1141 SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime , & 1134 & cd_type, psgn, kfill, kstart, kcount , ldxios)1142 & cd_type, psgn, kfill, kstart, kcount ) 1135 1143 !!----------------------------------------------------------------------- 1136 1144 !! *** ROUTINE iom_get_123d *** … … 1152 1160 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 1153 1161 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis 1154 LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use XIOS to read restart1155 1162 ! 1156 1163 LOGICAL :: llok ! true if ok! 1157 LOGICAL :: llxios ! local definition for XIOS read1158 1164 INTEGER :: jl ! loop on number of dimension 1159 1165 INTEGER :: idom ! type of domain … … 1182 1188 REAL(dp) :: gma, gmi 1183 1189 !--------------------------------------------------------------------- 1184 ! 1190 CHARACTER(LEN=lc) :: context 1191 ! 1192 CALL set_xios_context(kiomid, context) 1185 1193 inlev = -1 1186 1194 IF( PRESENT(pv_r3d) ) inlev = SIZE(pv_r3d, 3) 1187 1195 ! 1188 llxios = .FALSE.1189 IF( PRESENT(ldxios) ) llxios = ldxios1190 !1191 1196 idom = kdom 1192 1197 istop = nstop 1193 1198 ! 1194 IF( .NOT.llxios) THEN1199 IF(context == "NONE") THEN 1195 1200 clname = iom_file(kiomid)%name ! esier to read 1196 1201 clinfo = ' iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar) … … 1359 1364 #if defined key_iomput 1360 1365 !would be good to be able to check which context is active and swap only if current is not restart 1361 CALL iom_swap( TRIM(crxios_context) ) 1366 idvar = iom_varid( kiomid, cdvar ) 1367 CALL iom_swap(context) 1368 zsgn = 1._wp 1369 IF( PRESENT(psgn ) ) zsgn = psgn 1370 cl_type = 'T' 1371 IF( PRESENT(cd_type) ) cl_type = cd_type 1372 1362 1373 IF( PRESENT(pv_r3d) ) THEN 1363 1374 IF(lwp) WRITE(numout,*) 'XIOS RST READ (3D): ',TRIM(cdvar) 1364 CALL xios_recv_field( trim(cdvar), pv_r3d) 1365 IF(idom /= jpdom_unknown ) CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing) 1375 CALL xios_recv_field( trim(cdvar), pv_r3d(:, :, :)) 1376 IF(idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN 1377 CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill) 1378 ENDIF 1366 1379 ELSEIF( PRESENT(pv_r2d) ) THEN 1367 1380 IF(lwp) WRITE(numout,*) 'XIOS RST READ (2D): ', TRIM(cdvar) 1368 CALL xios_recv_field( trim(cdvar), pv_r2d) 1369 IF(idom /= jpdom_unknown ) CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing) 1381 CALL xios_recv_field( trim(cdvar), pv_r2d(:, :)) 1382 IF(idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN 1383 CALL lbc_lnk('iom', pv_r2d, cl_type, zsgn, kfillmode = kfill) 1384 ENDIF 1370 1385 ELSEIF( PRESENT(pv_r1d) ) THEN 1371 1386 IF(lwp) WRITE(numout,*) 'XIOS RST READ (1D): ', TRIM(cdvar) 1372 1387 CALL xios_recv_field( trim(cdvar), pv_r1d) 1373 1388 ENDIF 1374 CALL iom_swap( TRIM(cxios_context))1389 CALL iom_swap(cxios_context) 1375 1390 #else 1376 1391 istop = istop + 1 … … 1387 1402 zofs = iom_file(kiomid)%ofs(idvar) ! offset 1388 1403 IF( PRESENT(pv_r1d) ) THEN 1389 IF( zscf /= 1. ) pv_r1d(:) = pv_r1d(:) * zscf1390 IF( zofs /= 0. ) pv_r1d(:) = pv_r1d(:) + zofs1404 IF( zscf /= 1._wp ) pv_r1d(:) = pv_r1d(:) * zscf 1405 IF( zofs /= 0._wp ) pv_r1d(:) = pv_r1d(:) + zofs 1391 1406 ELSEIF( PRESENT(pv_r2d) ) THEN 1392 IF( zscf /= 1. ) pv_r2d(:,:) = pv_r2d(:,:) * zscf1393 IF( zofs /= 0. ) pv_r2d(:,:) = pv_r2d(:,:) + zofs1407 IF( zscf /= 1._wp) pv_r2d(:,:) = pv_r2d(:,:) * zscf 1408 IF( zofs /= 0._wp) pv_r2d(:,:) = pv_r2d(:,:) + zofs 1394 1409 ELSEIF( PRESENT(pv_r3d) ) THEN 1395 IF( zscf /= 1. ) pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf1396 IF( zofs /= 0. ) pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs1410 IF( zscf /= 1._wp) pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf 1411 IF( zofs /= 0._wp) pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs 1397 1412 ENDIF 1398 1413 ! … … 1568 1583 !! INTERFACE iom_rstput 1569 1584 !!---------------------------------------------------------------------- 1570 SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1585 SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1571 1586 INTEGER , INTENT(in) :: kt ! ocean time-step 1572 1587 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1575 1590 REAL(sp) , INTENT(in) :: pvar ! written field 1576 1591 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1577 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1578 LOGICAL :: llx ! local xios write flag 1579 INTEGER :: ivid ! variable id 1580 1581 llx = .FALSE. 1582 IF(PRESENT(ldxios)) llx = ldxios 1592 ! 1593 LOGICAL :: llx ! local xios write flag 1594 INTEGER :: ivid ! variable id 1595 CHARACTER(LEN=lc) :: context 1596 ! 1597 CALL set_xios_context(kiomid, context) 1598 1599 llx = .NOT. (context == "NONE") 1600 1583 1601 IF( llx ) THEN 1584 1602 #ifdef key_iomput 1585 IF( kt == kwrite ) THEN 1586 IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 1587 CALL xios_send_field(trim(cdvar), pvar) 1588 ENDIF 1603 IF( kt == kwrite ) THEN 1604 IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 1605 CALL iom_swap(context) 1606 CALL iom_put(trim(cdvar), pvar) 1607 CALL iom_swap(cxios_context) 1608 ELSE 1609 IF(lwp) write(numout,*) 'RESTART: define (XIOS 0D) ',trim(cdvar) 1610 CALL iom_swap(context) 1611 CALL iom_set_rstw_active( trim(cdvar), rs0 = pvar ) 1612 CALL iom_swap(cxios_context) 1613 ENDIF 1589 1614 #endif 1590 1615 ELSE … … 1598 1623 END SUBROUTINE iom_rp0d_sp 1599 1624 1600 SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1625 SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1601 1626 INTEGER , INTENT(in) :: kt ! ocean time-step 1602 1627 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1605 1630 REAL(dp) , INTENT(in) :: pvar ! written field 1606 1631 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1607 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1608 LOGICAL :: llx ! local xios write flag 1609 INTEGER :: ivid ! variable id 1610 1611 llx = .FALSE. 1612 IF(PRESENT(ldxios)) llx = ldxios 1632 ! 1633 LOGICAL :: llx ! local xios write flag 1634 INTEGER :: ivid ! variable id 1635 CHARACTER(LEN=lc) :: context 1636 ! 1637 CALL set_xios_context(kiomid, context) 1638 1639 llx = .NOT. (context == "NONE") 1640 1613 1641 IF( llx ) THEN 1614 1642 #ifdef key_iomput 1615 IF( kt == kwrite ) THEN 1616 IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 1617 CALL xios_send_field(trim(cdvar), pvar) 1618 ENDIF 1643 IF( kt == kwrite ) THEN 1644 IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 1645 CALL iom_swap(context) 1646 CALL iom_put(trim(cdvar), pvar) 1647 CALL iom_swap(cxios_context) 1648 ELSE 1649 IF(lwp) write(numout,*) 'RESTART: define (XIOS 0D) ',trim(cdvar) 1650 CALL iom_swap(context) 1651 CALL iom_set_rstw_active( trim(cdvar), rd0 = pvar ) 1652 CALL iom_swap(cxios_context) 1653 ENDIF 1619 1654 #endif 1620 1655 ELSE … … 1629 1664 1630 1665 1631 SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1666 SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1632 1667 INTEGER , INTENT(in) :: kt ! ocean time-step 1633 1668 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1636 1671 REAL(sp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1637 1672 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1638 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1639 LOGICAL :: llx ! local xios write flag 1640 INTEGER :: ivid ! variable id 1641 1642 llx = .FALSE. 1643 IF(PRESENT(ldxios)) llx = ldxios 1673 ! 1674 LOGICAL :: llx ! local xios write flag 1675 INTEGER :: ivid ! variable id 1676 CHARACTER(LEN=lc) :: context 1677 ! 1678 CALL set_xios_context(kiomid, context) 1679 1680 llx = .NOT. (context == "NONE") 1681 1644 1682 IF( llx ) THEN 1645 1683 #ifdef key_iomput 1646 IF( kt == kwrite ) THEN 1647 IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 1648 CALL xios_send_field(trim(cdvar), pvar) 1649 ENDIF 1684 IF( kt == kwrite ) THEN 1685 IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 1686 CALL iom_swap(context) 1687 CALL iom_put(trim(cdvar), pvar) 1688 CALL iom_swap(cxios_context) 1689 ELSE 1690 IF(lwp) write(numout,*) 'RESTART: define (XIOS 1D)',trim(cdvar) 1691 CALL iom_swap(context) 1692 CALL iom_set_rstw_active( trim(cdvar), rs1 = pvar ) 1693 CALL iom_swap(cxios_context) 1694 ENDIF 1650 1695 #endif 1651 1696 ELSE … … 1659 1704 END SUBROUTINE iom_rp1d_sp 1660 1705 1661 SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1706 SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1662 1707 INTEGER , INTENT(in) :: kt ! ocean time-step 1663 1708 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1666 1711 REAL(dp) , INTENT(in), DIMENSION( :) :: pvar ! written field 1667 1712 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1668 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1669 LOGICAL :: llx ! local xios write flag 1670 INTEGER :: ivid ! variable id 1671 1672 llx = .FALSE. 1673 IF(PRESENT(ldxios)) llx = ldxios 1713 ! 1714 LOGICAL :: llx ! local xios write flag 1715 INTEGER :: ivid ! variable id 1716 CHARACTER(LEN=lc) :: context 1717 ! 1718 CALL set_xios_context(kiomid, context) 1719 1720 llx = .NOT. (context == "NONE") 1721 1674 1722 IF( llx ) THEN 1675 1723 #ifdef key_iomput 1676 IF( kt == kwrite ) THEN 1677 IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 1678 CALL xios_send_field(trim(cdvar), pvar) 1679 ENDIF 1724 IF( kt == kwrite ) THEN 1725 IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 1726 CALL iom_swap(context) 1727 CALL iom_put(trim(cdvar), pvar) 1728 CALL iom_swap(cxios_context) 1729 ELSE 1730 IF(lwp) write(numout,*) 'RESTART: define (XIOS 1D)',trim(cdvar) 1731 CALL iom_swap(context) 1732 CALL iom_set_rstw_active( trim(cdvar), rd1 = pvar ) 1733 CALL iom_swap(cxios_context) 1734 ENDIF 1680 1735 #endif 1681 1736 ELSE … … 1690 1745 1691 1746 1692 SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1747 SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1693 1748 INTEGER , INTENT(in) :: kt ! ocean time-step 1694 1749 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1697 1752 REAL(sp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1698 1753 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1699 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1700 LOGICAL :: llx 1701 INTEGER :: ivid ! variable id 1702 1703 llx = .FALSE. 1704 IF(PRESENT(ldxios)) llx = ldxios 1754 ! 1755 LOGICAL :: llx 1756 INTEGER :: ivid ! variable id 1757 CHARACTER(LEN=lc) :: context 1758 ! 1759 CALL set_xios_context(kiomid, context) 1760 1761 llx = .NOT. (context == "NONE") 1762 1705 1763 IF( llx ) THEN 1706 1764 #ifdef key_iomput 1707 IF( kt == kwrite ) THEN 1708 IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 1709 CALL xios_send_field(trim(cdvar), pvar) 1710 ENDIF 1765 IF( kt == kwrite ) THEN 1766 IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 1767 CALL iom_swap(context) 1768 CALL iom_put(trim(cdvar), pvar) 1769 CALL iom_swap(cxios_context) 1770 ELSE 1771 IF(lwp) write(numout,*) 'RESTART: define (XIOS 2D)',trim(cdvar) 1772 CALL iom_swap(context) 1773 CALL iom_set_rstw_active( trim(cdvar), rs2 = pvar ) 1774 CALL iom_swap(cxios_context) 1775 ENDIF 1711 1776 #endif 1712 1777 ELSE … … 1720 1785 END SUBROUTINE iom_rp2d_sp 1721 1786 1722 SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1787 SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1723 1788 INTEGER , INTENT(in) :: kt ! ocean time-step 1724 1789 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1727 1792 REAL(dp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field 1728 1793 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1729 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1730 LOGICAL :: llx 1731 INTEGER :: ivid ! variable id 1732 1733 llx = .FALSE. 1734 IF(PRESENT(ldxios)) llx = ldxios 1794 ! 1795 LOGICAL :: llx 1796 INTEGER :: ivid ! variable id 1797 CHARACTER(LEN=lc) :: context 1798 ! 1799 CALL set_xios_context(kiomid, context) 1800 1801 llx = .NOT. (context == "NONE") 1802 1735 1803 IF( llx ) THEN 1736 1804 #ifdef key_iomput 1737 IF( kt == kwrite ) THEN 1738 IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 1739 CALL xios_send_field(trim(cdvar), pvar) 1740 ENDIF 1805 IF( kt == kwrite ) THEN 1806 IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 1807 CALL iom_swap(context) 1808 CALL iom_put(trim(cdvar), pvar) 1809 CALL iom_swap(cxios_context) 1810 ELSE 1811 IF(lwp) write(numout,*) 'RESTART: define (XIOS 2D)',trim(cdvar) 1812 CALL iom_swap(context) 1813 CALL iom_set_rstw_active( trim(cdvar), rd2 = pvar ) 1814 CALL iom_swap(cxios_context) 1815 ENDIF 1741 1816 #endif 1742 1817 ELSE … … 1751 1826 1752 1827 1753 SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1828 SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1754 1829 INTEGER , INTENT(in) :: kt ! ocean time-step 1755 1830 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1758 1833 REAL(sp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1759 1834 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1760 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1761 LOGICAL :: llx ! local xios write flag 1762 INTEGER :: ivid ! variable id 1763 1764 llx = .FALSE. 1765 IF(PRESENT(ldxios)) llx = ldxios 1835 ! 1836 LOGICAL :: llx ! local xios write flag 1837 INTEGER :: ivid ! variable id 1838 CHARACTER(LEN=lc) :: context 1839 ! 1840 CALL set_xios_context(kiomid, context) 1841 1842 llx = .NOT. (context == "NONE") 1843 1766 1844 IF( llx ) THEN 1767 1845 #ifdef key_iomput 1768 IF( kt == kwrite ) THEN 1769 IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 1770 CALL xios_send_field(trim(cdvar), pvar) 1771 ENDIF 1846 IF( kt == kwrite ) THEN 1847 IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 1848 CALL iom_swap(context) 1849 CALL iom_put(trim(cdvar), pvar) 1850 CALL iom_swap(cxios_context) 1851 ELSE 1852 IF(lwp) write(numout,*) 'RESTART: define (XIOS 3D)',trim(cdvar) 1853 CALL iom_swap(context) 1854 CALL iom_set_rstw_active( trim(cdvar), rs3 = pvar ) 1855 CALL iom_swap(cxios_context) 1856 ENDIF 1772 1857 #endif 1773 1858 ELSE … … 1781 1866 END SUBROUTINE iom_rp3d_sp 1782 1867 1783 SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype , ldxios)1868 SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 1784 1869 INTEGER , INTENT(in) :: kt ! ocean time-step 1785 1870 INTEGER , INTENT(in) :: kwrite ! writing time-step … … 1788 1873 REAL(dp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field 1789 1874 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 1790 LOGICAL, OPTIONAL :: ldxios ! xios write flag 1791 LOGICAL :: llx ! local xios write flag 1792 INTEGER :: ivid ! variable id 1793 1794 llx = .FALSE. 1795 IF(PRESENT(ldxios)) llx = ldxios 1875 ! 1876 LOGICAL :: llx ! local xios write flag 1877 INTEGER :: ivid ! variable id 1878 CHARACTER(LEN=lc) :: context 1879 ! 1880 CALL set_xios_context(kiomid, context) 1881 1882 llx = .NOT. (context == "NONE") 1883 1796 1884 IF( llx ) THEN 1797 1885 #ifdef key_iomput 1798 IF( kt == kwrite ) THEN 1799 IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 1800 CALL xios_send_field(trim(cdvar), pvar) 1801 ENDIF 1886 IF( kt == kwrite ) THEN 1887 IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 1888 CALL iom_swap(context) 1889 CALL iom_put(trim(cdvar), pvar) 1890 CALL iom_swap(cxios_context) 1891 ELSE 1892 IF(lwp) write(numout,*) 'RESTART: define (XIOS 3D)',trim(cdvar) 1893 CALL iom_swap(context) 1894 CALL iom_set_rstw_active( trim(cdvar), rd3 = pvar ) 1895 CALL iom_swap(cxios_context) 1896 ENDIF 1802 1897 #endif 1803 1898 ELSE … … 1865 1960 CHARACTER(LEN=*), INTENT(in) :: cdname 1866 1961 REAL(sp) , INTENT(in) :: pfield0d 1867 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson1962 !! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 1868 1963 #if defined key_iomput 1869 1964 !!clem zz(:,:)=pfield0d … … 2145 2240 CALL iom_swap( cdname ) ! swap to cdname context 2146 2241 CALL xios_update_calendar(kt) 2147 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context)) ! return back to nemo context2242 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( cxios_context ) ! return back to nemo context 2148 2243 END SUBROUTINE iom_setkt 2149 2244 … … 2159 2254 CALL iom_swap( cdname ) ! swap to cdname context 2160 2255 CALL xios_context_finalize() ! finalize the context 2161 IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context)) ! return back to nemo context2256 IF( cdname /= cxios_context ) CALL iom_swap( cxios_context ) ! return back to nemo context 2162 2257 ENDIF 2163 2258 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/IOM/iom_def.F90
r13558 r14046 9 9 !!---------------------------------------------------------------------- 10 10 USE par_kind 11 USE netcdf 11 12 12 13 IMPLICIT NONE … … 36 37 INTEGER, PUBLIC :: nxioso = 0 !: type of restart file when writing using XIOS 1 - single, 2 - multiple 37 38 !XIOS read restart 38 LOGICAL, PUBLIC :: lrxios = .FALSE. !: read single file restart using XIOS 39 LOGICAL, PUBLIC :: lrxios = .FALSE. !: read single file restart using XIOS main switch 39 40 LOGICAL, PUBLIC :: lxios_sini = .FALSE. ! is restart in a single file 40 LOGICAL, PUBLIC :: lxios_set = .FALSE. 41 42 41 43 42 44 TYPE, PUBLIC :: file_descriptor … … 59 61 END TYPE file_descriptor 60 62 TYPE(file_descriptor), DIMENSION(jpmax_files), PUBLIC :: iom_file !: array containing the info for all opened files 61 INTEGER, PARAMETER, PUBLIC :: max_rst_fields = 95 !: maximum number of restart variables defined in iom_set_rst_vars62 TYPE, PUBLIC :: RST_FIELD63 CHARACTER(len=30) :: vname = "NO_NAME" ! names of variables in restart file64 CHARACTER(len=30) :: grid = "NO_GRID"65 LOGICAL :: active =.FALSE. ! for restart write only: true - write field, false do not write field66 END TYPE RST_FIELD67 63 !$AGRIF_END_DO_NOT_TREAT 68 !69 TYPE(RST_FIELD), PUBLIC, SAVE :: rst_wfields(max_rst_fields), rst_rfields(max_rst_fields)70 64 ! 71 65 !! * Substitutions -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/IOM/iom_nf90.F90
r13286 r14046 31 31 PUBLIC iom_nf90_open , iom_nf90_close, iom_nf90_varid, iom_nf90_get, iom_nf90_rstput 32 32 PUBLIC iom_nf90_chkatt, iom_nf90_getatt, iom_nf90_putatt 33 PUBLIC iom_nf90_check 33 34 34 35 INTERFACE iom_nf90_get -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/IOM/prtctl.F90
r13286 r14046 8 8 !!---------------------------------------------------------------------- 9 9 USE dom_oce ! ocean space and time domain variables 10 USE domutl, ONLY : is_tile 10 11 USE in_out_manager ! I/O manager 11 12 USE mppini ! distributed memory computing … … 26 27 PUBLIC prt_ctl_init ! called by nemogcm.F90 and prt_ctl_trc_init 27 28 29 !! * Substitutions 30 # include "do_loop_substitute.h90" 28 31 !!---------------------------------------------------------------------- 29 32 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 35 38 SUBROUTINE prt_ctl (tab2d_1, tab3d_1, tab4d_1, tab2d_2, tab3d_2, mask1, mask2, & 36 39 & clinfo, clinfo1, clinfo2, clinfo3, kdim ) 40 !! 41 REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1 42 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_1 43 REAL(wp), DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d_1 44 REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2 45 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_2 46 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1 47 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2 48 CHARACTER(len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array 49 CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo1 50 CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo2 51 CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo3 52 INTEGER , INTENT(in), OPTIONAL :: kdim 53 ! 54 INTEGER :: itab2d_1, itab3d_1, itab4d_1, itab2d_2, itab3d_2 55 !! 56 IF( PRESENT(tab2d_1) ) THEN ; itab2d_1 = is_tile(tab2d_1) ; ELSE ; itab2d_1 = 0 ; ENDIF 57 IF( PRESENT(tab3d_1) ) THEN ; itab3d_1 = is_tile(tab3d_1) ; ELSE ; itab3d_1 = 0 ; ENDIF 58 IF( PRESENT(tab4d_1) ) THEN ; itab4d_1 = is_tile(tab4d_1) ; ELSE ; itab4d_1 = 0 ; ENDIF 59 IF( PRESENT(tab2d_2) ) THEN ; itab2d_2 = is_tile(tab2d_2) ; ELSE ; itab2d_2 = 0 ; ENDIF 60 IF( PRESENT(tab3d_2) ) THEN ; itab3d_2 = is_tile(tab3d_2) ; ELSE ; itab3d_2 = 0 ; ENDIF 61 62 CALL prt_ctl_t (tab2d_1, itab2d_1, tab3d_1, itab3d_1, tab4d_1, itab4d_1, tab2d_2, itab2d_2, tab3d_2, itab3d_2, & 63 & mask1, mask2, clinfo, clinfo1, clinfo2, clinfo3, kdim ) 64 END SUBROUTINE prt_ctl 65 66 67 SUBROUTINE prt_ctl_t (tab2d_1, ktab2d_1, tab3d_1, ktab3d_1, tab4d_1, ktab4d_1, tab2d_2, ktab2d_2, tab3d_2, ktab3d_2, & 68 & mask1, mask2, clinfo, clinfo1, clinfo2, clinfo3, kdim ) 37 69 !!---------------------------------------------------------------------- 38 70 !! *** ROUTINE prt_ctl *** … … 70 102 !! clinfo3 : additional information 71 103 !!---------------------------------------------------------------------- 72 REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1 73 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_1 74 REAL(wp), DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d_1 75 REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2 76 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_2 104 INTEGER , INTENT(in) :: ktab2d_1, ktab3d_1, ktab4d_1, ktab2d_2, ktab3d_2 105 REAL(wp), DIMENSION(A2D_T(ktab2d_1)) , INTENT(in), OPTIONAL :: tab2d_1 106 REAL(wp), DIMENSION(A2D_T(ktab3d_1),:) , INTENT(in), OPTIONAL :: tab3d_1 107 REAL(wp), DIMENSION(A2D_T(ktab4d_1),:,:), INTENT(in), OPTIONAL :: tab4d_1 108 REAL(wp), DIMENSION(A2D_T(ktab2d_2)) , INTENT(in), OPTIONAL :: tab2d_2 109 REAL(wp), DIMENSION(A2D_T(ktab3d_2),:) , INTENT(in), OPTIONAL :: tab3d_2 77 110 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1 78 111 REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2 … … 106 139 107 140 ! define shoter names... 108 iis = nall_ictls(jl)109 iie = nall_ictle(jl)110 jjs = nall_jctls(jl)111 jje = nall_jctle(jl)141 iis = MAX( nall_ictls(jl), ntsi ) 142 iie = MIN( nall_ictle(jl), ntei ) 143 jjs = MAX( nall_jctls(jl), ntsj ) 144 jje = MIN( nall_jctle(jl), ntej ) 112 145 113 146 IF( PRESENT(clinfo) ) THEN ; inum = numprt_top(jl) … … 115 148 ENDIF 116 149 117 DO jn = 1, itra 118 119 IF( PRESENT(clinfo3) ) THEN 120 IF ( clinfo3 == 'tra-ta' ) THEN 121 zvctl1 = t_ctl(jl) 122 ELSEIF( clinfo3 == 'tra' ) THEN 123 zvctl1 = t_ctl(jl) 124 zvctl2 = s_ctl(jl) 125 ELSEIF( clinfo3 == 'dyn' ) THEN 126 zvctl1 = u_ctl(jl) 127 zvctl2 = v_ctl(jl) 150 ! Compute the sum control only where the tile domain and control print area overlap 151 IF( iie >= iis .AND. jje >= jjs ) THEN 152 DO jn = 1, itra 153 154 IF( PRESENT(clinfo3) ) THEN 155 IF ( clinfo3 == 'tra-ta' ) THEN 156 zvctl1 = t_ctl(jl) 157 ELSEIF( clinfo3 == 'tra' ) THEN 158 zvctl1 = t_ctl(jl) 159 zvctl2 = s_ctl(jl) 160 ELSEIF( clinfo3 == 'dyn' ) THEN 161 zvctl1 = u_ctl(jl) 162 zvctl2 = v_ctl(jl) 163 ELSE 164 zvctl1 = tra_ctl(jn,jl) 165 ENDIF 166 ENDIF 167 168 ! 2D arrays 169 IF( PRESENT(tab2d_1) ) THEN 170 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) ) 171 ELSE ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) ) 172 ENDIF 173 ENDIF 174 IF( PRESENT(tab2d_2) ) THEN 175 IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) ) 176 ELSE ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) ) 177 ENDIF 178 ENDIF 179 180 ! 3D arrays 181 IF( PRESENT(tab3d_1) ) THEN 182 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) ) 183 ELSE ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) ) 184 ENDIF 185 ENDIF 186 IF( PRESENT(tab3d_2) ) THEN 187 IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) ) 188 ELSE ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) ) 189 ENDIF 190 ENDIF 191 192 ! 4D arrays 193 IF( PRESENT(tab4d_1) ) THEN 194 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) ) 195 ELSE ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) ) 196 ENDIF 197 ENDIF 198 199 ! Print the result 200 IF( PRESENT(clinfo ) ) cl1 = clinfo(jn) 201 IF( PRESENT(clinfo3) ) THEN 202 ! 203 IF( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN 204 WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1 - zvctl1, cl2, zsum2 - zvctl2 205 ELSE 206 WRITE(inum, "(3x,a,' : ',D23.16 )") cl1, zsum1 - zvctl1 207 ENDIF 208 ! 209 SELECT CASE( clinfo3 ) 210 CASE ( 'tra-ta' ) 211 t_ctl(jl) = zsum1 212 CASE ( 'tra' ) 213 t_ctl(jl) = zsum1 214 s_ctl(jl) = zsum2 215 CASE ( 'dyn' ) 216 u_ctl(jl) = zsum1 217 v_ctl(jl) = zsum2 218 CASE default 219 tra_ctl(jn,jl) = zsum1 220 END SELECT 221 ELSEIF ( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN 222 WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1, cl2, zsum2 128 223 ELSE 129 zvctl1 = tra_ctl(jn,jl) 130 ENDIF 131 ENDIF 132 133 ! 2D arrays 134 IF( PRESENT(tab2d_1) ) THEN 135 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) ) 136 ELSE ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) ) 137 ENDIF 138 ENDIF 139 IF( PRESENT(tab2d_2) ) THEN 140 IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) ) 141 ELSE ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) ) 142 ENDIF 143 ENDIF 144 145 ! 3D arrays 146 IF( PRESENT(tab3d_1) ) THEN 147 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) ) 148 ELSE ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) ) 149 ENDIF 150 ENDIF 151 IF( PRESENT(tab3d_2) ) THEN 152 IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) ) 153 ELSE ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) ) 154 ENDIF 155 ENDIF 156 157 ! 4D arrays 158 IF( PRESENT(tab4d_1) ) THEN 159 IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) ) 160 ELSE ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) ) 161 ENDIF 162 ENDIF 163 164 ! Print the result 165 IF( PRESENT(clinfo ) ) cl1 = clinfo(jn) 166 IF( PRESENT(clinfo3) ) THEN 167 ! 168 IF( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN 169 WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1 - zvctl1, cl2, zsum2 - zvctl2 170 ELSE 171 WRITE(inum, "(3x,a,' : ',D23.16 )") cl1, zsum1 - zvctl1 172 ENDIF 173 ! 174 SELECT CASE( clinfo3 ) 175 CASE ( 'tra-ta' ) 176 t_ctl(jl) = zsum1 177 CASE ( 'tra' ) 178 t_ctl(jl) = zsum1 179 s_ctl(jl) = zsum2 180 CASE ( 'dyn' ) 181 u_ctl(jl) = zsum1 182 v_ctl(jl) = zsum2 183 CASE default 184 tra_ctl(jn,jl) = zsum1 185 END SELECT 186 ELSEIF ( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN 187 WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1, cl2, zsum2 188 ELSE 189 WRITE(inum, "(3x,a,' : ',D23.16 )") cl1, zsum1 190 ENDIF 191 192 END DO 224 WRITE(inum, "(3x,a,' : ',D23.16 )") cl1, zsum1 225 ENDIF 226 227 END DO 228 ENDIF 193 229 END DO 194 230 ! 195 END SUBROUTINE prt_ctl 231 END SUBROUTINE prt_ctl_t 196 232 197 233 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/IOM/restart.F90
r13286 r14046 110 110 ELSE 111 111 #if defined key_iomput 112 cw xios_context = "rstw_"//TRIM(ADJUSTL(clkt))112 cw_ocerst_cxt = "rstw_"//TRIM(ADJUSTL(clkt)) 113 113 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 114 114 clpname = clname … … 116 116 clpname = TRIM(Agrif_CFixed())//"_"//clname 117 117 ENDIF 118 CALL iom_init( cwxios_context, TRIM(clpath)//TRIM(clpname), .false.)119 CALL xios_update_calendar(nitrst)118 numrow = iom_xios_setid(TRIM(clpath)//TRIM(clpname)) 119 CALL iom_init( cw_ocerst_cxt, kdid = numrow, ld_closedef = .false. ) 120 120 CALL iom_swap( cxios_context ) 121 121 #else … … 143 143 INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices 144 144 !!---------------------------------------------------------------------- 145 IF(lwxios) CALL iom_swap( cwxios_context ) 146 CALL iom_rstput( kt, nitrst, numrow, 'rdt' , rn_Dt , ldxios = lwxios) ! dynamics time step 147 CALL iom_delay_rst( 'WRITE', 'OCE', numrow ) ! save only ocean delayed global communication variables 145 CALL iom_rstput( kt, nitrst, numrow, 'rdt' , rn_Dt ) ! dynamics time step 146 IF(.NOT.lwxios) CALL iom_delay_rst( 'WRITE', 'OCE', numrow ) ! save only ocean delayed global communication variables 148 147 149 148 IF ( .NOT. ln_diurnal_only ) THEN 150 CALL iom_rstput( kt, nitrst, numrow, 'ub' , uu(:,:,: ,Kbb) , ldxios = lwxios) ! before fields151 CALL iom_rstput( kt, nitrst, numrow, 'vb' , vv(:,:,: ,Kbb) , ldxios = lwxios)152 CALL iom_rstput( kt, nitrst, numrow, 'tb' , ts(:,:,:,jp_tem,Kbb) , ldxios = lwxios)153 CALL iom_rstput( kt, nitrst, numrow, 'sb' , ts(:,:,:,jp_sal,Kbb) , ldxios = lwxios)154 CALL iom_rstput( kt, nitrst, numrow, 'sshb' , ssh(:,: ,Kbb), ldxios = lwxios)149 CALL iom_rstput( kt, nitrst, numrow, 'ub' , uu(:,:,: ,Kbb) ) ! before fields 150 CALL iom_rstput( kt, nitrst, numrow, 'vb' , vv(:,:,: ,Kbb) ) 151 CALL iom_rstput( kt, nitrst, numrow, 'tb' , ts(:,:,:,jp_tem,Kbb) ) 152 CALL iom_rstput( kt, nitrst, numrow, 'sb' , ts(:,:,:,jp_sal,Kbb) ) 153 CALL iom_rstput( kt, nitrst, numrow, 'sshb' , ssh(:,: ,Kbb)) 155 154 ! 156 CALL iom_rstput( kt, nitrst, numrow, 'un' , uu(:,:,: ,Kmm) , ldxios = lwxios) ! now fields157 CALL iom_rstput( kt, nitrst, numrow, 'vn' , vv(:,:,: ,Kmm) , ldxios = lwxios)158 CALL iom_rstput( kt, nitrst, numrow, 'tn' , ts(:,:,:,jp_tem,Kmm) , ldxios = lwxios)159 CALL iom_rstput( kt, nitrst, numrow, 'sn' , ts(:,:,:,jp_sal,Kmm) , ldxios = lwxios)160 CALL iom_rstput( kt, nitrst, numrow, 'sshn' , ssh(:,: ,Kmm), ldxios = lwxios)161 CALL iom_rstput( kt, nitrst, numrow, 'rhop' , rhop , ldxios = lwxios)155 CALL iom_rstput( kt, nitrst, numrow, 'un' , uu(:,:,: ,Kmm) ) ! now fields 156 CALL iom_rstput( kt, nitrst, numrow, 'vn' , vv(:,:,: ,Kmm) ) 157 CALL iom_rstput( kt, nitrst, numrow, 'tn' , ts(:,:,:,jp_tem,Kmm) ) 158 CALL iom_rstput( kt, nitrst, numrow, 'sn' , ts(:,:,:,jp_sal,Kmm) ) 159 CALL iom_rstput( kt, nitrst, numrow, 'sshn' , ssh(:,: ,Kmm)) 160 CALL iom_rstput( kt, nitrst, numrow, 'rhop' , rhop ) 162 161 ENDIF 163 162 164 IF (ln_diurnal) CALL iom_rstput( kt, nitrst, numrow, 'Dsst', x_dsst, ldxios = lwxios ) 165 IF(lwxios) CALL iom_swap( cxios_context ) 163 IF (ln_diurnal) CALL iom_rstput( kt, nitrst, numrow, 'Dsst', x_dsst ) 166 164 IF( kt == nitrst ) THEN 167 165 IF(.NOT.lwxios) THEN 168 166 CALL iom_close( numrow ) ! close the restart file (only at last time step) 169 167 ELSE 170 CALL iom_context_finalize( cwxios_context ) 168 CALL iom_context_finalize( cw_ocerst_cxt ) 169 iom_file(numrow)%nfid = 0 170 numrow = 0 171 171 ENDIF 172 172 !!gm IF( .NOT. lk_trdmld ) lrst_oce = .FALSE. … … 191 191 !! the file has already been opened 192 192 !!---------------------------------------------------------------------- 193 LOGICAL :: llok 194 CHARACTER(lc) :: clpath ! full path to ocean output restart file 193 LOGICAL :: llok 194 CHARACTER(len=lc) :: clpath ! full path to ocean output restart file 195 CHARACTER(len=lc+2) :: clpname ! file name including agrif prefix 195 196 !!---------------------------------------------------------------------- 196 197 ! … … 209 210 ! can handle checking if variable is in the restart file (there will be no need to open 210 211 ! restart) 211 IF(.NOT.lxios_set) lrxios = lrxios.AND.lxios_sini 212 lrxios = lrxios.AND.lxios_sini 213 212 214 IF( lrxios) THEN 213 crxios_context = 'nemo_rst' 214 IF( .NOT.lxios_set ) THEN 215 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS' 216 CALL iom_init( crxios_context ) 217 lxios_set = .TRUE. 218 ENDIF 219 ENDIF 220 IF( TRIM(Agrif_CFixed()) /= '0' .AND. lrxios) THEN 221 CALL iom_init( crxios_context ) 222 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS for AGRIF' 223 lxios_set = .TRUE. 224 ENDIF 215 cr_ocerst_cxt = 'oce_rst' 216 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS' 217 ! IF( TRIM(Agrif_CFixed()) == '0' ) THEN 218 ! clpname = cn_ocerst_in 219 ! ELSE 220 ! clpname = TRIM(Agrif_CFixed())//"_"//cn_ocerst_in 221 ! ENDIF 222 CALL iom_init( cr_ocerst_cxt, kdid = numror, ld_closedef = .TRUE. ) 223 CALL iom_swap( cxios_context ) 224 ENDIF 225 225 226 ENDIF 226 227 … … 246 247 ! Check dynamics and tracer time-step consistency and force Euler restart if changed 247 248 IF( iom_varid( numror, 'rdt', ldstop = .FALSE. ) > 0 ) THEN 248 CALL iom_get( numror, 'rdt', zrdt , ldxios = lrxios)249 CALL iom_get( numror, 'rdt', zrdt ) 249 250 IF( zrdt /= rn_Dt ) THEN 250 251 IF(lwp) WRITE( numout,*) … … 256 257 ENDIF 257 258 258 CALL iom_delay_rst( 'READ', 'OCE', numror ) ! read only ocean delayed global communication variables259 IF(.NOT.lrxios ) CALL iom_delay_rst( 'READ', 'OCE', numror ) ! read only ocean delayed global communication variables 259 260 260 261 ! Diurnal DSST 261 IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst , ldxios = lrxios)262 IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst ) 262 263 IF ( ln_diurnal_only ) THEN 263 264 IF(lwp) WRITE( numout, * ) & 264 265 & "rst_read:- ln_diurnal_only set, setting rhop=rho0" 265 266 rhop = rho0 266 CALL iom_get( numror, jpdom_auto, 'tn' , w3d , ldxios = lrxios)267 CALL iom_get( numror, jpdom_auto, 'tn' , w3d ) 267 268 ts(:,:,1,jp_tem,Kmm) = w3d(:,:,1) 268 269 RETURN 269 270 ENDIF 270 271 271 272 IF( iom_varid( numror, 'ub', ldstop = .FALSE. ) > 0 ) THEN 272 273 ! before fields 273 CALL iom_get( numror, jpdom_auto, 'ub' , uu(:,:,: ,Kbb), ldxios = lrxios,cd_type = 'U', psgn = -1._wp )274 CALL iom_get( numror, jpdom_auto, 'vb' , vv(:,:,: ,Kbb), ldxios = lrxios,cd_type = 'V', psgn = -1._wp )275 CALL iom_get( numror, jpdom_auto, 'tb' , ts(:,:,:,jp_tem,Kbb) , ldxios = lrxios)276 CALL iom_get( numror, jpdom_auto, 'sb' , ts(:,:,:,jp_sal,Kbb) , ldxios = lrxios)277 CALL iom_get( numror, jpdom_auto, 'sshb' ,ssh(:,: ,Kbb) , ldxios = lrxios)274 CALL iom_get( numror, jpdom_auto, 'ub' , uu(:,:,: ,Kbb), cd_type = 'U', psgn = -1._wp ) 275 CALL iom_get( numror, jpdom_auto, 'vb' , vv(:,:,: ,Kbb), cd_type = 'V', psgn = -1._wp ) 276 CALL iom_get( numror, jpdom_auto, 'tb' , ts(:,:,:,jp_tem,Kbb) ) 277 CALL iom_get( numror, jpdom_auto, 'sb' , ts(:,:,:,jp_sal,Kbb) ) 278 CALL iom_get( numror, jpdom_auto, 'sshb' ,ssh(:,: ,Kbb) ) 278 279 ELSE 279 280 l_1st_euler = .TRUE. ! before field not found, forced euler 1st time-step … … 281 282 ! 282 283 ! now fields 283 CALL iom_get( numror, jpdom_auto, 'un' , uu(:,:,: ,Kmm), ldxios = lrxios,cd_type = 'U', psgn = -1._wp )284 CALL iom_get( numror, jpdom_auto, 'vn' , vv(:,:,: ,Kmm), ldxios = lrxios,cd_type = 'V', psgn = -1._wp )285 CALL iom_get( numror, jpdom_auto, 'tn' , ts(:,:,:,jp_tem,Kmm) , ldxios = lrxios)286 CALL iom_get( numror, jpdom_auto, 'sn' , ts(:,:,:,jp_sal,Kmm) , ldxios = lrxios)287 CALL iom_get( numror, jpdom_auto, 'sshn' ,ssh(:,: ,Kmm) , ldxios = lrxios)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) ) 288 289 IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN 289 CALL iom_get( numror, jpdom_auto, 'rhop' , rhop , ldxios = lrxios) ! now potential density290 CALL iom_get( numror, jpdom_auto, 'rhop' , rhop ) ! now potential density 290 291 ELSE 291 292 CALL eos( ts(:,:,:,:,Kmm), rhd, rhop, gdept(:,:,:,Kmm) ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ISF/isfcav.F90
r13226 r14046 183 183 ! cavity mask 184 184 mskisf_cav(:,:) = (1._wp - tmask(:,:,1)) * ssmask(:,:) 185 ! 186 !================ 187 ! 2: read restart 185 !================ 186 ! 2: activate restart 187 !================ 188 ! 189 !================ 190 ! 3: read restart 188 191 !================ 189 192 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ISF/isfcpl.F90
r13295 r14046 120 120 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 121 121 #endif 122 ! prepare writing restart123 IF( lwxios ) THEN124 CALL iom_set_rstw_var_active('ssmask')125 CALL iom_set_rstw_var_active('tmask')126 CALL iom_set_rstw_var_active('e3t_n')127 CALL iom_set_rstw_var_active('e3u_n')128 CALL iom_set_rstw_var_active('e3v_n')129 END IF130 !131 122 END SUBROUTINE isfcpl_init 132 123 ! … … 153 144 END DO 154 145 ! 155 IF( lwxios ) CALL iom_swap( cwxios_context ) 156 CALL iom_rstput( kt, nitrst, numrow, 'tmask' , tmask , ldxios = lwxios ) 157 CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask, ldxios = lwxios ) 158 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , ze3t , ldxios = lwxios ) 159 CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , ze3u , ldxios = lwxios ) 160 CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , ze3v , ldxios = lwxios ) 161 CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', zgdepw , ldxios = lwxios ) 162 IF( lwxios ) CALL iom_swap( cxios_context ) 146 CALL iom_rstput( kt, nitrst, numrow, 'tmask' , tmask ) 147 CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask ) 148 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n' , ze3t ) 149 CALL iom_rstput( kt, nitrst, numrow, 'e3u_n' , ze3u ) 150 CALL iom_rstput( kt, nitrst, numrow, 'e3v_n' , ze3v ) 151 CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', zgdepw ) 163 152 ! 164 153 END SUBROUTINE isfcpl_rst_write … … 183 172 !!---------------------------------------------------------------------- 184 173 ! 185 CALL iom_get( numror, jpdom_auto, 'ssmask' , zssmask_b , ldxios = lrxios) ! need to extrapolate T/S174 CALL iom_get( numror, jpdom_auto, 'ssmask' , zssmask_b ) ! need to extrapolate T/S 186 175 187 176 ! compute new ssh if we open a full water column … … 264 253 !!---------------------------------------------------------------------- 265 254 ! 266 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b , ldxios = lrxios) ! need to extrapolate T/S267 !CALL iom_get( numror, jpdom_auto, 'wmask' , zwmask_b , ldxios = lrxios) ! need to extrapolate T/S268 !CALL iom_get( numror, jpdom_auto, 'gdepw_n', zdepw_b(:,:,:) , ldxios = lrxios) ! need to interpol vertical profile (vvl)255 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b ) ! need to extrapolate T/S 256 !CALL iom_get( numror, jpdom_auto, 'wmask' , zwmask_b ) ! need to extrapolate T/S 257 !CALL iom_get( numror, jpdom_auto, 'gdepw_n', zdepw_b(:,:,:) ) ! need to interpol vertical profile (vvl) 269 258 ! 270 259 ! … … 410 399 !!---------------------------------------------------------------------- 411 400 ! 412 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b , ldxios = lrxios)413 CALL iom_get( numror, jpdom_auto, 'e3u_n' , ze3u_b , ldxios = lrxios)414 CALL iom_get( numror, jpdom_auto, 'e3v_n' , ze3v_b , ldxios = lrxios)401 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b ) 402 CALL iom_get( numror, jpdom_auto, 'e3u_n' , ze3u_b ) 403 CALL iom_get( numror, jpdom_auto, 'e3v_n' , ze3v_b ) 415 404 ! 416 405 ! 1.0: compute horizontal volume flux divergence difference before-after coupling … … 520 509 521 510 ! get restart variable 522 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b(:,:,:) , ldxios = lrxios) ! need to extrapolate T/S523 CALL iom_get( numror, jpdom_auto, 'e3t_n' , ze3t_b(:,:,:) , ldxios = lrxios)524 CALL iom_get( numror, jpdom_auto, 'tn' , zt_b(:,:,:) , ldxios = lrxios)525 CALL iom_get( numror, jpdom_auto, 'sn' , zs_b(:,:,:) , ldxios = lrxios)511 CALL iom_get( numror, jpdom_auto, 'tmask' , ztmask_b(:,:,:) ) ! need to extrapolate T/S 512 CALL iom_get( numror, jpdom_auto, 'e3t_n' , ze3t_b(:,:,:) ) 513 CALL iom_get( numror, jpdom_auto, 'tn' , zt_b(:,:,:) ) 514 CALL iom_get( numror, jpdom_auto, 'sn' , zs_b(:,:,:) ) 526 515 527 516 ! compute run length -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ISF/isfrst.F90
r13286 r14046 53 53 IF( iom_varid( numror, cfwf_b, ldstop = .FALSE. ) > 0 ) THEN 54 54 IF(lwp) WRITE(numout,*) ' nit000-1 isf tracer content forcing fields read in the restart file' 55 CALL iom_get( numror, jpdom_auto, cfwf_b, pfwf_b(:,:) , ldxios = lrxios) ! before ice shelf melt56 CALL iom_get( numror, jpdom_auto, chc_b , ptsc_b (:,:,jp_tem) , ldxios = lrxios) ! before ice shelf heat flux57 CALL iom_get( numror, jpdom_auto, csc_b , ptsc_b (:,:,jp_sal) , ldxios = lrxios) ! before ice shelf heat flux55 CALL iom_get( numror, jpdom_auto, cfwf_b, pfwf_b(:,:) ) ! before ice shelf melt 56 CALL iom_get( numror, jpdom_auto, chc_b , ptsc_b (:,:,jp_tem) ) ! before ice shelf heat flux 57 CALL iom_get( numror, jpdom_auto, csc_b , ptsc_b (:,:,jp_sal) ) ! before ice shelf heat flux 58 58 ELSE 59 59 pfwf_b(:,:) = pfwf(:,:) … … 61 61 ENDIF 62 62 ! 63 IF( lwxios ) THEN64 CALL iom_set_rstw_var_active(TRIM(chc_b ))65 CALL iom_set_rstw_var_active(TRIM(csc_b ))66 CALL iom_set_rstw_var_active(TRIM(cfwf_b))67 ENDIF68 69 63 END SUBROUTINE isfrst_read 70 64 ! … … 95 89 ! 96 90 ! write restart variable 97 IF( lwxios ) CALL iom_swap( cwxios_context ) 98 CALL iom_rstput( kt, nitrst, numrow, cfwf_b, pfwf(:,:) , ldxios = lwxios ) 99 CALL iom_rstput( kt, nitrst, numrow, chc_b , ptsc(:,:,jp_tem), ldxios = lwxios ) 100 CALL iom_rstput( kt, nitrst, numrow, csc_b , ptsc(:,:,jp_sal), ldxios = lwxios ) 101 IF( lwxios ) CALL iom_swap( cxios_context ) 91 CALL iom_rstput( kt, nitrst, numrow, cfwf_b, pfwf(:,:) ) 92 CALL iom_rstput( kt, nitrst, numrow, chc_b , ptsc(:,:,jp_tem) ) 93 CALL iom_rstput( kt, nitrst, numrow, csc_b , ptsc(:,:,jp_sal) ) 102 94 ! 103 95 END SUBROUTINE isfrst_write -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/LBC/lbc_lnk_multi_generic.h90
r13472 r14046 40 40 & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & 41 41 & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & 42 & , kfillmode, pfillval, lsend, lrecv )42 & , kfillmode, pfillval, lsend, lrecv, ncsten ) 43 43 !!--------------------------------------------------------------------- 44 44 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine … … 55 55 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 56 56 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out 57 LOGICAL , OPTIONAL , INTENT(in ) :: ncsten 57 58 !! 58 59 INTEGER :: kfld ! number of elements that will be attributed … … 84 85 IF( PRESENT(psgn16) ) CALL ROUTINE_LOAD( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 85 86 ! 86 CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv )87 CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 87 88 ! 88 89 END SUBROUTINE ROUTINE_MULTI -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/LBC/lbclnk.F90
r13226 r14046 39 39 MODULE PROCEDURE lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp 40 40 END INTERFACE 41 INTERFACE lbc_lnk_nc_multi 42 MODULE PROCEDURE lbc_lnk_nc_2d_sp, lbc_lnk_nc_3d_sp, lbc_lnk_nc_4d_sp 43 MODULE PROCEDURE lbc_lnk_nc_2d_dp, lbc_lnk_nc_3d_dp, lbc_lnk_nc_4d_dp 44 END INTERFACE 45 INTERFACE lbc_lnk_nc 46 MODULE PROCEDURE mpp_lnk_nc_2d_sp, mpp_lnk_nc_3d_sp, mpp_lnk_nc_4d_sp 47 MODULE PROCEDURE mpp_lnk_nc_2d_dp, mpp_lnk_nc_3d_dp, mpp_lnk_nc_4d_dp 48 END INTERFACE 41 49 ! 42 50 INTERFACE lbc_lnk_icb … … 52 60 END INTERFACE 53 61 54 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 55 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 56 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 62 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 63 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 64 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 65 PUBLIC lbc_lnk_nc ! ocean/ice lateral boundary conditions (MPI3 version) 66 PUBLIC lbc_lnk_nc_multi ! modified ocean/ice lateral boundary conditions (MPI3 version) 57 67 58 68 #if defined key_mpp_mpi … … 250 260 # undef DIM_4d 251 261 262 !!---------------------------------------------------------------------- 263 !! *** load_ptr_(2,3,4)d *** 264 !! 265 !! * Dummy Argument : 266 !! in ==> ptab ! array to be loaded (2D, 3D or 4D) 267 !! cd_nat ! nature of pt2d array grid-points 268 !! psgn ! sign used across the north fold boundary 269 !! inout <=> ptab_ptr ! array of 2D, 3D or 4D pointers 270 !! cdna_ptr ! nature of ptab array grid-points 271 !! psgn_ptr ! sign used across the north fold boundary 272 !! kfld ! number of elements that has been attributed 273 !!---------------------------------------------------------------------- 274 275 !!---------------------------------------------------------------------- 276 !! *** lbc_lnk_nc(2,3,4)d_multi *** 277 !! *** load_ptr_(2,3,4)d *** 278 !! 279 !! * Argument : dummy argument use in lbc_lnk_nc_multi_... routines 280 !! 281 !!---------------------------------------------------------------------- 282 283 !! 284 !! ---- SINGLE PRECISION VERSIONS 285 !! 286 # define SINGLE_PRECISION 287 # define DIM_2d 288 # define ROUTINE_NC_LOAD load_ptr_nc_2d_sp 289 # define ROUTINE_MULTI_NC lbc_lnk_nc_2d_sp 290 # include "lbc_lnk_nc_generic.h90" 291 # undef ROUTINE_MULTI_NC 292 # undef ROUTINE_NC_LOAD 293 # undef DIM_2d 294 295 # define DIM_3d 296 # define ROUTINE_NC_LOAD load_ptr_nc_3d_sp 297 # define ROUTINE_MULTI_NC lbc_lnk_nc_3d_sp 298 # include "lbc_lnk_nc_generic.h90" 299 # undef ROUTINE_MULTI_NC 300 # undef ROUTINE_NC_LOAD 301 # undef DIM_3d 302 303 # define DIM_4d 304 # define ROUTINE_NC_LOAD load_ptr_nc_4d_sp 305 # define ROUTINE_MULTI_NC lbc_lnk_nc_4d_sp 306 # include "lbc_lnk_nc_generic.h90" 307 # undef ROUTINE_MULTI_NC 308 # undef ROUTINE_NC_LOAD 309 # undef DIM_4d 310 # undef SINGLE_PRECISION 311 !! 312 !! ---- DOUBLE PRECISION VERSIONS 313 !! 314 315 # define DIM_2d 316 # define ROUTINE_NC_LOAD load_ptr_nc_2d_dp 317 # define ROUTINE_MULTI_NC lbc_lnk_nc_2d_dp 318 # include "lbc_lnk_nc_generic.h90" 319 # undef ROUTINE_MULTI_NC 320 # undef ROUTINE_NC_LOAD 321 # undef DIM_2d 322 323 # define DIM_3d 324 # define ROUTINE_NC_LOAD load_ptr_nc_3d_dp 325 # define ROUTINE_MULTI_NC lbc_lnk_nc_3d_dp 326 # include "lbc_lnk_nc_generic.h90" 327 # undef ROUTINE_MULTI_NC 328 # undef ROUTINE_NC_LOAD 329 # undef DIM_3d 330 331 # define DIM_4d 332 # define ROUTINE_NC_LOAD load_ptr_nc_4d_dp 333 # define ROUTINE_MULTI_NC lbc_lnk_nc_4d_dp 334 # include "lbc_lnk_nc_generic.h90" 335 # undef ROUTINE_MULTI_NC 336 # undef ROUTINE_NC_LOAD 337 # undef DIM_4d 338 339 !!---------------------------------------------------------------------- 340 !! *** routine mpp_lnk_nc_(2,3,4)d *** 341 !! 342 !! * Argument : dummy argument use in mpp_lnk_... routines 343 !! ptab : array or pointer of arrays on which the boundary condition is applied 344 !! cd_nat : nature of array grid-points 345 !! psgn : sign used across the north fold boundary 346 !! kfld : optional, number of pt3d arrays 347 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 348 !! pfillval : optional, background value (used with jpfillcopy) 349 !!---------------------------------------------------------------------- 350 ! 351 ! !== 2D array and array of 2D pointer ==! 352 ! 353 !! 354 !! ---- SINGLE PRECISION VERSIONS 355 !! 356 # define SINGLE_PRECISION 357 # define DIM_2d 358 # define ROUTINE_NC mpp_lnk_nc_2d_sp 359 # include "mpp_nc_generic.h90" 360 # undef ROUTINE_NC 361 # undef DIM_2d 362 ! 363 ! !== 3D array and array of 3D pointer ==! 364 ! 365 # define DIM_3d 366 # define ROUTINE_NC mpp_lnk_nc_3d_sp 367 # include "mpp_nc_generic.h90" 368 # undef ROUTINE_NC 369 # undef DIM_3d 370 ! 371 ! !== 4D array and array of 4D pointer ==! 372 ! 373 # define DIM_4d 374 # define ROUTINE_NC mpp_lnk_nc_4d_sp 375 # include "mpp_nc_generic.h90" 376 # undef ROUTINE_NC 377 # undef DIM_4d 378 # undef SINGLE_PRECISION 379 380 !! 381 !! ---- DOUBLE PRECISION VERSIONS 382 !! 383 # define DIM_2d 384 # define ROUTINE_NC mpp_lnk_nc_2d_dp 385 # include "mpp_nc_generic.h90" 386 # undef ROUTINE_NC 387 # undef DIM_2d 388 ! 389 ! !== 3D array and array of 3D pointer ==! 390 ! 391 # define DIM_3d 392 # define ROUTINE_NC mpp_lnk_nc_3d_dp 393 # include "mpp_nc_generic.h90" 394 # undef ROUTINE_NC 395 # undef DIM_3d 396 ! 397 ! !== 4D array and array of 4D pointer ==! 398 ! 399 # define DIM_4d 400 # define ROUTINE_NC mpp_lnk_nc_4d_dp 401 # include "mpp_nc_generic.h90" 402 # undef ROUTINE_NC 403 # undef DIM_4d 252 404 253 405 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/LBC/lib_mpp.F90
r13636 r14046 66 66 PUBLIC mppscatter, mppgather 67 67 PUBLIC mpp_ini_znl 68 PUBLIC mpp_ini_nc 68 69 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 69 70 PUBLIC mppsend_sp, mpprecv_sp ! needed by TAM and ICB routines … … 137 138 INTEGER :: ndim_rank_znl ! number of processors on the same zonal average 138 139 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain 140 141 ! variables used for MPI3 neighbourhood collectives 142 INTEGER, PUBLIC :: mpi_nc_com ! MPI3 neighbourhood collectives communicator 143 INTEGER, PUBLIC :: mpi_nc_all_com ! MPI3 neighbourhood collectives communicator (with diagionals) 139 144 140 145 ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) … … 1067 1072 1068 1073 END SUBROUTINE mpp_ini_znl 1074 1075 SUBROUTINE mpp_ini_nc 1076 !!---------------------------------------------------------------------- 1077 !! *** routine mpp_ini_nc *** 1078 !! 1079 !! ** Purpose : Initialize special communicators for MPI3 neighbourhood 1080 !! collectives 1081 !! 1082 !! ** Method : - Create graph communicators starting from the processes 1083 !! distribution along i and j directions 1084 ! 1085 !! ** output 1086 !! mpi_nc_com = MPI3 neighbourhood collectives communicator 1087 !! mpi_nc_all_com = MPI3 neighbourhood collectives communicator 1088 !! (with diagonals) 1089 !! 1090 !!---------------------------------------------------------------------- 1091 INTEGER, DIMENSION(:), ALLOCATABLE :: ineigh, ineighalls, ineighallr 1092 INTEGER :: ideg, idegalls, idegallr, icont, icont1 1093 INTEGER :: ierr 1094 LOGICAL, PARAMETER :: ireord = .FALSE. 1095 1096 #if defined key_mpp_mpi 1097 1098 ideg = 0 1099 idegalls = 0 1100 idegallr = 0 1101 icont = 0 1102 icont1 = 0 1103 1104 IF (nbondi .eq. 1) THEN 1105 ideg = ideg + 1 1106 ELSEIF (nbondi .eq. -1) THEN 1107 ideg = ideg + 1 1108 ELSEIF (nbondi .eq. 0) THEN 1109 ideg = ideg + 2 1110 ENDIF 1111 1112 IF (nbondj .eq. 1) THEN 1113 ideg = ideg + 1 1114 ELSEIF (nbondj .eq. -1) THEN 1115 ideg = ideg + 1 1116 ELSEIF (nbondj .eq. 0) THEN 1117 ideg = ideg + 2 1118 ENDIF 1119 1120 idegalls = ideg 1121 idegallr = ideg 1122 1123 IF (nones .ne. -1) idegalls = idegalls + 1 1124 IF (nonws .ne. -1) idegalls = idegalls + 1 1125 IF (noses .ne. -1) idegalls = idegalls + 1 1126 IF (nosws .ne. -1) idegalls = idegalls + 1 1127 IF (noner .ne. -1) idegallr = idegallr + 1 1128 IF (nonwr .ne. -1) idegallr = idegallr + 1 1129 IF (noser .ne. -1) idegallr = idegallr + 1 1130 IF (noswr .ne. -1) idegallr = idegallr + 1 1131 1132 ALLOCATE(ineigh(ideg)) 1133 ALLOCATE(ineighalls(idegalls)) 1134 ALLOCATE(ineighallr(idegallr)) 1135 1136 IF (nbondi .eq. 1) THEN 1137 icont = icont + 1 1138 ineigh(icont) = nowe 1139 ineighalls(icont) = nowe 1140 ineighallr(icont) = nowe 1141 ELSEIF (nbondi .eq. -1) THEN 1142 icont = icont + 1 1143 ineigh(icont) = noea 1144 ineighalls(icont) = noea 1145 ineighallr(icont) = noea 1146 ELSEIF (nbondi .eq. 0) THEN 1147 icont = icont + 1 1148 ineigh(icont) = nowe 1149 ineighalls(icont) = nowe 1150 ineighallr(icont) = nowe 1151 icont = icont + 1 1152 ineigh(icont) = noea 1153 ineighalls(icont) = noea 1154 ineighallr(icont) = noea 1155 ENDIF 1156 1157 IF (nbondj .eq. 1) THEN 1158 icont = icont + 1 1159 ineigh(icont) = noso 1160 ineighalls(icont) = noso 1161 ineighallr(icont) = noso 1162 ELSEIF (nbondj .eq. -1) THEN 1163 icont = icont + 1 1164 ineigh(icont) = nono 1165 ineighalls(icont) = nono 1166 ineighallr(icont) = nono 1167 ELSEIF (nbondj .eq. 0) THEN 1168 icont = icont + 1 1169 ineigh(icont) = noso 1170 ineighalls(icont) = noso 1171 ineighallr(icont) = noso 1172 icont = icont + 1 1173 ineigh(icont) = nono 1174 ineighalls(icont) = nono 1175 ineighallr(icont) = nono 1176 ENDIF 1177 1178 icont1 = icont 1179 IF (nosws .ne. -1) THEN 1180 icont = icont + 1 1181 ineighalls(icont) = nosws 1182 ENDIF 1183 IF (noses .ne. -1) THEN 1184 icont = icont + 1 1185 ineighalls(icont) = noses 1186 ENDIF 1187 IF (nonws .ne. -1) THEN 1188 icont = icont + 1 1189 ineighalls(icont) = nonws 1190 ENDIF 1191 IF (nones .ne. -1) THEN 1192 icont = icont + 1 1193 ineighalls(icont) = nones 1194 ENDIF 1195 IF (noswr .ne. -1) THEN 1196 icont1 = icont1 + 1 1197 ineighallr(icont1) = noswr 1198 ENDIF 1199 IF (noser .ne. -1) THEN 1200 icont1 = icont1 + 1 1201 ineighallr(icont1) = noser 1202 ENDIF 1203 IF (nonwr .ne. -1) THEN 1204 icont1 = icont1 + 1 1205 ineighallr(icont1) = nonwr 1206 ENDIF 1207 IF (noner .ne. -1) THEN 1208 icont1 = icont1 + 1 1209 ineighallr(icont1) = noner 1210 ENDIF 1211 1212 CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, ideg, ineigh, MPI_UNWEIGHTED, ideg, ineigh, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_com, ierr) 1213 CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, idegallr, ineighallr, MPI_UNWEIGHTED, idegalls, ineighalls, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_all_com, ierr) 1214 1215 DEALLOCATE (ineigh) 1216 DEALLOCATE (ineighalls) 1217 DEALLOCATE (ineighallr) 1218 #endif 1219 END SUBROUTINE mpp_ini_nc 1220 1069 1221 1070 1222 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/LBC/mpp_lnk_generic.h90
r13286 r14046 72 72 73 73 #if defined MULTI 74 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv )74 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 75 75 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 76 76 #else 77 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv )77 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv, ncsten ) 78 78 #endif 79 79 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied … … 84 84 REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 85 85 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 86 LOGICAL, OPTIONAL, INTENT(in ) :: ncsten ! 5-point or 9-point stencil 86 87 ! 87 88 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices … … 100 101 !!---------------------------------------------------------------------- 101 102 ! 103 #if defined key_mpi3 104 # if defined MULTI 105 CALL lbc_lnk_nc ( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 106 # else 107 CALL lbc_lnk_nc_multi(cdname, ptab, cd_nat, psgn, kfillmode=kfillmode, pfillval=pfillval, lsend=lsend, lrecv=lrecv, ncsten=ncsten) 108 # endif 109 #else 110 102 111 ! ----------------------------------------- ! 103 112 ! 0. local variables initialization ! … … 387 396 IF( llrecv_no ) DEALLOCATE( zrcv_no ) 388 397 ! 398 #endif 389 399 END SUBROUTINE ROUTINE_LNK 390 400 #undef PRECISION -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/LBC/mppini.F90
r13490 r14046 542 542 ij = ijn(narea) 543 543 ! 544 ! set default neighbours545 noso = ii_noso(narea)546 nowe = ii_nowe(narea)547 noea = ii_noea(narea)548 nono = ii_nono(narea)549 544 jpi = ijpi(ii,ij) 550 545 !!$ Nis0 = iis0(ii,ij) … … 558 553 njmpp = ijmppt(ii,ij) 559 554 jpk = jpkglo ! third dim 555 556 ! set default neighbours 557 noso = ii_noso(narea) 558 nowe = ii_nowe(narea) 559 noea = ii_noea(narea) 560 nono = ii_nono(narea) 561 562 nones = -1 563 nonws = -1 564 noses = -1 565 nosws = -1 566 567 noner = -1 568 nonwr = -1 569 noser = -1 570 noswr = -1 571 572 IF((nbondi .eq. -1) .or. (nbondi .eq. 0)) THEN ! east neighbour exists 573 IF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 0) THEN 574 nones = ii_nono(noea+1) ! east neighbour has north and south neighbours 575 noses = ii_noso(noea+1) 576 ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. -1) THEN 577 nones = ii_nono(noea+1) ! east neighbour has north neighbour 578 ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 1) THEN 579 noses = ii_noso(noea+1) ! east neighbour has south neighbour 580 END IF 581 END IF 582 IF((nbondi .eq. 1) .or. (nbondi .eq. 0)) THEN ! west neighbour exists 583 IF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 0) THEN 584 nonws = ii_nono(nowe+1) ! west neighbour has north and south neighbours 585 nosws = ii_noso(nowe+1) 586 ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. -1) THEN 587 nonws = ii_nono(nowe+1) ! west neighbour has north neighbour 588 ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 1) THEN 589 nosws = ii_noso(nowe+1) ! west neighbour has north neighbour 590 END IF 591 END IF 592 593 IF((nbondj .eq. -1) .or. (nbondj .eq. 0)) THEN ! north neighbour exists 594 IF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 0) THEN 595 noner = ii_noea(nono+1) ! north neighbour has east and west neighbours 596 nonwr = ii_nowe(nono+1) 597 ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. -1) THEN 598 noner = ii_noea(nono+1) ! north neighbour has east neighbour 599 ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 1) THEN 600 nonwr = ii_nowe(nono+1) ! north neighbour has west neighbour 601 END IF 602 END IF 603 IF((nbondj .eq. 1) .or. (nbondj .eq. 0)) THEN ! south neighbour exists 604 IF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 0) THEN 605 noser = ii_noea(noso+1) ! south neighbour has east and west neighbours 606 noswr = ii_nowe(noso+1) 607 ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. -1) THEN 608 noser = ii_noea(noso+1) ! south neighbour has east neighbour 609 ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 1) THEN 610 noswr = ii_nowe(noso+1) ! south neighbour has west neighbour 611 END IF 612 END IF 613 560 614 ! 561 615 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) … … 648 702 ENDIF 649 703 ENDIF 704 705 ! 706 CALL mpp_ini_nc ! Initialize communicator for neighbourhood collective communications 650 707 ! 651 708 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/LDF/ldfc1d_c2d.F90
r13497 r14046 140 140 END_2D 141 141 CASE( 'TRA' ) ! U- and V-points 142 DO_2D( 1, 1, 1, 1 ) 142 ! NOTE: [tiling-comms-merge] Change needed to preserve results with respect to the trunk 143 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 143 144 pah1(ji,jj,1) = pUfac * MAX( e1u(ji,jj), e2u(ji,jj) )**knn 144 145 pah2(ji,jj,1) = pUfac * MAX( e1v(ji,jj), e2v(ji,jj) )**knn -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/LDF/ldftra.F90
r13558 r14046 427 427 zaht_min = 0.2_wp * aht0 ! minimum value for aht 428 428 zDaht = aht0 - zaht_min 429 DO_2D( 1, 1, 1, 1 ) 429 ! NOTE: [tiling-comms-merge] Change needed to preserve results with respect to the trunk 430 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 430 431 !!gm CAUTION : here we assume lat/lon grid in 20deg N/S band (like all ORCA cfg) 431 432 !! ==>>> The Coriolis value is identical for t- & u_points, and for v- and f-points … … 725 726 !! ** Action : pu, pv increased by the eiv transport 726 727 !!---------------------------------------------------------------------- 727 INTEGER 728 INTEGER 729 INTEGER 730 CHARACTER(len=3) 731 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: pu! in : 3 ocean transport components [m3/s]732 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: pv! out: 3 ocean transport components [m3/s]733 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: pw! increased by the eiv [m3/s]728 INTEGER , INTENT(in ) :: kt ! ocean time-step index 729 INTEGER , INTENT(in ) :: kit000 ! first time step index 730 INTEGER , INTENT(in ) :: Kmm, Krhs ! ocean time level indices 731 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 732 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: pu ! in : 3 ocean transport components [m3/s] 733 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: pv ! out: 3 ocean transport components [m3/s] 734 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: pw ! increased by the eiv [m3/s] 734 735 !! 735 736 INTEGER :: ji, jj, jk ! dummy loop indices 736 737 REAL(wp) :: zuwk, zuwk1, zuwi, zuwi1 ! local scalars 737 738 REAL(wp) :: zvwk, zvwk1, zvwj, zvwj1 ! - - 738 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw 739 !!---------------------------------------------------------------------- 740 ! 741 IF( kt == kit000 ) THEN 742 IF(lwp) WRITE(numout,*) 743 IF(lwp) WRITE(numout,*) 'ldf_eiv_trp : eddy induced advection on ', cdtype,' :' 744 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ add to velocity fields the eiv component' 739 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw 740 !!---------------------------------------------------------------------- 741 ! 742 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 743 IF( kt == kit000 ) THEN 744 IF(lwp) WRITE(numout,*) 745 IF(lwp) WRITE(numout,*) 'ldf_eiv_trp : eddy induced advection on ', cdtype,' :' 746 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ add to velocity fields the eiv component' 747 ENDIF 745 748 ENDIF 746 749 … … 781 784 !! 782 785 !!---------------------------------------------------------------------- 783 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: psi_uw, psi_vw ! streamfunction [m3/s]784 INTEGER 786 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: psi_uw, psi_vw ! streamfunction [m3/s] 787 INTEGER , INTENT(in ) :: Kmm ! ocean time level indices 785 788 ! 786 789 INTEGER :: ji, jj, jk ! dummy loop indices 787 790 REAL(wp) :: zztmp ! local scalar 788 REAL(wp), DIMENSION( jpi,jpj) :: zw2d ! 2D workspace789 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zw3d ! 3D workspace791 REAL(wp), DIMENSION(A2D(nn_hls)) :: zw2d ! 2D workspace 792 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zw3d ! 3D workspace 790 793 !!---------------------------------------------------------------------- 791 794 ! … … 793 796 !!gm to be redesigned.... 794 797 ! !== eiv stream function: output ==! 795 CALL lbc_lnk_multi( 'ldftra', psi_uw, 'U', -1.0_wp , psi_vw, 'V', -1.0_wp )796 !797 798 !!gm CALL iom_put( "psi_eiv_uw", psi_uw ) ! output 798 799 !!gm CALL iom_put( "psi_eiv_vw", psi_vw ) … … 802 803 zw3d(:,:,jpk) = 0._wp ! bottom value always 0 803 804 ! 804 DO jk = 1, jpkm1! e2u e3u u_eiv = -dk[psi_uw]805 zw3d( :,:,jk) = ( psi_uw(:,:,jk+1) - psi_uw(:,:,jk) ) / ( e2u(:,:) * e3u(:,:,jk,Kmm) )806 END DO805 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e2u e3u u_eiv = -dk[psi_uw] 806 zw3d(ji,jj,jk) = ( psi_uw(ji,jj,jk+1) - psi_uw(ji,jj,jk) ) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm) ) 807 END_3D 807 808 CALL iom_put( "uoce_eiv", zw3d ) 808 809 ! 809 DO jk = 1, jpkm1! e1v e3v v_eiv = -dk[psi_vw]810 zw3d( :,:,jk) = ( psi_vw(:,:,jk+1) - psi_vw(:,:,jk) ) / ( e1v(:,:) * e3v(:,:,jk,Kmm) )811 END DO810 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! e1v e3v v_eiv = -dk[psi_vw] 811 zw3d(ji,jj,jk) = ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj,jk) ) / ( e1v(ji,jj) * e3v(ji,jj,jk,Kmm) ) 812 END_3D 812 813 CALL iom_put( "voce_eiv", zw3d ) 813 814 ! … … 816 817 & + psi_uw(ji,jj,jk) - psi_uw(ji-1,jj ,jk) ) / e1e2t(ji,jj) 817 818 END_3D 818 CALL lbc_lnk( 'ldftra', zw3d, 'T', 1.0_wp ) ! lateral boundary condition819 819 CALL iom_put( "woce_eiv", zw3d ) 820 820 ! 821 821 IF( iom_use('weiv_masstr') ) THEN ! vertical mass transport & its square value 822 zw2d(:,:) = rho0 * e1e2t(:,:) 822 DO_2D( 0, 0, 0, 0 ) 823 zw2d(ji,jj) = rho0 * e1e2t(ji,jj) 824 END_2D 823 825 DO jk = 1, jpk 824 826 zw3d(:,:,jk) = zw3d(:,:,jk) * zw2d(:,:) … … 844 846 zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 845 847 END_3D 846 CALL lbc_lnk( 'ldftra', zw2d, 'U', -1.0_wp )847 CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp )848 848 CALL iom_put( "ueiv_heattr" , zztmp * zw2d ) ! heat transport in i-direction 849 849 CALL iom_put( "ueiv_heattr3d", zztmp * zw3d ) ! heat transport in i-direction … … 865 865 zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 866 866 END_3D 867 CALL lbc_lnk( 'ldftra', zw2d, 'V', -1.0_wp ) 868 CALL iom_put( "veiv_heattr", zztmp * zw2d ) ! heat transport in j-direction 869 CALL iom_put( "veiv_heattr", zztmp * zw3d ) ! heat transport in j-direction 867 CALL iom_put( "veiv_heattr" , zztmp * zw2d ) ! heat transport in j-direction 868 CALL iom_put( "veiv_heattr3d", zztmp * zw3d ) ! heat transport in j-direction 870 869 ! 871 870 IF( iom_use( 'sophteiv' ) ) CALL dia_ptr_hst( jp_tem, 'eiv', 0.5 * zw3d ) … … 880 879 zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 881 880 END_3D 882 CALL lbc_lnk( 'ldftra', zw2d, 'U', -1.0_wp )883 CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp )884 881 CALL iom_put( "ueiv_salttr", zztmp * zw2d ) ! salt transport in i-direction 885 882 CALL iom_put( "ueiv_salttr3d", zztmp * zw3d ) ! salt transport in i-direction … … 892 889 zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 893 890 END_3D 894 CALL lbc_lnk( 'ldftra', zw2d, 'V', -1.0_wp ) 895 CALL iom_put( "veiv_salttr", zztmp * zw2d ) ! salt transport in j-direction 896 CALL iom_put( "veiv_salttr", zztmp * zw3d ) ! salt transport in j-direction 891 CALL iom_put( "veiv_salttr" , zztmp * zw2d ) ! salt transport in j-direction 892 CALL iom_put( "veiv_salttr3d", zztmp * zw3d ) ! salt transport in j-direction 897 893 ! 898 894 IF( iom_use( 'sopsteiv' ) ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5 * zw3d ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/cpl_oasis3.F90
r13415 r14046 66 66 INTEGER :: nsnd ! total number of fields sent 67 67 INTEGER :: ncplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data 68 INTEGER, PUBLIC, PARAMETER :: nmaxfld=6 0! Maximum number of coupling fields68 INTEGER, PUBLIC, PARAMETER :: nmaxfld=62 ! Maximum number of coupling fields 69 69 INTEGER, PUBLIC, PARAMETER :: nmaxcat=5 ! Maximum number of coupling fields 70 70 INTEGER, PUBLIC, PARAMETER :: nmaxcpl=5 ! Maximum number of coupling fields -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/sbc_oce.F90
r13472 r14046 12 12 !! 4.0 ! 2016-06 (L. Brodeau) new unified bulk routine (based on AeroBulk) 13 13 !! 4.0 ! 2019-03 (F. Lemarié, G. Samson) add compatibility with ABL mode 14 !! 4.2 ! 2020-12 (G. Madec, E. Clementi) modified wave parameters in namelist 14 15 !!---------------------------------------------------------------------- 15 16 … … 36 37 LOGICAL , PUBLIC :: ln_blk !: bulk formulation 37 38 LOGICAL , PUBLIC :: ln_abl !: Atmospheric boundary layer model 39 LOGICAL , PUBLIC :: ln_wave !: wave in the system (forced or coupled) 38 40 #if defined key_oasis3 39 41 LOGICAL , PUBLIC :: lk_oasis = .TRUE. !: OASIS used … … 56 58 ! !: = 1 global mean of e-p-r set to zero at each nn_fsbc time step 57 59 ! !: = 2 annual global mean of e-p-r set to zero 58 LOGICAL , PUBLIC :: ln_wave !: true if some coupling with wave model59 LOGICAL , PUBLIC :: ln_cdgw !: true if neutral drag coefficient from wave model60 LOGICAL , PUBLIC :: ln_sdw !: true if 3d stokes drift from wave model61 LOGICAL , PUBLIC :: ln_tauwoc !: true if normalized stress from wave is used62 LOGICAL , PUBLIC :: ln_tauw !: true if ocean stress components from wave is used63 LOGICAL , PUBLIC :: ln_stcor !: true if Stokes-Coriolis term is used64 !65 INTEGER , PUBLIC :: nn_sdrift ! type of parameterization to calculate vertical Stokes drift66 !67 60 LOGICAL , PUBLIC :: ln_icebergs !: Icebergs 68 61 ! … … 71 64 ! !!* namsbc_cpl namelist * 72 65 INTEGER , PUBLIC :: nn_cats_cpl !: Number of sea ice categories over which the coupling is carried out 73 66 ! 67 ! !!* namsbc_wave namelist * 68 LOGICAL , PUBLIC :: ln_sdw !: =T 3d stokes drift from wave model 69 LOGICAL , PUBLIC :: ln_stcor !: =T if Stokes-Coriolis and tracer advection terms are used 70 LOGICAL , PUBLIC :: ln_cdgw !: =T neutral drag coefficient from wave model 71 LOGICAL , PUBLIC :: ln_tauoc !: =T if normalized stress from wave is used 72 LOGICAL , PUBLIC :: ln_wave_test !: =T wave test case (constant Stokes drift) 73 LOGICAL , PUBLIC :: ln_charn !: =T Chranock coefficient from wave model 74 LOGICAL , PUBLIC :: ln_taw !: =T wind stress corrected by wave intake 75 LOGICAL , PUBLIC :: ln_phioc !: =T TKE surface BC from wave model 76 LOGICAL , PUBLIC :: ln_bern_srfc !: Bernoulli head, waves' inuced pressure 77 LOGICAL , PUBLIC :: ln_breivikFV_2016 !: Breivik 2016 profile 78 LOGICAL , PUBLIC :: ln_vortex_force !: vortex force activation 79 LOGICAL , PUBLIC :: ln_stshear !: Stoked Drift shear contribution in zdftke 80 ! 74 81 !!---------------------------------------------------------------------- 75 82 !! switch definition (improve readability) … … 81 88 INTEGER , PUBLIC, PARAMETER :: jp_purecpl = 5 !: Pure ocean-atmosphere Coupled formulation 82 89 INTEGER , PUBLIC, PARAMETER :: jp_none = 6 !: for OPA when doing coupling via SAS module 83 84 !!---------------------------------------------------------------------- 85 !! Stokes drift parametrization definition 86 !!---------------------------------------------------------------------- 87 INTEGER , PUBLIC, PARAMETER :: jp_breivik_2014 = 0 !: Breivik 2014: v_z=v_0*[exp(2*k*z)/(1-8*k*z)] 88 INTEGER , PUBLIC, PARAMETER :: jp_li_2017 = 1 !: Li et al 2017: Stokes drift based on Phillips spectrum (Breivik 2016) 89 ! with depth averaged profile 90 INTEGER , PUBLIC, PARAMETER :: jp_peakfr = 2 !: Li et al 2017: using the peak wave number read from wave model instead 91 ! of the inverse depth scale 92 LOGICAL , PUBLIC :: ll_st_bv2014 = .FALSE. ! logical indicator, .true. if Breivik 2014 parameterisation is active. 93 LOGICAL , PUBLIC :: ll_st_li2017 = .FALSE. ! logical indicator, .true. if Li 2017 parameterisation is active. 94 LOGICAL , PUBLIC :: ll_st_bv_li = .FALSE. ! logical indicator, .true. if either Breivik or Li parameterisation is active. 95 LOGICAL , PUBLIC :: ll_st_peakfr = .FALSE. ! logical indicator, .true. if using Li 2017 with peak wave number 96 90 ! 97 91 !!---------------------------------------------------------------------- 98 92 !! component definition -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/sbcapr.F90
r13286 r14046 65 65 CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files 66 66 TYPE(FLD_N) :: sn_apr ! informations about the fields to be read 67 LOGICAL :: lrxios ! read restart using XIOS?68 67 !! 69 68 NAMELIST/namsbc_apr/ cn_dir, sn_apr, ln_ref_apr, rn_pref, ln_apr_obc … … 108 107 CALL ctl_warn( 'sbc_apr: use inverse barometer ssh at open boundary ONLY requires ln_apr_dyn=T' ) 109 108 ! 110 IF( lwxios ) THEN111 CALL iom_set_rstw_var_active('ssh_ibb')112 ENDIF113 109 END SUBROUTINE sbc_apr_init 114 110 … … 154 150 IF( ln_rstart .AND. iom_varid( numror, 'ssh_ibb', ldstop = .FALSE. ) > 0 ) THEN 155 151 IF(lwp) WRITE(numout,*) 'sbc_apr: ssh_ibb read in the restart file' 156 CALL iom_get( numror, jpdom_auto, 'ssh_ibb', ssh_ibb , ldxios = lrxios) ! before inv. barometer ssh152 CALL iom_get( numror, jpdom_auto, 'ssh_ibb', ssh_ibb ) ! before inv. barometer ssh 157 153 ! 158 154 ELSE !* no restart: set from nit000 values … … 167 163 IF(lwp) WRITE(numout,*) 'sbc_apr : ssh_ib written in ocean restart file at it= ', kt,' date= ', ndastp 168 164 IF(lwp) WRITE(numout,*) '~~~~' 169 IF( lwxios ) CALL iom_swap( cwxios_context ) 170 CALL iom_rstput( kt, nitrst, numrow, 'ssh_ibb' , ssh_ib, ldxios = lwxios ) 171 IF( lwxios ) CALL iom_swap( cxios_context ) 165 CALL iom_rstput( kt, nitrst, numrow, 'ssh_ibb' , ssh_ib ) 172 166 ENDIF 173 167 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/sbcblk.F90
r13501 r14046 314 314 ENDIF 315 315 END DO 316 !317 IF( ln_wave ) THEN318 !Activated wave module but neither drag nor stokes drift activated319 IF( .NOT.(ln_cdgw .OR. ln_sdw .OR. ln_tauwoc .OR. ln_stcor ) ) THEN320 CALL ctl_stop( 'STOP', 'Ask for wave coupling but ln_cdgw=F, ln_sdw=F, ln_tauwoc=F, ln_stcor=F' )321 !drag coefficient read from wave model definable only with mfs bulk formulae and core322 ELSEIF(ln_cdgw .AND. .NOT. ln_NCAR ) THEN323 CALL ctl_stop( 'drag coefficient read from wave model definable only with NCAR and CORE bulk formulae')324 ELSEIF(ln_stcor .AND. .NOT. ln_sdw) THEN325 CALL ctl_stop( 'Stokes-Coriolis term calculated only if activated Stokes Drift ln_sdw=T')326 ENDIF327 ELSE328 IF( ln_cdgw .OR. ln_sdw .OR. ln_tauwoc .OR. ln_stcor ) &329 & CALL ctl_stop( 'Not Activated Wave Module (ln_wave=F) but asked coupling ', &330 & 'with drag coefficient (ln_cdgw =T) ' , &331 & 'or Stokes Drift (ln_sdw=T) ' , &332 & 'or ocean stress modification due to waves (ln_tauwoc=T) ', &333 & 'or Stokes-Coriolis term (ln_stcori=T)' )334 ENDIF335 316 ! 336 317 IF( ln_abl ) THEN ! ABL: read 3D fields for wind, temperature, humidity and pressure gradient -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/sbcblk_algo_ecmwf.F90
r13460 r14046 17 17 !!---------------------------------------------------------------------- 18 18 !! History : 4.0 ! 2016-02 (L.Brodeau) Original code 19 !! 4.2 ! 2020-12 (G. Madec, E. Clementi) Charnock coeff from wave model 19 20 !!---------------------------------------------------------------------- 20 21 … … 31 32 USE in_out_manager ! I/O manager 32 33 USE prtctl ! Print control 33 USE sbcwave, ONLY : cdn_wave! wave module34 USE sbcwave, ONLY : charn ! wave module 34 35 #if defined key_si3 || defined key_cice 35 36 USE sbc_ice ! Surface boundary condition: ice fields … … 233 234 u_star = 0.035_wp*U_blk*ztmp1/ztmp0 ! (u* = 0.035*Un10) 234 235 235 z0 = charn0*u_star*u_star/grav + 0.11_wp*znu_a/u_star 236 IF (ln_charn) THEN ! Charnock value if wave coupling 237 z0 = charn*u_star*u_star/grav + 0.11_wp*znu_a/u_star 238 ELSE 239 z0 = charn0*u_star*u_star/grav + 0.11_wp*znu_a/u_star 240 ENDIF 241 236 242 z0 = MIN( MAX(ABS(z0), 1.E-9) , 1._wp ) ! (prevents FPE from stupid values from masked region later on) 237 243 … … 302 308 ztmp2 = u_star*u_star 303 309 ztmp1 = znu_a/u_star 304 z0 = MIN( ABS( alpha_M*ztmp1 + charn0*ztmp2/grav ) , 0.001_wp) 310 IF (ln_charn) THEN ! Charnock value if wave coupling 311 z0 = MIN( ABS( alpha_M*ztmp1 + charn*ztmp2/grav ) , 0.001_wp) 312 ELSE 313 z0 = MIN( ABS( alpha_M*ztmp1 + charn0*ztmp2/grav ) , 0.001_wp) 314 ENDIF 305 315 z0t = MIN( ABS( alpha_H*ztmp1 ) , 0.001_wp) ! eq.3.26, Chap.3, p.34, IFS doc - Cy31r1 306 316 z0q = MIN( ABS( alpha_Q*ztmp1 ) , 0.001_wp) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/sbccpl.F90
r13497 r14046 8 8 !! 3.1 ! 2009_02 (G. Madec, S. Masson, E. Maisonave, A. Caubel) generic coupled interface 9 9 !! 3.4 ! 2011_11 (C. Harris) more flexibility + multi-category fields 10 !! 4.2 ! 2020-12 (G. Madec, E. Clementi) wave coupling updates 10 11 !!---------------------------------------------------------------------- 11 12 … … 106 107 INTEGER, PARAMETER :: jpr_fraqsr = 42 ! fraction of solar net radiation absorbed in the first ocean level 107 108 INTEGER, PARAMETER :: jpr_mslp = 43 ! mean sea level pressure 108 INTEGER, PARAMETER :: jpr_hsig = 44 ! Hsig 109 INTEGER, PARAMETER :: jpr_phioc = 45 ! Wave=>ocean energy flux 110 INTEGER, PARAMETER :: jpr_sdrftx = 46 ! Stokes drift on grid 1 111 INTEGER, PARAMETER :: jpr_sdrfty = 47 ! Stokes drift on grid 2 109 !** surface wave coupling ** 110 INTEGER, PARAMETER :: jpr_hsig = 44 ! Hsig 111 INTEGER, PARAMETER :: jpr_phioc = 45 ! Wave=>ocean energy flux 112 INTEGER, PARAMETER :: jpr_sdrftx = 46 ! Stokes drift on grid 1 113 INTEGER, PARAMETER :: jpr_sdrfty = 47 ! Stokes drift on grid 2 112 114 INTEGER, PARAMETER :: jpr_wper = 48 ! Mean wave period 113 115 INTEGER, PARAMETER :: jpr_wnum = 49 ! Mean wavenumber 114 INTEGER, PARAMETER :: jpr_ tauwoc= 50 ! Stress fraction adsorbed by waves116 INTEGER, PARAMETER :: jpr_wstrf = 50 ! Stress fraction adsorbed by waves 115 117 INTEGER, PARAMETER :: jpr_wdrag = 51 ! Neutral surface drag coefficient 116 INTEGER, PARAMETER :: jpr_isf = 52 117 INTEGER, PARAMETER :: jpr_icb = 53 118 INTEGER, PARAMETER :: jpr_wfreq = 54 ! Wave peak frequency 119 INTEGER, PARAMETER :: jpr_tauwx = 55 ! x component of the ocean stress from waves 120 INTEGER, PARAMETER :: jpr_tauwy = 56 ! y component of the ocean stress from waves 121 INTEGER, PARAMETER :: jpr_ts_ice = 57 ! Sea ice surface temp 122 123 INTEGER, PARAMETER :: jprcv = 57 ! total number of fields received 118 INTEGER, PARAMETER :: jpr_charn = 52 ! Chranock coefficient 119 INTEGER, PARAMETER :: jpr_twox = 53 ! wave to ocean momentum flux 120 INTEGER, PARAMETER :: jpr_twoy = 54 ! wave to ocean momentum flux 121 INTEGER, PARAMETER :: jpr_tawx = 55 ! net wave-supported stress 122 INTEGER, PARAMETER :: jpr_tawy = 56 ! net wave-supported stress 123 INTEGER, PARAMETER :: jpr_bhd = 57 ! Bernoulli head. waves' induced surface pressure 124 INTEGER, PARAMETER :: jpr_tusd = 58 ! zonal stokes transport 125 INTEGER, PARAMETER :: jpr_tvsd = 59 ! meridional stokes tranmport 126 INTEGER, PARAMETER :: jpr_isf = 60 127 INTEGER, PARAMETER :: jpr_icb = 61 128 INTEGER, PARAMETER :: jpr_ts_ice = 62 ! Sea ice surface temp 129 130 INTEGER, PARAMETER :: jprcv = 62 ! total number of fields received 124 131 125 132 INTEGER, PARAMETER :: jps_fice = 1 ! ice fraction sent to the atmosphere … … 184 191 & sn_snd_thick1, sn_snd_cond, sn_snd_mpnd , sn_snd_sstfrz, sn_snd_ttilyr 185 192 ! ! Received from the atmosphere 186 TYPE(FLD_C) :: sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau, sn_rcv_ tauw, sn_rcv_dqnsdt, sn_rcv_qsr, &193 TYPE(FLD_C) :: sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau, sn_rcv_dqnsdt, sn_rcv_qsr, & 187 194 & sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf, sn_rcv_ts_ice 188 195 TYPE(FLD_C) :: sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2, sn_rcv_mslp, sn_rcv_icb, sn_rcv_isf 189 ! Send to waves196 ! ! Send to waves 190 197 TYPE(FLD_C) :: sn_snd_ifrac, sn_snd_crtw, sn_snd_wlev 191 ! Received from waves192 TYPE(FLD_C) :: sn_rcv_hsig, sn_rcv_phioc, sn_rcv_sdrfx, sn_rcv_sdrfy, sn_rcv_wper, sn_rcv_wnum, sn_rcv_tauwoc,&193 sn_rcv_wdrag, sn_rcv_wfreq198 ! ! Received from waves 199 TYPE(FLD_C) :: sn_rcv_hsig, sn_rcv_phioc, sn_rcv_sdrfx, sn_rcv_sdrfy, sn_rcv_wper, sn_rcv_wnum, & 200 & sn_rcv_wstrf, sn_rcv_wdrag, sn_rcv_charn, sn_rcv_taw, sn_rcv_bhd, sn_rcv_tusd, sn_rcv_tvsd 194 201 ! ! Other namelist parameters 195 202 INTEGER :: nn_cplmodel ! Maximum number of models to/from which NEMO is potentialy sending/receiving data … … 274 281 & sn_snd_ifrac , sn_snd_crtw , sn_snd_wlev , sn_rcv_hsig , sn_rcv_phioc , & 275 282 & sn_rcv_w10m , sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr , & 276 & sn_rcv_sdrfx , sn_rcv_sdrfy , sn_rcv_wper , sn_rcv_wnum , sn_rcv_ tauwoc, &277 & sn_rcv_ wdrag , sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal ,&278 & sn_rcv_ iceflx, sn_rcv_co2 , sn_rcv_mslp ,&279 & sn_rcv_ic b , sn_rcv_isf , sn_rcv_wfreq, sn_rcv_tauw , &280 & sn_rcv_ts_ice 283 & sn_rcv_sdrfx , sn_rcv_sdrfy , sn_rcv_wper , sn_rcv_wnum , sn_rcv_wstrf , & 284 & sn_rcv_charn , sn_rcv_taw , sn_rcv_bhd , sn_rcv_tusd , sn_rcv_tvsd, & 285 & sn_rcv_wdrag , sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , & 286 & sn_rcv_iceflx, sn_rcv_co2 , sn_rcv_icb , sn_rcv_isf , sn_rcv_ts_ice 287 281 288 !!--------------------------------------------------------------------- 282 289 ! … … 319 326 WRITE(numout,*)' sea ice heat fluxes = ', TRIM(sn_rcv_iceflx%cldes), ' (', TRIM(sn_rcv_iceflx%clcat), ')' 320 327 WRITE(numout,*)' atm co2 = ', TRIM(sn_rcv_co2%cldes ), ' (', TRIM(sn_rcv_co2%clcat ), ')' 328 WRITE(numout,*)' Sea ice surface skin temperature= ', TRIM(sn_rcv_ts_ice%cldes), ' (', TRIM(sn_rcv_ts_ice%clcat), ')' 329 WRITE(numout,*)' surface waves:' 321 330 WRITE(numout,*)' significant wave heigth = ', TRIM(sn_rcv_hsig%cldes ), ' (', TRIM(sn_rcv_hsig%clcat ), ')' 322 331 WRITE(numout,*)' wave to oce energy flux = ', TRIM(sn_rcv_phioc%cldes ), ' (', TRIM(sn_rcv_phioc%clcat ), ')' … … 325 334 WRITE(numout,*)' Mean wave period = ', TRIM(sn_rcv_wper%cldes ), ' (', TRIM(sn_rcv_wper%clcat ), ')' 326 335 WRITE(numout,*)' Mean wave number = ', TRIM(sn_rcv_wnum%cldes ), ' (', TRIM(sn_rcv_wnum%clcat ), ')' 327 WRITE(numout,*)' Wave peak frequency = ', TRIM(sn_rcv_wfreq%cldes ), ' (', TRIM(sn_rcv_wfreq%clcat ), ')' 328 WRITE(numout,*)' Stress frac adsorbed by waves = ', TRIM(sn_rcv_tauwoc%cldes), ' (', TRIM(sn_rcv_tauwoc%clcat ), ')' 329 WRITE(numout,*)' Stress components by waves = ', TRIM(sn_rcv_tauw%cldes ), ' (', TRIM(sn_rcv_tauw%clcat ), ')' 336 WRITE(numout,*)' Stress frac adsorbed by waves = ', TRIM(sn_rcv_wstrf%cldes ), ' (', TRIM(sn_rcv_wstrf%clcat ), ')' 330 337 WRITE(numout,*)' Neutral surf drag coefficient = ', TRIM(sn_rcv_wdrag%cldes ), ' (', TRIM(sn_rcv_wdrag%clcat ), ')' 331 WRITE(numout,*)' Sea ice surface skin temperature= ', TRIM(sn_rcv_ts_ice%cldes), ' (', TRIM(sn_rcv_ts_ice%clcat), ')'338 WRITE(numout,*)' Charnock coefficient = ', TRIM(sn_rcv_charn%cldes ), ' (', TRIM(sn_rcv_charn%clcat ), ')' 332 339 WRITE(numout,*)' sent fields (multiple ice categories)' 333 340 WRITE(numout,*)' surface temperature = ', TRIM(sn_snd_temp%cldes ), ' (', TRIM(sn_snd_temp%clcat ), ')' … … 351 358 WRITE(numout,*)' - mesh = ', sn_snd_crtw%clvgrd 352 359 ENDIF 353 360 IF( lwp .AND. ln_wave) THEN ! control print 361 WRITE(numout,*)' surface waves:' 362 WRITE(numout,*)' Significant wave heigth = ', TRIM(sn_rcv_hsig%cldes ), ' (', TRIM(sn_rcv_hsig%clcat ), ')' 363 WRITE(numout,*)' Wave to oce energy flux = ', TRIM(sn_rcv_phioc%cldes ), ' (', TRIM(sn_rcv_phioc%clcat ), ')' 364 WRITE(numout,*)' Surface Stokes drift grid u = ', TRIM(sn_rcv_sdrfx%cldes ), ' (', TRIM(sn_rcv_sdrfx%clcat ), ')' 365 WRITE(numout,*)' Surface Stokes drift grid v = ', TRIM(sn_rcv_sdrfy%cldes ), ' (', TRIM(sn_rcv_sdrfy%clcat ), ')' 366 WRITE(numout,*)' Mean wave period = ', TRIM(sn_rcv_wper%cldes ), ' (', TRIM(sn_rcv_wper%clcat ), ')' 367 WRITE(numout,*)' Mean wave number = ', TRIM(sn_rcv_wnum%cldes ), ' (', TRIM(sn_rcv_wnum%clcat ), ')' 368 WRITE(numout,*)' Stress frac adsorbed by waves = ', TRIM(sn_rcv_wstrf%cldes ), ' (', TRIM(sn_rcv_wstrf%clcat ), ')' 369 WRITE(numout,*)' Neutral surf drag coefficient = ', TRIM(sn_rcv_wdrag%cldes ), ' (', TRIM(sn_rcv_wdrag%clcat ), ')' 370 WRITE(numout,*)' Charnock coefficient = ', TRIM(sn_rcv_charn%cldes ), ' (', TRIM(sn_rcv_charn%clcat ), ')' 371 WRITE(numout,*)' Transport associated to Stokes drift grid u = ', TRIM(sn_rcv_tusd%cldes ), ' (', TRIM(sn_rcv_tusd%clcat ), ')' 372 WRITE(numout,*)' Transport associated to Stokes drift grid v = ', TRIM(sn_rcv_tvsd%cldes ), ' (', TRIM(sn_rcv_tvsd%clcat ), ')' 373 WRITE(numout,*)' Bernouilli pressure head = ', TRIM(sn_rcv_bhd%cldes ), ' (', TRIM(sn_rcv_bhd%clcat ), ')' 374 WRITE(numout,*)'Wave to ocean momentum flux and Net wave-supported stress = ', TRIM(sn_rcv_taw%cldes ), ' (', TRIM(sn_rcv_taw%clcat ), ')' 375 WRITE(numout,*)' Surface current to waves = ', TRIM(sn_snd_crtw%cldes ), ' (', TRIM(sn_snd_crtw%clcat ), ')' 376 WRITE(numout,*)' - referential = ', sn_snd_crtw%clvref 377 WRITE(numout,*)' - orientation = ', sn_snd_crtw%clvor 378 WRITE(numout,*)' - mesh = ', sn_snd_crtw%clvgrd 379 ENDIF 354 380 ! ! allocate sbccpl arrays 355 381 IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' ) … … 629 655 cpl_wper = .TRUE. 630 656 ENDIF 631 srcv(jpr_wfreq)%clname = 'O_WFreq' ! wave peak frequency632 IF( TRIM(sn_rcv_wfreq%cldes ) == 'coupled' ) THEN633 srcv(jpr_wfreq)%laction = .TRUE.634 cpl_wfreq = .TRUE.635 ENDIF636 657 srcv(jpr_wnum)%clname = 'O_WNum' ! mean wave number 637 658 IF( TRIM(sn_rcv_wnum%cldes ) == 'coupled' ) THEN … … 639 660 cpl_wnum = .TRUE. 640 661 ENDIF 641 srcv(jpr_tauwoc)%clname = 'O_TauOce' ! stress fraction adsorbed by the wave 642 IF( TRIM(sn_rcv_tauwoc%cldes ) == 'coupled' ) THEN 643 srcv(jpr_tauwoc)%laction = .TRUE. 644 cpl_tauwoc = .TRUE. 645 ENDIF 646 srcv(jpr_tauwx)%clname = 'O_Tauwx' ! ocean stress from wave in the x direction 647 srcv(jpr_tauwy)%clname = 'O_Tauwy' ! ocean stress from wave in the y direction 648 IF( TRIM(sn_rcv_tauw%cldes ) == 'coupled' ) THEN 649 srcv(jpr_tauwx)%laction = .TRUE. 650 srcv(jpr_tauwy)%laction = .TRUE. 651 cpl_tauw = .TRUE. 662 srcv(jpr_wstrf)%clname = 'O_WStrf' ! stress fraction adsorbed by the wave 663 IF( TRIM(sn_rcv_wstrf%cldes ) == 'coupled' ) THEN 664 srcv(jpr_wstrf)%laction = .TRUE. 665 cpl_wstrf = .TRUE. 652 666 ENDIF 653 667 srcv(jpr_wdrag)%clname = 'O_WDrag' ! neutral surface drag coefficient … … 656 670 cpl_wdrag = .TRUE. 657 671 ENDIF 658 IF( srcv(jpr_tauwoc)%laction .AND. srcv(jpr_tauwx)%laction .AND. srcv(jpr_tauwy)%laction ) & 659 CALL ctl_stop( 'More than one method for modifying the ocean stress has been selected ', & 660 '(sn_rcv_tauwoc=coupled and sn_rcv_tauw=coupled)' ) 672 srcv(jpr_charn)%clname = 'O_Charn' ! Chranock coefficient 673 IF( TRIM(sn_rcv_charn%cldes ) == 'coupled' ) THEN 674 srcv(jpr_charn)%laction = .TRUE. 675 cpl_charn = .TRUE. 676 ENDIF 677 srcv(jpr_bhd)%clname = 'O_Bhd' ! Bernoulli head. waves' induced surface pressure 678 IF( TRIM(sn_rcv_bhd%cldes ) == 'coupled' ) THEN 679 srcv(jpr_bhd)%laction = .TRUE. 680 cpl_bhd = .TRUE. 681 ENDIF 682 srcv(jpr_tusd)%clname = 'O_Tusd' ! zonal stokes transport 683 IF( TRIM(sn_rcv_tusd%cldes ) == 'coupled' ) THEN 684 srcv(jpr_tusd)%laction = .TRUE. 685 cpl_tusd = .TRUE. 686 ENDIF 687 srcv(jpr_tvsd)%clname = 'O_Tvsd' ! meridional stokes tranmport 688 IF( TRIM(sn_rcv_tvsd%cldes ) == 'coupled' ) THEN 689 srcv(jpr_tvsd)%laction = .TRUE. 690 cpl_tvsd = .TRUE. 691 ENDIF 692 693 srcv(jpr_twox)%clname = 'O_Twox' ! wave to ocean momentum flux in the u direction 694 srcv(jpr_twoy)%clname = 'O_Twoy' ! wave to ocean momentum flux in the v direction 695 srcv(jpr_tawx)%clname = 'O_Tawx' ! Net wave-supported stress in the u direction 696 srcv(jpr_tawy)%clname = 'O_Tawy' ! Net wave-supported stress in the v direction 697 IF( TRIM(sn_rcv_taw%cldes ) == 'coupled' ) THEN 698 srcv(jpr_twox)%laction = .TRUE. 699 srcv(jpr_twoy)%laction = .TRUE. 700 srcv(jpr_tawx)%laction = .TRUE. 701 srcv(jpr_tawy)%laction = .TRUE. 702 cpl_taw = .TRUE. 703 ENDIF 661 704 ! 662 705 ! ! ------------------------------- ! … … 1058 1101 ! initialisation of the coupler ! 1059 1102 ! ================================ ! 1060 1061 1103 CALL cpl_define(jprcv, jpsnd, nn_cplmodel) 1062 1104 … … 1071 1113 ENDIF 1072 1114 xcplmask(:,:,0) = 1. - SUM( xcplmask(:,:,1:nn_cplmodel), dim = 3 ) 1115 ! 1073 1116 ! 1074 1117 END SUBROUTINE sbc_cpl_init … … 1146 1189 IF( ncpl_qsr_freq /= 0) ncpl_qsr_freq = 86400 / ncpl_qsr_freq ! used by top 1147 1190 1191 IF ( ln_wave .AND. nn_components == 0 ) THEN 1192 ncpl_qsr_freq = 1; 1193 WRITE(numout,*) 'ncpl_qsr_freq is set to 1 when coupling NEMO with wave (without SAS) ' 1194 ENDIF 1148 1195 ENDIF 1149 1196 ! … … 1320 1367 IF( srcv(jpr_hsig)%laction ) hsw(:,:) = frcv(jpr_hsig)%z3(:,:,1) 1321 1368 ! 1322 ! ! ========================= !1323 ! ! Wave peak frequency !1324 ! ! ========================= !1325 IF( srcv(jpr_wfreq)%laction ) wfreq(:,:) = frcv(jpr_wfreq)%z3(:,:,1)1326 !1327 1369 ! ! ========================= ! 1328 1370 ! ! Vertical mixing Qiao ! … … 1331 1373 1332 1374 ! Calculate the 3D Stokes drift both in coupled and not fully uncoupled mode 1333 IF( srcv(jpr_sdrftx)%laction .OR. srcv(jpr_sdrfty)%laction .OR. srcv(jpr_wper)%laction&1334 .OR. srcv(jpr_hsig)%laction .OR. srcv(jpr_wfreq)%laction)THEN1375 IF( srcv(jpr_sdrftx)%laction .OR. srcv(jpr_sdrfty)%laction .OR. & 1376 srcv(jpr_wper)%laction .OR. srcv(jpr_hsig)%laction ) THEN 1335 1377 CALL sbc_stokes( Kmm ) 1336 1378 ENDIF … … 1339 1381 ! ! Stress adsorbed by waves ! 1340 1382 ! ! ========================= ! 1341 IF( srcv(jpr_tauwoc)%laction .AND. ln_tauwoc ) tauoc_wave(:,:) = frcv(jpr_tauwoc)%z3(:,:,1) 1342 1343 ! ! ========================= ! 1344 ! ! Stress component by waves ! 1345 ! ! ========================= ! 1346 IF( srcv(jpr_tauwx)%laction .AND. srcv(jpr_tauwy)%laction .AND. ln_tauw ) THEN 1347 tauw_x(:,:) = frcv(jpr_tauwx)%z3(:,:,1) 1348 tauw_y(:,:) = frcv(jpr_tauwy)%z3(:,:,1) 1349 ENDIF 1350 1383 IF( srcv(jpr_wstrf)%laction .AND. ln_tauoc ) tauoc_wave(:,:) = frcv(jpr_wstrf)%z3(:,:,1) 1384 ! 1351 1385 ! ! ========================= ! 1352 1386 ! ! Wave drag coefficient ! 1353 1387 ! ! ========================= ! 1354 1388 IF( srcv(jpr_wdrag)%laction .AND. ln_cdgw ) cdn_wave(:,:) = frcv(jpr_wdrag)%z3(:,:,1) 1355 1389 ! 1390 ! ! ========================= ! 1391 ! ! Chranock coefficient ! 1392 ! ! ========================= ! 1393 IF( srcv(jpr_charn)%laction .AND. ln_charn ) charn(:,:) = frcv(jpr_charn)%z3(:,:,1) 1394 ! 1395 ! ! ========================= ! 1396 ! ! net wave-supported stress ! 1397 ! ! ========================= ! 1398 IF( srcv(jpr_tawx)%laction .AND. ln_taw ) tawx(:,:) = frcv(jpr_tawx)%z3(:,:,1) 1399 IF( srcv(jpr_tawy)%laction .AND. ln_taw ) tawy(:,:) = frcv(jpr_tawy)%z3(:,:,1) 1400 ! 1401 ! ! ========================= ! 1402 ! !wave to ocean momentum flux! 1403 ! ! ========================= ! 1404 IF( srcv(jpr_twox)%laction .AND. ln_taw ) twox(:,:) = frcv(jpr_twox)%z3(:,:,1) 1405 IF( srcv(jpr_twoy)%laction .AND. ln_taw ) twoy(:,:) = frcv(jpr_twoy)%z3(:,:,1) 1406 ! 1407 ! ! ========================= ! 1408 ! ! wave TKE flux at sfc ! 1409 ! ! ========================= ! 1410 IF( srcv(jpr_phioc)%laction .AND. ln_phioc ) phioc(:,:) = frcv(jpr_phioc)%z3(:,:,1) 1411 ! 1412 ! ! ========================= ! 1413 ! ! Bernoulli head ! 1414 ! ! ========================= ! 1415 IF( srcv(jpr_bhd)%laction .AND. ln_bern_srfc ) bhd_wave(:,:) = frcv(jpr_bhd)%z3(:,:,1) 1416 ! 1417 ! ! ========================= ! 1418 ! ! Stokes transport u dir ! 1419 ! ! ========================= ! 1420 IF( srcv(jpr_tusd)%laction .AND. ln_breivikFV_2016 ) tusd(:,:) = frcv(jpr_tusd)%z3(:,:,1) 1421 ! 1422 ! ! ========================= ! 1423 ! ! Stokes transport v dir ! 1424 ! ! ========================= ! 1425 IF( srcv(jpr_tvsd)%laction .AND. ln_breivikFV_2016 ) tvsd(:,:) = frcv(jpr_tvsd)%z3(:,:,1) 1426 ! 1356 1427 ! Fields received by SAS when OASIS coupling 1357 1428 ! (arrays no more filled at sbcssm stage) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/sbcflx.F90
r13497 r14046 127 127 128 128 IF( ln_dm2dc ) THEN ! modify now Qsr to include the diurnal cycle 129 qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask( ji,jj,1)129 qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1) 130 130 ELSE 131 131 DO_2D( 0, 0, 0, 0 ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/sbcmod.F90
r13722 r14046 16 16 !! 4.0 ! 2016-06 (L. Brodeau) new general bulk formulation 17 17 !! 4.0 ! 2019-03 (F. Lemarié & G. Samson) add ABL compatibility (ln_abl=TRUE) 18 !! 4.2 ! 2020-12 (G. Madec, E. Clementi) modified wave forcing and coupling 18 19 !!---------------------------------------------------------------------- 19 20 … … 54 55 USE usrdef_sbc ! user defined: surface boundary condition 55 56 USE closea ! closed sea 57 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 56 58 ! 57 59 USE prtctl ! Print control (prt_ctl routine) … … 70 72 71 73 INTEGER :: nsbc ! type of surface boundary condition (deduced from namsbc informations) 72 74 !! * Substitutions 75 # include "do_loop_substitute.h90" 73 76 !!---------------------------------------------------------------------- 74 77 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 99 102 & nn_ice , ln_ice_embd, & 100 103 & ln_traqsr, ln_dm2dc , & 101 & ln_rnf , nn_fwb , ln_ssr , ln_apr_dyn, & 102 & ln_wave , ln_cdgw , ln_sdw , ln_tauwoc , ln_stcor , & 103 & ln_tauw , nn_lsm, nn_sdrift 104 & ln_rnf , nn_fwb , ln_ssr , ln_apr_dyn, & 105 & ln_wave , nn_lsm 104 106 !!---------------------------------------------------------------------- 105 107 ! … … 133 135 WRITE(numout,*) ' bulk formulation ln_blk = ', ln_blk 134 136 WRITE(numout,*) ' ABL formulation ln_abl = ', ln_abl 137 WRITE(numout,*) ' Surface wave (forced or coupled) ln_wave = ', ln_wave 135 138 WRITE(numout,*) ' Type of coupling (Ocean/Ice/Atmosphere) : ' 136 139 WRITE(numout,*) ' ocean-atmosphere coupled formulation ln_cpl = ', ln_cpl … … 150 153 WRITE(numout,*) ' runoff / runoff mouths ln_rnf = ', ln_rnf 151 154 WRITE(numout,*) ' nb of iterations if land-sea-mask applied nn_lsm = ', nn_lsm 152 WRITE(numout,*) ' surface wave ln_wave = ', ln_wave 153 WRITE(numout,*) ' Stokes drift corr. to vert. velocity ln_sdw = ', ln_sdw 154 WRITE(numout,*) ' vertical parametrization nn_sdrift = ', nn_sdrift 155 WRITE(numout,*) ' wave modified ocean stress ln_tauwoc = ', ln_tauwoc 156 WRITE(numout,*) ' wave modified ocean stress component ln_tauw = ', ln_tauw 157 WRITE(numout,*) ' Stokes coriolis term ln_stcor = ', ln_stcor 158 WRITE(numout,*) ' neutral drag coefficient (CORE,NCAR) ln_cdgw = ', ln_cdgw 159 ENDIF 160 ! 161 IF( .NOT.ln_wave ) THEN 162 ln_sdw = .false. ; ln_cdgw = .false. ; ln_tauwoc = .false. ; ln_tauw = .false. ; ln_stcor = .false. 163 ENDIF 164 IF( ln_sdw ) THEN 165 IF( .NOT.(nn_sdrift==jp_breivik_2014 .OR. nn_sdrift==jp_li_2017 .OR. nn_sdrift==jp_peakfr) ) & 166 CALL ctl_stop( 'The chosen nn_sdrift for Stokes drift vertical velocity must be 0, 1, or 2' ) 167 ENDIF 168 ll_st_bv2014 = ( nn_sdrift==jp_breivik_2014 ) 169 ll_st_li2017 = ( nn_sdrift==jp_li_2017 ) 170 ll_st_bv_li = ( ll_st_bv2014 .OR. ll_st_li2017 ) 171 ll_st_peakfr = ( nn_sdrift==jp_peakfr ) 172 IF( ln_tauwoc .AND. ln_tauw ) & 173 CALL ctl_stop( 'More than one method for modifying the ocean stress has been selected ', & 174 '(ln_tauwoc=.true. and ln_tauw=.true.)' ) 175 IF( ln_tauwoc ) & 176 CALL ctl_warn( 'You are subtracting the wave stress to the ocean (ln_tauwoc=.true.)' ) 177 IF( ln_tauw ) & 178 CALL ctl_warn( 'The wave modified ocean stress components are used (ln_tauw=.true.) ', & 179 'This will override any other specification of the ocean stress' ) 155 ENDIF 180 156 ! 181 157 IF( .NOT.ln_usr ) THEN ! the model calendar needs some specificities (except in user defined case) … … 357 333 IF( nn_ice == 3 ) CALL cice_sbc_init( nsbc, Kbb, Kmm ) ! CICE initialization 358 334 ! 359 IF( ln_wave ) CALL sbc_wave_init ! surface wave initialisation 360 ! 361 IF( lwxios ) THEN 362 CALL iom_set_rstw_var_active('utau_b') 363 CALL iom_set_rstw_var_active('vtau_b') 364 CALL iom_set_rstw_var_active('qns_b') 365 ! The 3D heat content due to qsr forcing is treated in traqsr 366 ! CALL iom_set_rstw_var_active('qsr_b') 367 CALL iom_set_rstw_var_active('emp_b') 368 CALL iom_set_rstw_var_active('sfx_b') 369 ENDIF 370 335 IF( ln_wave ) THEN 336 CALL sbc_wave_init ! surface wave initialisation 337 ELSE 338 IF(lwp) WRITE(numout,*) 339 IF(lwp) WRITE(numout,*) ' No surface waves : all wave related logical set to false' 340 ln_sdw = .false. 341 ln_stcor = .false. 342 ln_cdgw = .false. 343 ln_tauoc = .false. 344 ln_wave_test = .false. 345 ln_charn = .false. 346 ln_taw = .false. 347 ln_phioc = .false. 348 ln_bern_srfc = .false. 349 ln_breivikFV_2016 = .false. 350 ln_vortex_force = .false. 351 ln_stshear = .false. 352 ENDIF 353 ! 371 354 END SUBROUTINE sbc_init 372 355 … … 390 373 INTEGER, INTENT(in) :: kt ! ocean time step 391 374 INTEGER, INTENT(in) :: Kbb, Kmm ! ocean time level indices 375 INTEGER :: jj, ji ! dummy loop argument 392 376 ! 393 377 LOGICAL :: ll_sas, ll_opa ! local logical … … 422 406 ! 423 407 IF( .NOT.ll_sas ) CALL sbc_ssm ( kt, Kbb, Kmm ) ! mean ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m) 424 IF( ln_wave ) CALL sbc_wave( kt, Kmm ) ! surface waves425 426 408 ! 427 409 ! !== sbc formulation ==! 428 410 ! 411 ! 429 412 SELECT CASE( nsbc ) ! Compute ocean surface boundary condition 430 413 ! ! (i.e. utau,vtau, qns, qsr, emp, sfx) … … 433 416 CASE( jp_blk ) 434 417 IF( ll_sas ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! OPA-SAS coupling: SAS receiving fields from OPA 418 !!!!!!!!!!! ATTENTION:ln_wave is not only used for oasis coupling !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 419 IF( ln_wave ) THEN 420 IF ( lk_oasis ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! OPA-wave coupling 421 CALL sbc_wave ( kt, Kmm ) 422 ENDIF 435 423 CALL sbc_blk ( kt ) ! bulk formulation for the ocean 436 424 ! … … 446 434 IF( ln_mixcpl ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm ) ! forced-coupled mixed formulation after forcing 447 435 ! 448 IF ( ln_wave .AND. (ln_tauwoc .OR. ln_tauw) ) CALL sbc_wstress( ) ! Wind stress provided by waves 436 IF( ln_wave .AND. ln_tauoc ) THEN ! Wave stress reduction 437 DO_2D( 0, 0, 0, 0) 438 utau(ji,jj) = utau(ji,jj) * ( tauoc_wave(ji,jj) + tauoc_wave(ji-1,jj) ) * 0.5_wp 439 vtau(ji,jj) = vtau(ji,jj) * ( tauoc_wave(ji,jj) + tauoc_wave(ji,jj-1) ) * 0.5_wp 440 END_2D 441 ! 442 CALL lbc_lnk( 'sbcwave', utau, 'U', -1. ) 443 CALL lbc_lnk( 'sbcwave', vtau, 'V', -1. ) 444 ! 445 taum(:,:) = taum(:,:)*tauoc_wave(:,:) 446 ! 447 IF( kt == nit000 ) CALL ctl_warn( 'sbc: You are subtracting the wave stress to the ocean.', & 448 & 'If not requested select ln_tauoc=.false.' ) 449 ! 450 ELSEIF( ln_wave .AND. ln_taw ) THEN ! Wave stress reduction 451 utau(:,:) = utau(:,:) - tawx(:,:) + twox(:,:) 452 vtau(:,:) = vtau(:,:) - tawy(:,:) + twoy(:,:) 453 CALL lbc_lnk( 'sbcwave', utau, 'U', -1. ) 454 CALL lbc_lnk( 'sbcwave', vtau, 'V', -1. ) 455 ! 456 DO_2D( 0, 0, 0, 0) 457 taum(ji,jj) = sqrt((.5*(utau(ji-1,jj)+utau(ji,jj)))**2 + (.5*(vtau(ji,jj-1)+vtau(ji,jj)))**2) 458 END_2D 459 ! 460 IF( kt == nit000 ) CALL ctl_warn( 'sbc: You are subtracting the wave stress to the ocean.', & 461 & 'If not requested select ln_taw=.false.' ) 462 ! 463 ENDIF 464 CALL lbc_lnk( 'sbcmod', taum(:,:), 'T', 1. ) 449 465 ! 450 466 ! !== Misc. Options ==! … … 510 526 & iom_varid( numror, 'utau_b', ldstop = .FALSE. ) > 0 ) THEN 511 527 IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields red in the restart file' 512 CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b , ldxios = lrxios, cd_type = 'U', psgn = -1._wp) ! before i-stress (U-point)513 CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b , ldxios = lrxios, cd_type = 'V', psgn = -1._wp) ! before j-stress (V-point)514 CALL iom_get( numror, jpdom_auto, 'qns_b', qns_b , ldxios = lrxios) ! before non solar heat flux (T-point)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) 515 531 ! The 3D heat content due to qsr forcing is treated in traqsr 516 ! CALL iom_get( numror, jpdom_auto, 'qsr_b' , qsr_b , ldxios = lrxios) ! before solar heat flux (T-point)517 CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b , ldxios = lrxios) ! before freshwater flux (T-point)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) 518 534 ! To ensure restart capability with 3.3x/3.4 restart files !! to be removed in v3.6 519 535 IF( iom_varid( numror, 'sfx_b', ldstop = .FALSE. ) > 0 ) THEN 520 CALL iom_get( numror, jpdom_auto, 'sfx_b', sfx_b , ldxios = lrxios) ! before salt flux (T-point)536 CALL iom_get( numror, jpdom_auto, 'sfx_b', sfx_b ) ! before salt flux (T-point) 521 537 ELSE 522 538 sfx_b (:,:) = sfx(:,:) … … 538 554 & 'at it= ', kt,' date= ', ndastp 539 555 IF(lwp) WRITE(numout,*) '~~~~' 540 IF( lwxios ) CALL iom_swap( cwxios_context ) 541 CALL iom_rstput( kt, nitrst, numrow, 'utau_b' , utau, ldxios = lwxios ) 542 CALL iom_rstput( kt, nitrst, numrow, 'vtau_b' , vtau, ldxios = lwxios ) 543 CALL iom_rstput( kt, nitrst, numrow, 'qns_b' , qns, ldxios = lwxios ) 556 CALL iom_rstput( kt, nitrst, numrow, 'utau_b' , utau ) 557 CALL iom_rstput( kt, nitrst, numrow, 'vtau_b' , vtau ) 558 CALL iom_rstput( kt, nitrst, numrow, 'qns_b' , qns ) 544 559 ! The 3D heat content due to qsr forcing is treated in traqsr 545 560 ! CALL iom_rstput( kt, nitrst, numrow, 'qsr_b' , qsr ) 546 CALL iom_rstput( kt, nitrst, numrow, 'emp_b' , emp, ldxios = lwxios ) 547 CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx, ldxios = lwxios ) 548 IF( lwxios ) CALL iom_swap( cxios_context ) 561 CALL iom_rstput( kt, nitrst, numrow, 'emp_b' , emp ) 562 CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx ) 549 563 ENDIF 550 564 ! ! ---------------------------------------- ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/sbcrnf.F90
r13497 r14046 160 160 & iom_varid( numror, 'rnf_b', ldstop = .FALSE. ) > 0 ) THEN 161 161 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 , ldxios = lrxios) ! before runoff163 CALL iom_get( numror, jpdom_auto, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem) , ldxios = lrxios) ! before heat content of runoff164 CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal) , ldxios = lrxios) ! before salinity content of runoff162 CALL iom_get( numror, jpdom_auto, 'rnf_b', rnf_b ) ! before runoff 163 CALL iom_get( numror, jpdom_auto, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem) ) ! before heat content of runoff 164 CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal) ) ! before salinity content of runoff 165 165 ELSE !* no restart: set from nit000 values 166 166 IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields set to nit000' … … 176 176 & 'at it= ', kt,' date= ', ndastp 177 177 IF(lwp) WRITE(numout,*) '~~~~' 178 IF( lwxios ) CALL iom_swap( cwxios_context ) 179 CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf, ldxios = lwxios ) 180 CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem), ldxios = lwxios ) 181 CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal), ldxios = lwxios ) 182 IF( lwxios ) CALL iom_swap( cxios_context ) 178 CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf ) 179 CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem) ) 180 CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal) ) 183 181 ENDIF 184 182 ! … … 480 478 ENDIF 481 479 ! 482 IF( lwxios ) THEN483 CALL iom_set_rstw_var_active('rnf_b')484 CALL iom_set_rstw_var_active('rnf_hc_b')485 CALL iom_set_rstw_var_active('rnf_sc_b')486 ENDIF487 488 480 END SUBROUTINE sbc_rnf_init 489 481 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/sbcssm.F90
r13286 r14046 154 154 IF(lwp) WRITE(numout,*) '~~~~~~~' 155 155 zf_sbc = REAL( nn_fsbc, wp ) 156 IF( lwxios ) CALL iom_swap( cwxios_context ) 157 CALL iom_rstput( kt, nitrst, numrow, 'nn_fsbc', zf_sbc, ldxios = lwxios ) ! sbc frequency 158 CALL iom_rstput( kt, nitrst, numrow, 'ssu_m' , ssu_m, ldxios = lwxios ) ! sea surface mean fields 159 CALL iom_rstput( kt, nitrst, numrow, 'ssv_m' , ssv_m, ldxios = lwxios ) 160 CALL iom_rstput( kt, nitrst, numrow, 'sst_m' , sst_m, ldxios = lwxios ) 161 CALL iom_rstput( kt, nitrst, numrow, 'sss_m' , sss_m, ldxios = lwxios ) 162 CALL iom_rstput( kt, nitrst, numrow, 'ssh_m' , ssh_m, ldxios = lwxios ) 163 CALL iom_rstput( kt, nitrst, numrow, 'e3t_m' , e3t_m, ldxios = lwxios ) 164 CALL iom_rstput( kt, nitrst, numrow, 'frq_m' , frq_m, ldxios = lwxios ) 165 ! 166 IF( lwxios ) CALL iom_swap( cxios_context ) 156 CALL iom_rstput( kt, nitrst, numrow, 'nn_fsbc', zf_sbc ) ! sbc frequency 157 CALL iom_rstput( kt, nitrst, numrow, 'ssu_m' , ssu_m ) ! sea surface mean fields 158 CALL iom_rstput( kt, nitrst, numrow, 'ssv_m' , ssv_m ) 159 CALL iom_rstput( kt, nitrst, numrow, 'sst_m' , sst_m ) 160 CALL iom_rstput( kt, nitrst, numrow, 'sss_m' , sss_m ) 161 CALL iom_rstput( kt, nitrst, numrow, 'ssh_m' , ssh_m ) 162 CALL iom_rstput( kt, nitrst, numrow, 'e3t_m' , e3t_m ) 163 CALL iom_rstput( kt, nitrst, numrow, 'frq_m' , frq_m ) 164 ! 167 165 ENDIF 168 166 ! … … 208 206 IF( ln_rstart .AND. iom_varid( numror, 'nn_fsbc', ldstop = .FALSE. ) > 0 ) THEN 209 207 l_ssm_mean = .TRUE. 210 CALL iom_get( numror , 'nn_fsbc', zf_sbc ,ldxios = lrxios) ! sbc frequency of previous run211 CALL iom_get( numror, jpdom_auto, 'ssu_m' , ssu_m, ldxios = lrxios,cd_type = 'U', psgn = -1._wp ) ! sea surface mean velocity (U-point)212 CALL iom_get( numror, jpdom_auto, 'ssv_m' , ssv_m, ldxios = lrxios,cd_type = 'V', psgn = -1._wp ) ! " " velocity (V-point)213 CALL iom_get( numror, jpdom_auto, 'sst_m' , sst_m , ldxios = lrxios) ! " " temperature (T-point)214 CALL iom_get( numror, jpdom_auto, 'sss_m' , sss_m , ldxios = lrxios) ! " " salinity (T-point)215 CALL iom_get( numror, jpdom_auto, 'ssh_m' , ssh_m , ldxios = lrxios) ! " " height (T-point)216 CALL iom_get( numror, jpdom_auto, 'e3t_m' , e3t_m , ldxios = lrxios) ! 1st level thickness (T-point)208 CALL iom_get( numror , 'nn_fsbc', zf_sbc ) ! sbc frequency of previous run 209 CALL iom_get( numror, jpdom_auto, 'ssu_m' , ssu_m, cd_type = 'U', psgn = -1._wp ) ! sea surface mean velocity (U-point) 210 CALL iom_get( numror, jpdom_auto, 'ssv_m' , ssv_m, cd_type = 'V', psgn = -1._wp ) ! " " velocity (V-point) 211 CALL iom_get( numror, jpdom_auto, 'sst_m' , sst_m ) ! " " temperature (T-point) 212 CALL iom_get( numror, jpdom_auto, 'sss_m' , sss_m ) ! " " salinity (T-point) 213 CALL iom_get( numror, jpdom_auto, 'ssh_m' , ssh_m ) ! " " height (T-point) 214 CALL iom_get( numror, jpdom_auto, 'e3t_m' , e3t_m ) ! 1st level thickness (T-point) 217 215 ! fraction of solar net radiation absorbed in 1st T level 218 216 IF( iom_varid( numror, 'frq_m', ldstop = .FALSE. ) > 0 ) THEN 219 CALL iom_get( numror, jpdom_auto, 'frq_m' , frq_m , ldxios = lrxios)217 CALL iom_get( numror, jpdom_auto, 'frq_m' , frq_m ) 220 218 ELSE 221 219 frq_m(:,:) = 1._wp ! default definition … … 255 253 IF( .NOT. ln_traqsr ) fraqsr_1lev(:,:) = 1._wp ! default definition: qsr 100% in the fisrt level 256 254 ! 257 IF( lwxios.AND.nn_fsbc > 1 ) THEN258 CALL iom_set_rstw_var_active('nn_fsbc')259 CALL iom_set_rstw_var_active('ssu_m')260 CALL iom_set_rstw_var_active('ssv_m')261 CALL iom_set_rstw_var_active('sst_m')262 CALL iom_set_rstw_var_active('sss_m')263 CALL iom_set_rstw_var_active('ssh_m')264 CALL iom_set_rstw_var_active('e3t_m')265 CALL iom_set_rstw_var_active('frq_m')266 ENDIF267 268 255 END SUBROUTINE sbc_ssm_init 269 256 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/SBC/sbcwave.F90
r13546 r14046 9 9 !! - ! 2016-12 (G. Madec, E. Clementi) update Stoke drift computation 10 10 !! + add sbc_wave_ini routine 11 !! 4.2 ! 2020-12 (G. Madec, E. Clementi) updates, new Stoke drift computation 12 !! according to Couvelard et al.,2019 11 13 !!---------------------------------------------------------------------- 12 14 13 15 !!---------------------------------------------------------------------- 14 16 !! sbc_stokes : calculate 3D Stokes-drift velocities 15 !! sbc_wave : wave data from wave model in netcdf files17 !! sbc_wave : wave data from wave model: forced (netcdf files) or coupled mode 16 18 !! sbc_wave_init : initialisation fo surface waves 17 19 !!---------------------------------------------------------------------- 18 USE phycst ! physical constants 20 USE phycst ! physical constants 19 21 USE oce ! ocean variables 20 USE sbc_oce ! Surface boundary condition: ocean fields21 USE zdf_oce, ONLY : ln_zdfswm22 USE dom_oce ! ocean domain variables 23 USE sbc_oce ! Surface boundary condition: ocean fields 22 24 USE bdy_oce ! open boundary condition variables 23 25 USE domvvl ! domain: variable volume layers … … 26 28 USE in_out_manager ! I/O manager 27 29 USE lib_mpp ! distribued memory computing library 28 USE fldread 30 USE fldread ! read input fields 29 31 30 32 IMPLICIT NONE … … 32 34 33 35 PUBLIC sbc_stokes ! routine called in sbccpl 34 PUBLIC sbc_wstress ! routine called in sbcmod35 36 PUBLIC sbc_wave ! routine called in sbcmod 36 37 PUBLIC sbc_wave_init ! routine called in sbcmod 37 38 38 39 ! Variables checking if the wave parameters are coupled (if not, they are read from file) 39 LOGICAL, PUBLIC :: cpl_hsig = .FALSE. 40 LOGICAL, PUBLIC :: cpl_phioc = .FALSE. 41 LOGICAL, PUBLIC :: cpl_sdrftx = .FALSE. 42 LOGICAL, PUBLIC :: cpl_sdrfty = .FALSE. 43 LOGICAL, PUBLIC :: cpl_wper = .FALSE. 44 LOGICAL, PUBLIC :: cpl_wfreq = .FALSE. 45 LOGICAL, PUBLIC :: cpl_wnum = .FALSE. 46 LOGICAL, PUBLIC :: cpl_tauwoc = .FALSE. 47 LOGICAL, PUBLIC :: cpl_tauw = .FALSE. 48 LOGICAL, PUBLIC :: cpl_wdrag = .FALSE. 40 LOGICAL, PUBLIC :: cpl_hsig = .FALSE. 41 LOGICAL, PUBLIC :: cpl_phioc = .FALSE. 42 LOGICAL, PUBLIC :: cpl_sdrftx = .FALSE. 43 LOGICAL, PUBLIC :: cpl_sdrfty = .FALSE. 44 LOGICAL, PUBLIC :: cpl_wper = .FALSE. 45 LOGICAL, PUBLIC :: cpl_wnum = .FALSE. 46 LOGICAL, PUBLIC :: cpl_wstrf = .FALSE. 47 LOGICAL, PUBLIC :: cpl_wdrag = .FALSE. 48 LOGICAL, PUBLIC :: cpl_charn = .FALSE. 49 LOGICAL, PUBLIC :: cpl_taw = .FALSE. 50 LOGICAL, PUBLIC :: cpl_bhd = .FALSE. 51 LOGICAL, PUBLIC :: cpl_tusd = .FALSE. 52 LOGICAL, PUBLIC :: cpl_tvsd = .FALSE. 49 53 50 54 INTEGER :: jpfld ! number of files to read for stokes drift … … 53 57 INTEGER :: jp_hsw ! index of significant wave hight (m) at T-point 54 58 INTEGER :: jp_wmp ! index of mean wave period (s) at T-point 55 INTEGER :: jp_wfr ! index of wave peak frequency (1/s) at T-point56 59 57 60 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_cd ! structure of input fields (file informations, fields read) Drag Coefficient 58 61 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_sd ! structure of input fields (file informations, fields read) Stokes Drift 59 62 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_wn ! structure of input fields (file informations, fields read) wave number for Qiao 60 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tauwoc ! structure of input fields (file informations, fields read) normalized wave stress into the ocean 61 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tauw ! structure of input fields (file informations, fields read) ocean stress components from wave model 62 63 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: cdn_wave !: 64 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: hsw, wmp, wnum !: 65 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wfreq !: 66 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wave !: 67 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauw_x, tauw_y !: 68 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tsd2d !: 69 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: div_sd !: barotropic stokes drift divergence 70 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: ut0sd, vt0sd !: surface Stokes drift velocities at t-point 71 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: usd , vsd , wsd !: Stokes drift velocities at u-, v- & w-points, resp. 72 63 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tauoc ! structure of input fields (file informations, fields read) normalized wave stress into the ocean 64 65 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: cdn_wave !: Neutral drag coefficient at t-point 66 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: hsw !: Significant Wave Height at t-point 67 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wmp !: Wave Mean Period at t-point 68 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wnum !: Wave Number at t-point 69 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wave !: stress reduction factor at t-point 70 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tsd2d !: Surface Stokes Drift module at t-point 71 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: div_sd !: barotropic stokes drift divergence 72 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: ut0sd, vt0sd !: surface Stokes drift velocities at t-point 73 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: usd, vsd, wsd !: Stokes drift velocities at u-, v- & w-points, resp.u 74 ! 75 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: charn !: charnock coefficient at t-point 76 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tawx !: Net wave-supported stress, u 77 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tawy !: Net wave-supported stress, v 78 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: twox !: wave-ocean momentum flux, u 79 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: twoy !: wave-ocean momentum flux, v 80 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wavex !: stress reduction factor at, u component 81 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wavey !: stress reduction factor at, v component 82 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: phioc !: tke flux from wave model 83 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: KZN2 !: Kz*N2 84 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: bhd_wave !: Bernoulli head. wave induce pression 85 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tusd, tvsd !: Stokes drift transport 86 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: ZMX !: Kz*N2 73 87 !! * Substitutions 74 88 # include "do_loop_substitute.h90" … … 88 102 !! 2014 (DOI: 10.1175/JPO-D-14-0020.1) 89 103 !! 90 !! ** Method : - Calculate Stokes transport speed 91 !! - Calculate horizontal divergence 92 !! - Integrate the horizontal divergenze from the bottom 93 !! ** action 104 !! ** Method : - Calculate the horizontal Stokes drift velocity (Breivik et al. 2014) 105 !! - Calculate its horizontal divergence 106 !! - Calculate the vertical Stokes drift velocity 107 !! - Calculate the barotropic Stokes drift divergence 108 !! 109 !! ** action : - tsd2d : module of the surface Stokes drift velocity 110 !! - usd, vsd, wsd : 3 components of the Stokes drift velocity 111 !! - div_sd : barotropic Stokes drift divergence 94 112 !!--------------------------------------------------------------------- 95 113 INTEGER, INTENT(in) :: Kmm ! ocean time level index 96 114 INTEGER :: jj, ji, jk ! dummy loop argument 97 115 INTEGER :: ik ! local integer 98 REAL(wp) :: ztransp, zfac, zsp0 99 REAL(wp) :: zdepth, zsqrt_depth, zexp_depth, z_two_thirds, zsqrtpi !sqrt of pi 100 REAL(wp) :: zbot_u, zbot_v, zkb_u, zkb_v, zke3_u, zke3_v, zda_u, zda_v 101 REAL(wp) :: zstokes_psi_u_bot, zstokes_psi_v_bot 102 REAL(wp) :: zdep_u, zdep_v, zkh_u, zkh_v 103 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zk_t, zk_u, zk_v, zu0_sd, zv0_sd ! 2D workspace 104 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zstokes_psi_u_top, zstokes_psi_v_top ! 2D workspace 105 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3divh ! 3D workspace 106 !!--------------------------------------------------------------------- 107 ! 108 ALLOCATE( ze3divh(jpi,jpj,jpkm1) ) ! jpkm1 -> avoid lbc_lnk on jpk that is not defined 116 REAL(wp) :: ztransp, zfac, ztemp, zsp0, zsqrt, zbreiv16_w 117 REAL(wp) :: zdep_u, zdep_v, zkh_u, zkh_v, zda_u, zda_v, sdtrp 118 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zk_t, zk_u, zk_v, zu0_sd, zv0_sd ! 2D workspace 119 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3divh, zInt_w ! 3D workspace 120 !!--------------------------------------------------------------------- 121 ! 122 ALLOCATE( ze3divh(jpi,jpj,jpkm1) ) ! jpkm1 -> avoid lbc_lnk on jpk that is not defined 123 ALLOCATE( zInt_w(jpi,jpj,jpk) ) 109 124 ALLOCATE( zk_t(jpi,jpj), zk_u(jpi,jpj), zk_v(jpi,jpj), zu0_sd(jpi,jpj), zv0_sd(jpi,jpj) ) 125 zk_t (:,:) = 0._wp 126 zk_u (:,:) = 0._wp 127 zk_v (:,:) = 0._wp 128 zu0_sd (:,:) = 0._wp 129 zv0_sd (:,:) = 0._wp 130 ze3divh (:,:,:) = 0._wp 131 110 132 ! 111 133 ! select parameterization for the calculation of vertical Stokes drift 112 134 ! exp. wave number at t-point 113 IF( ll_st_bv_li ) THEN ! (Eq. (19) in Breivik et al. (2014) ) 135 IF( ln_breivikFV_2016 ) THEN 136 ! Assumptions : ut0sd and vt0sd are surface Stokes drift at T-points 137 ! sdtrp is the norm of Stokes transport 138 ! 139 zfac = 0.166666666667_wp 140 DO_2D( 1, 1, 1, 1 ) ! In the deep-water limit we have ke = ||ust0||/( 6 * ||transport|| ) 141 zsp0 = SQRT( ut0sd(ji,jj)*ut0sd(ji,jj) + vt0sd(ji,jj)*vt0sd(ji,jj) ) !<-- norm of Surface Stokes drift 142 tsd2d(ji,jj) = zsp0 143 IF( cpl_tusd .AND. cpl_tvsd ) THEN !stokes transport is provided in coupled mode 144 sdtrp = SQRT( tusd(ji,jj)*tusd(ji,jj) + tvsd(ji,jj)*tvsd(ji,jj) ) !<-- norm of Surface Stokes drift transport 145 ELSE 146 ! Stokes drift transport estimated from Hs and Tmean 147 sdtrp = 2.0_wp * rpi / 16.0_wp * & 148 & hsw(ji,jj)*hsw(ji,jj) / MAX( wmp(ji,jj), 0.0000001_wp ) 149 ENDIF 150 zk_t (ji,jj) = zfac * zsp0 / MAX ( sdtrp, 0.0000001_wp ) !<-- ke = ||ust0||/( 6 * ||transport|| ) 151 END_2D 152 !# define zInt_w ze3divh 153 DO_3D( 1, 1, 1, 1, 1, jpk ) ! Compute the primitive of Breivik 2016 function at W-points 154 zfac = - 2._wp * zk_t (ji,jj) * gdepw(ji,jj,jk,Kmm) !<-- zfac should be negative definite 155 ztemp = EXP ( zfac ) 156 zsqrt = SQRT( -zfac ) 157 zbreiv16_w = ztemp - SQRT(rpi)*zsqrt*ERFC(zsqrt) !Eq. 16 Breivik 2016 158 zInt_w(ji,jj,jk) = ztemp - 4._wp * zk_t (ji,jj) * gdepw(ji,jj,jk,Kmm) * zbreiv16_w 159 END_3D 160 ! 161 DO jk = 1, jpkm1 162 zfac = 0.166666666667_wp 163 DO_2D( 1, 1, 1, 1 ) !++ Compute the FV Breivik 2016 function at T-points 164 zsp0 = zfac / MAX(zk_t (ji,jj),0.0000001_wp) 165 ztemp = zInt_w(ji,jj,jk) - zInt_w(ji,jj,jk+1) 166 zu0_sd(ji,jj) = ut0sd(ji,jj) * zsp0 * ztemp * tmask(ji,jj,jk) 167 zv0_sd(ji,jj) = vt0sd(ji,jj) * zsp0 * ztemp * tmask(ji,jj,jk) 168 END_2D 169 DO_2D( 1, 0, 1, 0 ) ! ++ Interpolate at U/V points 170 zfac = 1.0_wp / e3u(ji ,jj,jk,Kmm) 171 usd(ji,jj,jk) = 0.5_wp * zfac * ( zu0_sd(ji,jj)+zu0_sd(ji+1,jj) ) * umask(ji,jj,jk) 172 zfac = 1.0_wp / e3v(ji ,jj,jk,Kmm) 173 vsd(ji,jj,jk) = 0.5_wp * zfac * ( zv0_sd(ji,jj)+zv0_sd(ji,jj+1) ) * vmask(ji,jj,jk) 174 END_2D 175 ENDDO 176 !# undef zInt_w 177 ! 178 ELSE 114 179 zfac = 2.0_wp * rpi / 16.0_wp 115 180 DO_2D( 1, 1, 1, 1 ) … … 128 193 zv0_sd(ji,jj) = 0.5_wp * ( vt0sd(ji,jj) + vt0sd(ji,jj+1) ) 129 194 END_2D 130 ELSE IF( ll_st_peakfr ) THEN ! peak wave number calculated from the peak frequency received by the wave model 131 DO_2D( 1, 1, 1, 1 ) 132 zk_t(ji,jj) = ( 2.0_wp * rpi * wfreq(ji,jj) ) * ( 2.0_wp * rpi * wfreq(ji,jj) ) / grav 133 END_2D 134 DO_2D( 1, 0, 1, 0 ) 135 zk_u(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji+1,jj) ) 136 zk_v(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji,jj+1) ) 137 ! 138 zu0_sd(ji,jj) = 0.5_wp * ( ut0sd(ji,jj) + ut0sd(ji+1,jj) ) 139 zv0_sd(ji,jj) = 0.5_wp * ( vt0sd(ji,jj) + vt0sd(ji,jj+1) ) 140 END_2D 141 ENDIF 142 ! 195 143 196 ! !== horizontal Stokes Drift 3D velocity ==! 144 IF( ll_st_bv2014 ) THEN 197 145 198 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 146 199 zdep_u = 0.5_wp * ( gdept(ji,jj,jk,Kmm) + gdept(ji+1,jj,jk,Kmm) ) 147 200 zdep_v = 0.5_wp * ( gdept(ji,jj,jk,Kmm) + gdept(ji,jj+1,jk,Kmm) ) 148 ! 201 ! 149 202 zkh_u = zk_u(ji,jj) * zdep_u ! k * depth 150 203 zkh_v = zk_v(ji,jj) * zdep_v … … 156 209 vsd(ji,jj,jk) = zda_v * zv0_sd(ji,jj) * vmask(ji,jj,jk) 157 210 END_3D 158 ELSE IF( ll_st_li2017 .OR. ll_st_peakfr ) THEN159 ALLOCATE( zstokes_psi_u_top(jpi,jpj), zstokes_psi_v_top(jpi,jpj) )160 DO_2D( 1, 0, 1, 0 )161 zstokes_psi_u_top(ji,jj) = 0._wp162 zstokes_psi_v_top(ji,jj) = 0._wp163 END_2D164 zsqrtpi = SQRT(rpi)165 z_two_thirds = 2.0_wp / 3.0_wp166 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! exp. wave number & Stokes drift velocity at u- & v-points167 zbot_u = ( gdepw(ji,jj,jk+1,Kmm) + gdepw(ji+1,jj,jk+1,Kmm) ) ! 2 * bottom depth168 zbot_v = ( gdepw(ji,jj,jk+1,Kmm) + gdepw(ji,jj+1,jk+1,Kmm) ) ! 2 * bottom depth169 zkb_u = zk_u(ji,jj) * zbot_u ! 2 * k * bottom depth170 zkb_v = zk_v(ji,jj) * zbot_v ! 2 * k * bottom depth171 !172 zke3_u = MAX(1.e-8_wp, 2.0_wp * zk_u(ji,jj) * e3u(ji,jj,jk,Kmm)) ! 2k * thickness173 zke3_v = MAX(1.e-8_wp, 2.0_wp * zk_v(ji,jj) * e3v(ji,jj,jk,Kmm)) ! 2k * thickness174 175 ! Depth attenuation .... do u component first..176 zdepth = zkb_u177 zsqrt_depth = SQRT(zdepth)178 zexp_depth = EXP(-zdepth)179 zstokes_psi_u_bot = 1.0_wp - zexp_depth &180 & - z_two_thirds * ( zsqrtpi*zsqrt_depth*zdepth*ERFC(zsqrt_depth) &181 & + 1.0_wp - (1.0_wp + zdepth)*zexp_depth )182 zda_u = ( zstokes_psi_u_bot - zstokes_psi_u_top(ji,jj) ) / zke3_u183 zstokes_psi_u_top(ji,jj) = zstokes_psi_u_bot184 185 ! ... and then v component186 zdepth =zkb_v187 zsqrt_depth = SQRT(zdepth)188 zexp_depth = EXP(-zdepth)189 zstokes_psi_v_bot = 1.0_wp - zexp_depth &190 & - z_two_thirds * ( zsqrtpi*zsqrt_depth*zdepth*ERFC(zsqrt_depth) &191 & + 1.0_wp - (1.0_wp + zdepth)*zexp_depth )192 zda_v = ( zstokes_psi_v_bot - zstokes_psi_v_top(ji,jj) ) / zke3_v193 zstokes_psi_v_top(ji,jj) = zstokes_psi_v_bot194 !195 usd(ji,jj,jk) = zda_u * zu0_sd(ji,jj) * umask(ji,jj,jk)196 vsd(ji,jj,jk) = zda_v * zv0_sd(ji,jj) * vmask(ji,jj,jk)197 END_3D198 DEALLOCATE( zstokes_psi_u_top, zstokes_psi_v_top )199 211 ENDIF 200 212 … … 235 247 CALL iom_put( "vstokes", vsd ) 236 248 CALL iom_put( "wstokes", wsd ) 237 !238 DEALLOCATE( ze3divh )249 ! ! 250 DEALLOCATE( ze3divh, zInt_w ) 239 251 DEALLOCATE( zk_t, zk_u, zk_v, zu0_sd, zv0_sd ) 240 252 ! 241 253 END SUBROUTINE sbc_stokes 242 243 244 SUBROUTINE sbc_wstress( ) 245 !!--------------------------------------------------------------------- 246 !! *** ROUTINE sbc_wstress *** 247 !! 248 !! ** Purpose : Updates the ocean momentum modified by waves 249 !! 250 !! ** Method : - Calculate u,v components of stress depending on stress 251 !! model 252 !! - Calculate the stress module 253 !! - The wind module is not modified by waves 254 !! ** action 255 !!--------------------------------------------------------------------- 256 INTEGER :: jj, ji ! dummy loop argument 257 ! 258 IF( ln_tauwoc ) THEN 259 utau(:,:) = utau(:,:)*tauoc_wave(:,:) 260 vtau(:,:) = vtau(:,:)*tauoc_wave(:,:) 261 taum(:,:) = taum(:,:)*tauoc_wave(:,:) 262 ENDIF 263 ! 264 IF( ln_tauw ) THEN 265 DO_2D( 1, 0, 1, 0 ) 266 ! Stress components at u- & v-points 267 utau(ji,jj) = 0.5_wp * ( tauw_x(ji,jj) + tauw_x(ji+1,jj) ) 268 vtau(ji,jj) = 0.5_wp * ( tauw_y(ji,jj) + tauw_y(ji,jj+1) ) 269 ! 270 ! Stress module at t points 271 taum(ji,jj) = SQRT( tauw_x(ji,jj)*tauw_x(ji,jj) + tauw_y(ji,jj)*tauw_y(ji,jj) ) 272 END_2D 273 CALL lbc_lnk_multi( 'sbcwave', utau(:,:), 'U', -1.0_wp , vtau(:,:), 'V', -1.0_wp , taum(:,:) , 'T', -1.0_wp ) 274 ENDIF 275 ! 276 END SUBROUTINE sbc_wstress 277 278 254 ! 255 ! 279 256 SUBROUTINE sbc_wave( kt, Kmm ) 280 257 !!--------------------------------------------------------------------- 281 258 !! *** ROUTINE sbc_wave *** 282 259 !! 283 !! ** Purpose : read wave parameters from wave model in netcdf files. 284 !! 285 !! ** Method : - Read namelist namsbc_wave 286 !! - Read Cd_n10 fields in netcdf files 287 !! - Read stokes drift 2d in netcdf files 288 !! - Read wave number in netcdf files 289 !! - Compute 3d stokes drift using Breivik et al.,2014 290 !! formulation 291 !! ** action 260 !! ** Purpose : read wave parameters from wave model in netcdf files 261 !! or from a coupled wave mdoel 262 !! 292 263 !!--------------------------------------------------------------------- 293 264 INTEGER, INTENT(in ) :: kt ! ocean time step 294 265 INTEGER, INTENT(in ) :: Kmm ! ocean time index 295 266 !!--------------------------------------------------------------------- 267 ! 268 IF( kt == nit000 .AND. lwp ) THEN 269 WRITE(numout,*) 270 WRITE(numout,*) 'sbc_wave : update the read waves fields' 271 WRITE(numout,*) '~~~~~~~~ ' 272 ENDIF 296 273 ! 297 274 IF( ln_cdgw .AND. .NOT. cpl_wdrag ) THEN !== Neutral drag coefficient ==! … … 300 277 ENDIF 301 278 302 IF( ln_tauwoc .AND. .NOT. cpl_tauwoc ) THEN !== Wave induced stress ==! 303 CALL fld_read( kt, nn_fsbc, sf_tauwoc ) ! read wave norm stress from external forcing 304 tauoc_wave(:,:) = sf_tauwoc(1)%fnow(:,:,1) * tmask(:,:,1) 305 ENDIF 306 307 IF( ln_tauw .AND. .NOT. cpl_tauw ) THEN !== Wave induced stress ==! 308 CALL fld_read( kt, nn_fsbc, sf_tauw ) ! read ocean stress components from external forcing (T grid) 309 tauw_x(:,:) = sf_tauw(1)%fnow(:,:,1) * tmask(:,:,1) 310 tauw_y(:,:) = sf_tauw(2)%fnow(:,:,1) * tmask(:,:,1) 311 ENDIF 312 313 IF( ln_sdw ) THEN !== Computation of the 3d Stokes Drift ==! 279 IF( ln_tauoc .AND. .NOT. cpl_wstrf ) THEN !== Wave induced stress ==! 280 CALL fld_read( kt, nn_fsbc, sf_tauoc ) ! read stress reduction factor due to wave from external forcing 281 tauoc_wave(:,:) = sf_tauoc(1)%fnow(:,:,1) * tmask(:,:,1) 282 ELSEIF ( ln_taw .AND. cpl_taw ) THEN 283 IF (kt < 1) THEN ! The first fields gave by OASIS have very high erroneous values .... 284 twox(:,:)=0._wp 285 twoy(:,:)=0._wp 286 tawx(:,:)=0._wp 287 tawy(:,:)=0._wp 288 tauoc_wavex(:,:) = 1._wp 289 tauoc_wavey(:,:) = 1._wp 290 ELSE 291 tauoc_wavex(:,:) = abs(twox(:,:)/tawx(:,:)) 292 tauoc_wavey(:,:) = abs(twoy(:,:)/tawy(:,:)) 293 ENDIF 294 ENDIF 295 296 IF ( ln_phioc .and. cpl_phioc .and. kt == nit000 ) THEN 297 WRITE(numout,*) 298 WRITE(numout,*) 'sbc_wave : PHIOC from wave model' 299 WRITE(numout,*) '~~~~~~~~ ' 300 ENDIF 301 302 IF( ln_sdw .AND. .NOT. cpl_sdrftx) THEN !== Computation of the 3d Stokes Drift ==! 314 303 ! 315 304 IF( jpfld > 0 ) THEN ! Read from file only if the field is not coupled 316 305 CALL fld_read( kt, nn_fsbc, sf_sd ) ! read wave parameters from external forcing 306 ! ! NB: test case mode, not read as jpfld=0 317 307 IF( jp_hsw > 0 ) hsw (:,:) = sf_sd(jp_hsw)%fnow(:,:,1) * tmask(:,:,1) ! significant wave height 318 308 IF( jp_wmp > 0 ) wmp (:,:) = sf_sd(jp_wmp)%fnow(:,:,1) * tmask(:,:,1) ! wave mean period 319 IF( jp_wfr > 0 ) wfreq(:,:) = sf_sd(jp_wfr)%fnow(:,:,1) * tmask(:,:,1) ! Peak wave frequency320 309 IF( jp_usd > 0 ) ut0sd(:,:) = sf_sd(jp_usd)%fnow(:,:,1) * tmask(:,:,1) ! 2D zonal Stokes Drift at T point 321 310 IF( jp_vsd > 0 ) vt0sd(:,:) = sf_sd(jp_vsd)%fnow(:,:,1) * tmask(:,:,1) ! 2D meridional Stokes Drift at T point 322 311 ENDIF 323 312 ! 324 ! Read also wave number if needed, so that it is available in coupling routines 325 IF( ln_zdfswm .AND. .NOT.cpl_wnum ) THEN 326 CALL fld_read( kt, nn_fsbc, sf_wn ) ! read wave parameters from external forcing 327 wnum(:,:) = sf_wn(1)%fnow(:,:,1) * tmask(:,:,1) 328 ENDIF 329 330 ! Calculate only if required fields have been read 331 ! In coupled wave model-NEMO case the call is done after coupling 313 IF( jpfld == 4 .OR. ln_wave_test ) & 314 & CALL sbc_stokes( Kmm ) ! Calculate only if all required fields are read 315 ! ! or in wave test case 316 ! ! ! In coupled case the call is done after (in sbc_cpl) 317 ENDIF 332 318 ! 333 IF( ( ll_st_bv_li .AND. jp_hsw>0 .AND. jp_wmp>0 .AND. jp_usd>0 .AND. jp_vsd>0 ) .OR. &334 & ( ll_st_peakfr .AND. jp_wfr>0 .AND. jp_usd>0 .AND. jp_vsd>0 ) ) CALL sbc_stokes( Kmm )335 !336 ENDIF337 !338 319 END SUBROUTINE sbc_wave 339 320 … … 343 324 !! *** ROUTINE sbc_wave_init *** 344 325 !! 345 !! ** Purpose : read wave parameters from wave model in netcdf files.326 !! ** Purpose : Initialisation fo surface waves 346 327 !! 347 328 !! ** Method : - Read namelist namsbc_wave 348 !! - Read Cd_n10 fields in netcdf files 349 !! - Read stokes drift 2d in netcdf files 350 !! - Read wave number in netcdf files 351 !! - Compute 3d stokes drift using Breivik et al.,2014 352 !! formulation 329 !! - create the structure used to read required wave fields 330 !! (its size depends on namelist options) 353 331 !! ** action 354 332 !!--------------------------------------------------------------------- … … 357 335 !! 358 336 CHARACTER(len=100) :: cn_dir ! Root directory for location of drag coefficient files 359 TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: slf_i , slf_j! array of namelist informations on the fields to read337 TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: slf_i ! array of namelist informations on the fields to read 360 338 TYPE(FLD_N) :: sn_cdg, sn_usd, sn_vsd, & 361 & sn_hsw, sn_wmp, sn_wfr, sn_wnum, & 362 & sn_tauwoc, sn_tauwx, sn_tauwy ! informations about the fields to be read 363 ! 364 NAMELIST/namsbc_wave/ sn_cdg, cn_dir, sn_usd, sn_vsd, sn_hsw, sn_wmp, sn_wfr, & 365 sn_wnum, sn_tauwoc, sn_tauwx, sn_tauwy 366 !!--------------------------------------------------------------------- 339 & sn_hsw, sn_wmp, sn_wnum, sn_tauoc ! informations about the fields to be read 340 ! 341 NAMELIST/namsbc_wave/ cn_dir, sn_cdg, sn_usd, sn_vsd, sn_hsw, sn_wmp, sn_wnum, sn_tauoc, & 342 & ln_cdgw, ln_sdw, ln_tauoc, ln_stcor, ln_charn, ln_taw, ln_phioc, & 343 & ln_wave_test, ln_bern_srfc, ln_breivikFV_2016, ln_vortex_force, ln_stshear 344 !!--------------------------------------------------------------------- 345 IF(lwp) THEN 346 WRITE(numout,*) 347 WRITE(numout,*) 'sbc_wave_init : surface waves in the system' 348 WRITE(numout,*) '~~~~~~~~~~~~~ ' 349 ENDIF 367 350 ! 368 351 READ ( numnam_ref, namsbc_wave, IOSTAT = ios, ERR = 901) 369 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_wave in reference namelist' 370 352 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_wave in reference namelist') 353 371 354 READ ( numnam_cfg, namsbc_wave, IOSTAT = ios, ERR = 902 ) 372 355 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_wave in configuration namelist' ) 373 356 IF(lwm) WRITE ( numond, namsbc_wave ) 374 357 ! 375 IF( ln_cdgw ) THEN 376 IF( .NOT. cpl_wdrag ) THEN 377 ALLOCATE( sf_cd(1), STAT=ierror ) !* allocate and fill sf_wave with sn_cdg 378 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) 358 IF(lwp) THEN 359 WRITE(numout,*) ' Namelist namsbc_wave' 360 WRITE(numout,*) ' Stokes drift ln_sdw = ', ln_sdw 361 WRITE(numout,*) ' Breivik 2016 ln_breivikFV_2016 = ', ln_breivikFV_2016 362 WRITE(numout,*) ' Stokes Coriolis & tracer advection terms ln_stcor = ', ln_stcor 363 WRITE(numout,*) ' Vortex Force ln_vortex_force = ', ln_vortex_force 364 WRITE(numout,*) ' Bernouilli Head Pressure ln_bern_srfc = ', ln_bern_srfc 365 WRITE(numout,*) ' wave modified ocean stress ln_tauoc = ', ln_tauoc 366 WRITE(numout,*) ' neutral drag coefficient (CORE bulk only) ln_cdgw = ', ln_cdgw 367 WRITE(numout,*) ' charnock coefficient ln_charn = ', ln_charn 368 WRITE(numout,*) ' Stress modificated by wave ln_taw = ', ln_taw 369 WRITE(numout,*) ' TKE flux from wave ln_phioc = ', ln_phioc 370 WRITE(numout,*) ' Surface shear with Stokes drift ln_stshear = ', ln_stshear 371 WRITE(numout,*) ' Test with constant wave fields ln_wave_test = ', ln_wave_test 372 ENDIF 373 374 ! ! option check 375 IF( .NOT.( ln_cdgw .OR. ln_sdw .OR. ln_tauoc .OR. ln_stcor .OR. ln_charn) ) & 376 & CALL ctl_warn( 'Ask for wave coupling but ln_cdgw=F, ln_sdw=F, ln_tauoc=F, ln_stcor=F') 377 IF( ln_cdgw .AND. ln_blk ) & 378 & CALL ctl_stop( 'drag coefficient read from wave model NOT available yet with aerobulk package') 379 IF( ln_stcor .AND. .NOT.ln_sdw ) & 380 & CALL ctl_stop( 'Stokes-Coriolis term calculated only if activated Stokes Drift ln_sdw=T') 381 382 ! !== Allocate wave arrays ==! 383 ALLOCATE( ut0sd (jpi,jpj) , vt0sd (jpi,jpj) ) 384 ALLOCATE( hsw (jpi,jpj) , wmp (jpi,jpj) ) 385 ALLOCATE( wnum (jpi,jpj) ) 386 ALLOCATE( tsd2d (jpi,jpj) , div_sd(jpi,jpj) , bhd_wave(jpi,jpj) ) 387 ALLOCATE( usd (jpi,jpj,jpk), vsd (jpi,jpj,jpk), wsd (jpi,jpj,jpk) ) 388 ALLOCATE( tusd (jpi,jpj) , tvsd (jpi,jpj) , ZMX (jpi,jpj,jpk) ) 389 usd (:,:,:) = 0._wp 390 vsd (:,:,:) = 0._wp 391 wsd (:,:,:) = 0._wp 392 hsw (:,:) = 0._wp 393 wmp (:,:) = 0._wp 394 ut0sd (:,:) = 0._wp 395 vt0sd (:,:) = 0._wp 396 tusd (:,:) = 0._wp 397 tvsd (:,:) = 0._wp 398 bhd_wave(:,:) = 0._wp 399 ZMX (:,:,:) = 0._wp 400 ! 401 IF( ln_wave_test ) THEN !== Wave TEST case ==! set uniform waves fields 402 jpfld = 0 ! No field read 403 ln_cdgw = .FALSE. ! No neutral wave drag input 404 ln_tauoc = .FALSE. ! No wave induced drag reduction factor 405 ut0sd(:,:) = 0.13_wp * tmask(:,:,1) ! m/s 406 vt0sd(:,:) = 0.00_wp ! m/s 407 hsw (:,:) = 2.80_wp ! meters 408 wmp (:,:) = 8.00_wp ! seconds 409 ! 410 ELSE !== create the structure associated with fields to be read ==! 411 IF( ln_cdgw ) THEN ! wave drag 412 IF( .NOT. cpl_wdrag ) THEN 413 ALLOCATE( sf_cd(1), STAT=ierror ) !* allocate and fill sf_wave with sn_cdg 414 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) 415 ! 416 ALLOCATE( sf_cd(1)%fnow(jpi,jpj,1) ) 417 IF( sn_cdg%ln_tint ) ALLOCATE( sf_cd(1)%fdta(jpi,jpj,1,2) ) 418 CALL fld_fill( sf_cd, (/ sn_cdg /), cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) 419 ENDIF 420 ALLOCATE( cdn_wave(jpi,jpj) ) 421 cdn_wave(:,:) = 0._wp 422 ENDIF 423 IF( ln_charn ) THEN ! wave drag 424 IF( .NOT. cpl_charn ) THEN 425 CALL ctl_stop( 'STOP', 'Charnock based wind stress can be used in coupled mode only' ) 426 ENDIF 427 ALLOCATE( charn(jpi,jpj) ) 428 charn(:,:) = 0._wp 429 ENDIF 430 IF( ln_taw ) THEN ! wind stress 431 IF( .NOT. cpl_taw ) THEN 432 CALL ctl_stop( 'STOP', 'wind stress from wave model can be used in coupled mode only, use ln_cdgw instead' ) 433 ENDIF 434 ALLOCATE( tawx(jpi,jpj) ) 435 ALLOCATE( tawy(jpi,jpj) ) 436 ALLOCATE( twox(jpi,jpj) ) 437 ALLOCATE( twoy(jpi,jpj) ) 438 ALLOCATE( tauoc_wavex(jpi,jpj) ) 439 ALLOCATE( tauoc_wavey(jpi,jpj) ) 440 tawx(:,:) = 0._wp 441 tawy(:,:) = 0._wp 442 twox(:,:) = 0._wp 443 twoy(:,:) = 0._wp 444 tauoc_wavex(:,:) = 1._wp 445 tauoc_wavey(:,:) = 1._wp 446 ENDIF 447 448 IF( ln_phioc ) THEN ! TKE flux 449 IF( .NOT. cpl_phioc ) THEN 450 CALL ctl_stop( 'STOP', 'phioc can be used in coupled mode only' ) 451 ENDIF 452 ALLOCATE( phioc(jpi,jpj) ) 453 phioc(:,:) = 0._wp 454 ENDIF 455 456 IF( ln_tauoc ) THEN ! normalized wave stress into the ocean 457 IF( .NOT. cpl_wstrf ) THEN 458 ALLOCATE( sf_tauoc(1), STAT=ierror ) !* allocate and fill sf_wave with sn_tauoc 459 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_tauoc structure' ) 460 ! 461 ALLOCATE( sf_tauoc(1)%fnow(jpi,jpj,1) ) 462 IF( sn_tauoc%ln_tint ) ALLOCATE( sf_tauoc(1)%fdta(jpi,jpj,1,2) ) 463 CALL fld_fill( sf_tauoc, (/ sn_tauoc /), cn_dir, 'sbc_wave_init', 'Wave module', 'namsbc_wave' ) 464 ENDIF 465 ALLOCATE( tauoc_wave(jpi,jpj) ) 466 tauoc_wave(:,:) = 0._wp 467 ENDIF 468 469 IF( ln_sdw ) THEN ! Stokes drift 470 ! 1. Find out how many fields have to be read from file if not coupled 471 jpfld=0 472 jp_usd=0 ; jp_vsd=0 ; jp_hsw=0 ; jp_wmp=0 473 IF( .NOT. cpl_sdrftx ) THEN 474 jpfld = jpfld + 1 475 jp_usd = jpfld 476 ENDIF 477 IF( .NOT. cpl_sdrfty ) THEN 478 jpfld = jpfld + 1 479 jp_vsd = jpfld 480 ENDIF 481 IF( .NOT. cpl_hsig ) THEN 482 jpfld = jpfld + 1 483 jp_hsw = jpfld 484 ENDIF 485 IF( .NOT. cpl_wper ) THEN 486 jpfld = jpfld + 1 487 jp_wmp = jpfld 488 ENDIF 489 ! 2. Read from file only the non-coupled fields 490 IF( jpfld > 0 ) THEN 491 ALLOCATE( slf_i(jpfld) ) 492 IF( jp_usd > 0 ) slf_i(jp_usd) = sn_usd 493 IF( jp_vsd > 0 ) slf_i(jp_vsd) = sn_vsd 494 IF( jp_hsw > 0 ) slf_i(jp_hsw) = sn_hsw 495 IF( jp_wmp > 0 ) slf_i(jp_wmp) = sn_wmp 496 ALLOCATE( sf_sd(jpfld), STAT=ierror ) !* allocate and fill sf_sd with stokes drift 497 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) 498 ! 499 DO ifpr= 1, jpfld 500 ALLOCATE( sf_sd(ifpr)%fnow(jpi,jpj,1) ) 501 IF( slf_i(ifpr)%ln_tint ) ALLOCATE( sf_sd(ifpr)%fdta(jpi,jpj,1,2) ) 502 END DO 503 ! 504 CALL fld_fill( sf_sd, slf_i, cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) 505 ENDIF 379 506 ! 380 ALLOCATE( sf_cd(1)%fnow(jpi,jpj,1) ) 381 IF( sn_cdg%ln_tint ) ALLOCATE( sf_cd(1)%fdta(jpi,jpj,1,2) ) 382 CALL fld_fill( sf_cd, (/ sn_cdg /), cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) 383 ENDIF 384 ALLOCATE( cdn_wave(jpi,jpj) ) 385 ENDIF 386 387 IF( ln_tauwoc ) THEN 388 IF( .NOT. cpl_tauwoc ) THEN 389 ALLOCATE( sf_tauwoc(1), STAT=ierror ) !* allocate and fill sf_wave with sn_tauwoc 390 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) 507 ! 3. Wave number (only needed for Qiao parametrisation, ln_zdfqiao=T) 508 IF( .NOT. cpl_wnum ) THEN 509 ALLOCATE( sf_wn(1), STAT=ierror ) !* allocate and fill sf_wave with sn_wnum 510 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wn structure' ) 511 ALLOCATE( sf_wn(1)%fnow(jpi,jpj,1) ) 512 IF( sn_wnum%ln_tint ) ALLOCATE( sf_wn(1)%fdta(jpi,jpj,1,2) ) 513 CALL fld_fill( sf_wn, (/ sn_wnum /), cn_dir, 'sbc_wave', 'Wave module', 'namsbc_wave' ) 514 ENDIF 391 515 ! 392 ALLOCATE( sf_tauwoc(1)%fnow(jpi,jpj,1) ) 393 IF( sn_tauwoc%ln_tint ) ALLOCATE( sf_tauwoc(1)%fdta(jpi,jpj,1,2) ) 394 CALL fld_fill( sf_tauwoc, (/ sn_tauwoc /), cn_dir, 'sbc_wave_init', 'Wave module', 'namsbc_wave' ) 395 ENDIF 396 ALLOCATE( tauoc_wave(jpi,jpj) ) 397 ENDIF 398 399 IF( ln_tauw ) THEN 400 IF( .NOT. cpl_tauw ) THEN 401 ALLOCATE( sf_tauw(2), STAT=ierror ) !* allocate and fill sf_wave with sn_tauwx/y 402 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_tauw structure' ) 403 ! 404 ALLOCATE( slf_j(2) ) 405 slf_j(1) = sn_tauwx 406 slf_j(2) = sn_tauwy 407 ALLOCATE( sf_tauw(1)%fnow(jpi,jpj,1) ) 408 ALLOCATE( sf_tauw(2)%fnow(jpi,jpj,1) ) 409 IF( slf_j(1)%ln_tint ) ALLOCATE( sf_tauw(1)%fdta(jpi,jpj,1,2) ) 410 IF( slf_j(2)%ln_tint ) ALLOCATE( sf_tauw(2)%fdta(jpi,jpj,1,2) ) 411 CALL fld_fill( sf_tauw, (/ slf_j /), cn_dir, 'sbc_wave_init', 'read wave input', 'namsbc_wave' ) 412 ENDIF 413 ALLOCATE( tauw_x(jpi,jpj) ) 414 ALLOCATE( tauw_y(jpi,jpj) ) 415 ENDIF 416 417 IF( ln_sdw ) THEN ! Find out how many fields have to be read from file if not coupled 418 jpfld=0 419 jp_usd=0 ; jp_vsd=0 ; jp_hsw=0 ; jp_wmp=0 ; jp_wfr=0 420 IF( .NOT. cpl_sdrftx ) THEN 421 jpfld = jpfld + 1 422 jp_usd = jpfld 423 ENDIF 424 IF( .NOT. cpl_sdrfty ) THEN 425 jpfld = jpfld + 1 426 jp_vsd = jpfld 427 ENDIF 428 IF( .NOT. cpl_hsig .AND. ll_st_bv_li ) THEN 429 jpfld = jpfld + 1 430 jp_hsw = jpfld 431 ENDIF 432 IF( .NOT. cpl_wper .AND. ll_st_bv_li ) THEN 433 jpfld = jpfld + 1 434 jp_wmp = jpfld 435 ENDIF 436 IF( .NOT. cpl_wfreq .AND. ll_st_peakfr ) THEN 437 jpfld = jpfld + 1 438 jp_wfr = jpfld 439 ENDIF 440 441 ! Read from file only the non-coupled fields 442 IF( jpfld > 0 ) THEN 443 ALLOCATE( slf_i(jpfld) ) 444 IF( jp_usd > 0 ) slf_i(jp_usd) = sn_usd 445 IF( jp_vsd > 0 ) slf_i(jp_vsd) = sn_vsd 446 IF( jp_hsw > 0 ) slf_i(jp_hsw) = sn_hsw 447 IF( jp_wmp > 0 ) slf_i(jp_wmp) = sn_wmp 448 IF( jp_wfr > 0 ) slf_i(jp_wfr) = sn_wfr 449 450 ALLOCATE( sf_sd(jpfld), STAT=ierror ) !* allocate and fill sf_sd with stokes drift 451 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) 452 ! 453 DO ifpr= 1, jpfld 454 ALLOCATE( sf_sd(ifpr)%fnow(jpi,jpj,1) ) 455 IF( slf_i(ifpr)%ln_tint ) ALLOCATE( sf_sd(ifpr)%fdta(jpi,jpj,1,2) ) 456 END DO 457 ! 458 CALL fld_fill( sf_sd, slf_i, cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) 459 ENDIF 460 ALLOCATE( usd (jpi,jpj,jpk), vsd (jpi,jpj,jpk), wsd(jpi,jpj,jpk) ) 461 ALLOCATE( hsw (jpi,jpj) , wmp (jpi,jpj) ) 462 ALLOCATE( wfreq(jpi,jpj) ) 463 ALLOCATE( ut0sd(jpi,jpj) , vt0sd(jpi,jpj) ) 464 ALLOCATE( div_sd(jpi,jpj) ) 465 ALLOCATE( tsd2d (jpi,jpj) ) 466 467 ut0sd(:,:) = 0._wp 468 vt0sd(:,:) = 0._wp 469 hsw(:,:) = 0._wp 470 wmp(:,:) = 0._wp 471 472 usd(:,:,:) = 0._wp 473 vsd(:,:,:) = 0._wp 474 wsd(:,:,:) = 0._wp 475 ! Wave number needed only if ln_zdfswm=T 476 IF( .NOT. cpl_wnum ) THEN 477 ALLOCATE( sf_wn(1), STAT=ierror ) !* allocate and fill sf_wave with sn_wnum 478 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable toallocate sf_wave structure' ) 479 ALLOCATE( sf_wn(1)%fnow(jpi,jpj,1) ) 480 IF( sn_wnum%ln_tint ) ALLOCATE( sf_wn(1)%fdta(jpi,jpj,1,2) ) 481 CALL fld_fill( sf_wn, (/ sn_wnum /), cn_dir, 'sbc_wave', 'Wave module', 'namsbc_wave' ) 482 ENDIF 483 ALLOCATE( wnum(jpi,jpj) ) 516 ENDIF 517 ! 484 518 ENDIF 485 519 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/eosbn2.F90
r13497 r14046 39 39 !!---------------------------------------------------------------------- 40 40 USE dom_oce ! ocean space and time domain 41 USE domutl, ONLY : is_tile 41 42 USE phycst ! physical constants 42 43 USE stopar ! Stochastic T/S fluctuations … … 55 56 ! !! * Interface 56 57 INTERFACE eos 57 MODULE PROCEDURE eos_insitu, eos_insitu_pot, eos_insitu_2d 58 MODULE PROCEDURE eos_insitu, eos_insitu_pot, eos_insitu_2d, eos_insitu_pot_2d 58 59 END INTERFACE 59 60 ! … … 189 190 190 191 SUBROUTINE eos_insitu( pts, prd, pdep ) 192 !! 193 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 194 ! ! 2 : salinity [psu] 195 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] 196 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] 197 !! 198 CALL eos_insitu_t( pts, is_tile(pts), prd, is_tile(prd), pdep, is_tile(pdep) ) 199 END SUBROUTINE eos_insitu 200 201 SUBROUTINE eos_insitu_t( pts, ktts, prd, ktrd, pdep, ktdep ) 191 202 !!---------------------------------------------------------------------- 192 203 !! *** ROUTINE eos_insitu *** … … 222 233 !! TEOS-10 Manual, 2010 223 234 !!---------------------------------------------------------------------- 224 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 225 ! ! 2 : salinity [psu] 226 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prd ! in situ density [-] 227 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pdep ! depth [m] 235 INTEGER , INTENT(in ) :: ktts, ktrd, ktdep 236 REAL(wp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 237 ! ! 2 : salinity [psu] 238 REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-] 239 REAL(wp), DIMENSION(A2D_T(ktdep),JPK ), INTENT(in ) :: pdep ! depth [m] 228 240 ! 229 241 INTEGER :: ji, jj, jk ! dummy loop indices … … 238 250 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 239 251 ! 240 DO_3D( 1, 1, 1, 1, 1, jpkm1 )252 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 241 253 ! 242 254 zh = pdep(ji,jj,jk) * r1_Z0 ! depth … … 274 286 CASE( np_seos ) !== simplified EOS ==! 275 287 ! 276 DO_3D( 1, 1, 1, 1, 1, jpkm1 )288 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 277 289 zt = pts (ji,jj,jk,jp_tem) - 10._wp 278 290 zs = pts (ji,jj,jk,jp_sal) - 35._wp … … 293 305 IF( ln_timing ) CALL timing_stop('eos-insitu') 294 306 ! 295 END SUBROUTINE eos_insitu 307 END SUBROUTINE eos_insitu_t 296 308 297 309 298 310 SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) 311 !! 312 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 313 ! ! 2 : salinity [psu] 314 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] 315 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prhop ! potential density (surface referenced) 316 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] 317 !! 318 CALL eos_insitu_pot_t( pts, is_tile(pts), prd, is_tile(prd), prhop, is_tile(prhop), pdep, is_tile(pdep) ) 319 END SUBROUTINE eos_insitu_pot 320 321 322 SUBROUTINE eos_insitu_pot_t( pts, ktts, prd, ktrd, prhop, ktrhop, pdep, ktdep ) 299 323 !!---------------------------------------------------------------------- 300 324 !! *** ROUTINE eos_insitu_pot *** … … 309 333 !! 310 334 !!---------------------------------------------------------------------- 311 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 312 ! ! 2 : salinity [psu] 313 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prd ! in situ density [-] 314 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prhop ! potential density (surface referenced) 315 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pdep ! depth [m] 335 INTEGER , INTENT(in ) :: ktts, ktrd, ktrhop, ktdep 336 REAL(wp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 337 ! ! 2 : salinity [psu] 338 REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK ), INTENT( out) :: prd ! in situ density [-] 339 REAL(wp), DIMENSION(A2D_T(ktrhop),JPK ), INTENT( out) :: prhop ! potential density (surface referenced) 340 REAL(wp), DIMENSION(A2D_T(ktdep) ,JPK ), INTENT(in ) :: pdep ! depth [m] 316 341 ! 317 342 INTEGER :: ji, jj, jk, jsmp ! dummy loop indices … … 338 363 END DO 339 364 ! 340 DO_3D( 1, 1, 1, 1, 1, jpkm1 )365 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 341 366 ! 342 367 ! compute density (2*nn_sto_eos) times: … … 388 413 ! Non-stochastic equation of state 389 414 ELSE 390 DO_3D( 1, 1, 1, 1, 1, jpkm1 )415 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 391 416 ! 392 417 zh = pdep(ji,jj,jk) * r1_Z0 ! depth … … 426 451 CASE( np_seos ) !== simplified EOS ==! 427 452 ! 428 DO_3D( 1, 1, 1, 1, 1, jpkm1 )453 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 429 454 zt = pts (ji,jj,jk,jp_tem) - 10._wp 430 455 zs = pts (ji,jj,jk,jp_sal) - 35._wp … … 444 469 END SELECT 445 470 ! 446 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', kdim=jpk ) 471 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', & 472 & tab3d_2=prhop, clinfo2=' pot : ', kdim=jpk ) 447 473 ! 448 474 IF( ln_timing ) CALL timing_stop('eos-pot') 449 475 ! 450 END SUBROUTINE eos_insitu_pot 476 END SUBROUTINE eos_insitu_pot_t 451 477 452 478 453 479 SUBROUTINE eos_insitu_2d( pts, pdep, prd ) 480 !! 481 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 482 ! ! 2 : salinity [psu] 483 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] 484 REAL(wp), DIMENSION(:,:) , INTENT( out) :: prd ! in situ density 485 !! 486 CALL eos_insitu_2d_t( pts, is_tile(pts), pdep, is_tile(pdep), prd, is_tile(prd) ) 487 END SUBROUTINE eos_insitu_2d 488 489 490 SUBROUTINE eos_insitu_2d_t( pts, ktts, pdep, ktdep, prd, ktrd ) 454 491 !!---------------------------------------------------------------------- 455 492 !! *** ROUTINE eos_insitu_2d *** … … 462 499 !! 463 500 !!---------------------------------------------------------------------- 464 REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 465 ! ! 2 : salinity [psu] 466 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m] 467 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: prd ! in situ density 501 INTEGER , INTENT(in ) :: ktts, ktdep, ktrd 502 REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 503 ! ! 2 : salinity [psu] 504 REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m] 505 REAL(wp), DIMENSION(A2D_T(ktrd) ), INTENT( out) :: prd ! in situ density 468 506 ! 469 507 INTEGER :: ji, jj, jk ! dummy loop indices … … 480 518 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 481 519 ! 482 DO_2D( 1, 1, 1, 1)520 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 483 521 ! 484 522 zh = pdep(ji,jj) * r1_Z0 ! depth … … 515 553 CASE( np_seos ) !== simplified EOS ==! 516 554 ! 517 DO_2D( 1, 1, 1, 1)555 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 518 556 ! 519 557 zt = pts (ji,jj,jp_tem) - 10._wp … … 535 573 IF( ln_timing ) CALL timing_stop('eos2d') 536 574 ! 537 END SUBROUTINE eos_insitu_2d 575 END SUBROUTINE eos_insitu_2d_t 576 577 578 SUBROUTINE eos_insitu_pot_2d( pts, prhop ) 579 !!---------------------------------------------------------------------- 580 !! *** ROUTINE eos_insitu_pot *** 581 !! 582 !! ** Purpose : Compute the in situ density (ratio rho/rho0) and the 583 !! potential volumic mass (Kg/m3) from potential temperature and 584 !! salinity fields using an equation of state selected in the 585 !! namelist. 586 !! 587 !! ** Action : 588 !! - prhop, the potential volumic mass (Kg/m3) 589 !! 590 !!---------------------------------------------------------------------- 591 REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] 592 ! ! 2 : salinity [psu] 593 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out) :: prhop ! potential density (surface referenced) 594 ! 595 INTEGER :: ji, jj, jk, jsmp ! dummy loop indices 596 INTEGER :: jdof 597 REAL(wp) :: zt , zh , zstemp, zs , ztm ! local scalars 598 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 599 REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign ! local vectors 600 !!---------------------------------------------------------------------- 601 ! 602 IF( ln_timing ) CALL timing_start('eos-pot') 603 ! 604 SELECT CASE ( neos ) 605 ! 606 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 607 ! 608 DO_2D( 1, 1, 1, 1 ) 609 ! 610 zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature 611 zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 612 ztm = tmask(ji,jj,1) ! tmask 613 ! 614 zn0 = (((((EOS060*zt & 615 & + EOS150*zs+EOS050)*zt & 616 & + (EOS240*zs+EOS140)*zs+EOS040)*zt & 617 & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & 618 & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & 619 & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & 620 & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 621 ! 622 ! 623 prhop(ji,jj) = zn0 * ztm ! potential density referenced at the surface 624 ! 625 END_2D 626 627 CASE( np_seos ) !== simplified EOS ==! 628 ! 629 DO_2D( 1, 1, 1, 1 ) 630 zt = pts (ji,jj,jp_tem) - 10._wp 631 zs = pts (ji,jj,jp_sal) - 35._wp 632 ztm = tmask(ji,jj,1) 633 ! ! potential density referenced at the surface 634 zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt & 635 & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs & 636 & - rn_nu * zt * zs 637 prhop(ji,jj) = ( rho0 + zn ) * ztm 638 ! 639 END_2D 640 ! 641 END SELECT 642 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prhop, clinfo1=' pot: ', kdim=1 ) 643 ! 644 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=prhop, clinfo1=' eos-pot: ' ) 645 ! 646 IF( ln_timing ) CALL timing_stop('eos-pot') 647 ! 648 END SUBROUTINE eos_insitu_pot_2d 538 649 539 650 540 651 SUBROUTINE rab_3d( pts, pab, Kmm ) 652 !! 653 INTEGER , INTENT(in ) :: Kmm ! time level index 654 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity 655 REAL(wp), DIMENSION(:,:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio 656 !! 657 CALL rab_3d_t( pts, is_tile(pts), pab, is_tile(pab), Kmm ) 658 END SUBROUTINE rab_3d 659 660 661 SUBROUTINE rab_3d_t( pts, ktts, pab, ktab, Kmm ) 541 662 !!---------------------------------------------------------------------- 542 663 !! *** ROUTINE rab_3d *** … … 548 669 !! ** Action : - pab : thermal/haline expansion ratio at T-points 549 670 !!---------------------------------------------------------------------- 550 INTEGER , INTENT(in ) :: Kmm ! time level index 551 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity 552 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT( out) :: pab ! thermal/haline expansion ratio 671 INTEGER , INTENT(in ) :: Kmm ! time level index 672 INTEGER , INTENT(in ) :: ktts, ktab 673 REAL(wp), DIMENSION(A2D_T(ktts),JPK,JPTS), INTENT(in ) :: pts ! pot. temperature & salinity 674 REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio 553 675 ! 554 676 INTEGER :: ji, jj, jk ! dummy loop indices … … 563 685 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 564 686 ! 565 DO_3D( 1, 1, 1, 1, 1, jpkm1 )687 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 566 688 ! 567 689 zh = gdept(ji,jj,jk,Kmm) * r1_Z0 ! depth … … 616 738 CASE( np_seos ) !== simplified EOS ==! 617 739 ! 618 DO_3D( 1, 1, 1, 1, 1, jpkm1 )740 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 619 741 zt = pts (ji,jj,jk,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) 620 742 zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) … … 641 763 IF( ln_timing ) CALL timing_stop('rab_3d') 642 764 ! 643 END SUBROUTINE rab_3d 765 END SUBROUTINE rab_3d_t 644 766 645 767 646 768 SUBROUTINE rab_2d( pts, pdep, pab, Kmm ) 769 !! 770 INTEGER , INTENT(in ) :: Kmm ! time level index 771 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pts ! pot. temperature & salinity 772 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pdep ! depth [m] 773 REAL(wp), DIMENSION(:,:,:), INTENT( out) :: pab ! thermal/haline expansion ratio 774 !! 775 CALL rab_2d_t(pts, is_tile(pts), pdep, is_tile(pdep), pab, is_tile(pab), Kmm) 776 END SUBROUTINE rab_2d 777 778 779 SUBROUTINE rab_2d_t( pts, ktts, pdep, ktdep, pab, ktab, Kmm ) 647 780 !!---------------------------------------------------------------------- 648 781 !! *** ROUTINE rab_2d *** … … 652 785 !! ** Action : - pab : thermal/haline expansion ratio at T-points 653 786 !!---------------------------------------------------------------------- 654 INTEGER , INTENT(in ) :: Kmm ! time level index 655 REAL(wp), DIMENSION(jpi,jpj,jpts) , INTENT(in ) :: pts ! pot. temperature & salinity 656 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m] 657 REAL(wp), DIMENSION(jpi,jpj,jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio 787 INTEGER , INTENT(in ) :: Kmm ! time level index 788 INTEGER , INTENT(in ) :: ktts, ktdep, ktab 789 REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in ) :: pts ! pot. temperature & salinity 790 REAL(wp), DIMENSION(A2D_T(ktdep) ), INTENT(in ) :: pdep ! depth [m] 791 REAL(wp), DIMENSION(A2D_T(ktab),JPTS), INTENT( out) :: pab ! thermal/haline expansion ratio 658 792 ! 659 793 INTEGER :: ji, jj, jk ! dummy loop indices … … 670 804 CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! 671 805 ! 672 DO_2D( 1, 1, 1, 1)806 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 673 807 ! 674 808 zh = pdep(ji,jj) * r1_Z0 ! depth … … 723 857 CASE( np_seos ) !== simplified EOS ==! 724 858 ! 725 DO_2D( 1, 1, 1, 1)859 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 726 860 ! 727 861 zt = pts (ji,jj,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) … … 748 882 IF( ln_timing ) CALL timing_stop('rab_2d') 749 883 ! 750 END SUBROUTINE rab_2d 884 END SUBROUTINE rab_2d_t 751 885 752 886 … … 849 983 850 984 SUBROUTINE bn2( pts, pab, pn2, Kmm ) 985 !! 986 INTEGER , INTENT(in ) :: Kmm ! time level index 987 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] 988 REAL(wp), DIMENSION(:,:,:,:) , INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] 989 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] 990 !! 991 CALL bn2_t( pts, pab, is_tile(pab), pn2, is_tile(pn2), Kmm ) 992 END SUBROUTINE bn2 993 994 995 SUBROUTINE bn2_t( pts, pab, ktab, pn2, ktn2, Kmm ) 851 996 !!---------------------------------------------------------------------- 852 997 !! *** ROUTINE bn2 *** … … 862 1007 !! 863 1008 !!---------------------------------------------------------------------- 864 INTEGER , INTENT(in ) :: Kmm ! time level index 865 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] 866 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] 867 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] 1009 INTEGER , INTENT(in ) :: Kmm ! time level index 1010 INTEGER , INTENT(in ) :: ktab, ktn2 1011 REAL(wp), DIMENSION(jpi,jpj, jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] 1012 REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] 1013 REAL(wp), DIMENSION(A2D_T(ktn2),JPK ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] 868 1014 ! 869 1015 INTEGER :: ji, jj, jk ! dummy loop indices … … 873 1019 IF( ln_timing ) CALL timing_start('bn2') 874 1020 ! 875 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F901021 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpkm1 ) ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F90 876 1022 zrw = ( gdepw(ji,jj,jk ,Kmm) - gdept(ji,jj,jk,Kmm) ) & 877 1023 & / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) ) … … 889 1035 IF( ln_timing ) CALL timing_stop('bn2') 890 1036 ! 891 END SUBROUTINE bn2 1037 END SUBROUTINE bn2_t 892 1038 893 1039 … … 949 1095 950 1096 951 SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) 1097 SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) 1098 !! 1099 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] 1100 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] 1101 REAL(wp), DIMENSION(:,:) , INTENT(out ) :: ptf ! freezing temperature [Celsius] 1102 !! 1103 CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep ) 1104 END SUBROUTINE eos_fzp_2d 1105 1106 1107 SUBROUTINE eos_fzp_2d_t( psal, ptf, kttf, pdep ) 952 1108 !!---------------------------------------------------------------------- 953 1109 !! *** ROUTINE eos_fzp *** … … 961 1117 !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 962 1118 !!---------------------------------------------------------------------- 963 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] 964 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] 965 REAL(wp), DIMENSION(jpi,jpj), INTENT(out ) :: ptf ! freezing temperature [Celsius] 1119 INTEGER , INTENT(in ) :: kttf 1120 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: psal ! salinity [psu] 1121 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ), OPTIONAL :: pdep ! depth [m] 1122 REAL(wp), DIMENSION(A2D_T(kttf)), INTENT(out ) :: ptf ! freezing temperature [Celsius] 966 1123 ! 967 1124 INTEGER :: ji, jj ! dummy loop indices … … 996 1153 END SELECT 997 1154 ! 998 END SUBROUTINE eos_fzp_2d 1155 END SUBROUTINE eos_fzp_2d_t 999 1156 1000 1157 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traadv.F90
r13237 r14046 18 18 USE oce ! ocean dynamics and active tracers 19 19 USE dom_oce ! ocean space and time domain 20 ! TEMP: [tiling] This change not necessary after extended haloes development 21 USE domain, ONLY : dom_tile 20 22 USE domvvl ! variable vertical scale factors 21 23 USE sbcwave ! wave module … … 23 25 USE traadv_cen ! centered scheme (tra_adv_cen routine) 24 26 USE traadv_fct ! FCT scheme (tra_adv_fct routine) 27 USE traadv_fct_lf ! FCT scheme (tra_adv_fct routine - loop fusion version) 25 28 USE traadv_mus ! MUSCL scheme (tra_adv_mus routine) 29 USE traadv_mus_lf ! MUSCL scheme (tra_adv_mus routine - loop fusion version) 26 30 USE traadv_ubs ! UBS scheme (tra_adv_ubs routine) 27 31 USE traadv_qck ! QUICKEST scheme (tra_adv_qck routine) … … 65 69 INTEGER, PARAMETER :: np_UBS = 4 ! 3rd order Upstream Biased Scheme 66 70 INTEGER, PARAMETER :: np_QCK = 5 ! QUICK scheme 67 71 72 !! * Substitutions 73 # include "do_loop_substitute.h90" 68 74 # include "domzgr_substitute.h90" 69 75 !!---------------------------------------------------------------------- … … 86 92 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 87 93 ! 88 INTEGER :: jk ! dummy loop index 89 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zuu, zvv, zww ! 3D workspace 90 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 94 INTEGER :: ji, jj, jk ! dummy loop index 95 ! TEMP: [tiling] This change not necessary and can be A2D(nn_hls) if using XIOS (subdomain support) 96 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zuu, zvv, zww ! 3D workspace 97 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 98 ! TEMP: [tiling] This change not necessary after extra haloes development 99 LOGICAL :: lskip 91 100 !!---------------------------------------------------------------------- 92 101 ! 93 102 IF( ln_timing ) CALL timing_start('tra_adv') 94 103 ! 95 ! !== effective transport ==! 96 zuu(:,:,jpk) = 0._wp 97 zvv(:,:,jpk) = 0._wp 98 zww(:,:,jpk) = 0._wp 99 IF( ln_wave .AND. ln_sdw ) THEN 100 DO jk = 1, jpkm1 ! eulerian transport + Stokes Drift 101 zuu(:,:,jk) = & 102 & e2u (:,:) * e3u(:,:,jk,Kmm) * ( uu(:,:,jk,Kmm) + usd(:,:,jk) ) 103 zvv(:,:,jk) = & 104 & e1v (:,:) * e3v(:,:,jk,Kmm) * ( vv(:,:,jk,Kmm) + vsd(:,:,jk) ) 105 zww(:,:,jk) = & 106 & e1e2t(:,:) * ( ww(:,:,jk) + wsd(:,:,jk) ) 107 END DO 108 ELSE 109 DO jk = 1, jpkm1 110 zuu(:,:,jk) = e2u (:,:) * e3u(:,:,jk,Kmm) * uu(:,:,jk,Kmm) ! eulerian transport only 111 zvv(:,:,jk) = e1v (:,:) * e3v(:,:,jk,Kmm) * vv(:,:,jk,Kmm) 112 zww(:,:,jk) = e1e2t(:,:) * ww(:,:,jk) 113 END DO 114 ENDIF 115 ! 116 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections 117 zuu(:,:,:) = zuu(:,:,:) + un_td(:,:,:) 118 zvv(:,:,:) = zvv(:,:,:) + vn_td(:,:,:) 119 ENDIF 120 ! 121 zuu(:,:,jpk) = 0._wp ! no transport trough the bottom 122 zvv(:,:,jpk) = 0._wp 123 zww(:,:,jpk) = 0._wp 124 ! 125 IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad ) & 126 & CALL ldf_eiv_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm, Krhs ) ! add the eiv transport (if necessary) 127 ! 128 IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm ) ! add the mle transport (if necessary) 129 ! 130 CALL iom_put( "uocetr_eff", zuu ) ! output effective transport 131 CALL iom_put( "vocetr_eff", zvv ) 132 CALL iom_put( "wocetr_eff", zww ) 133 ! 134 !!gm ??? 135 CALL dia_ptr( kt, Kmm, zvv ) ! diagnose the effective MSF 136 !!gm ??? 137 ! 138 139 IF( l_trdtra ) THEN !* Save ta and sa trends 140 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 141 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 142 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 143 ENDIF 144 ! 145 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 146 ! 147 CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order 148 CALL tra_adv_cen ( kt, nit000, 'TRA', zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v ) 149 CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order 150 CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 151 CASE ( np_MUS ) ! MUSCL 152 CALL tra_adv_mus ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 153 CASE ( np_UBS ) ! UBS 154 CALL tra_adv_ubs ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v ) 155 CASE ( np_QCK ) ! QUICKEST 156 CALL tra_adv_qck ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs ) 157 ! 158 END SELECT 159 ! 160 IF( l_trdtra ) THEN ! save the advective trends for further diagnostics 161 DO jk = 1, jpkm1 162 ztrdt(:,:,jk) = pts(:,:,jk,jp_tem,Krhs) - ztrdt(:,:,jk) 163 ztrds(:,:,jk) = pts(:,:,jk,jp_sal,Krhs) - ztrds(:,:,jk) 164 END DO 165 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_totad, ztrdt ) 166 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_totad, ztrds ) 167 DEALLOCATE( ztrdt, ztrds ) 104 lskip = .FALSE. 105 106 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 107 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 108 ALLOCATE( zuu(jpi,jpj,jpk), zvv(jpi,jpj,jpk), zww(jpi,jpj,jpk) ) 109 ENDIF 110 111 ! TEMP: [tiling] These changes not necessary after extra haloes development (lbc_lnk removed from tra_adv_*) and if XIOS has subdomain support (ldf_eiv_dia) 112 IF( nadv /= np_CEN .OR. (nadv == np_CEN .AND. nn_cen_h == 4) .OR. ln_ldfeiv_dia ) THEN 113 IF( ln_tile ) THEN 114 IF( ntile == 1 ) THEN 115 CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 116 ELSE 117 lskip = .TRUE. 118 ENDIF 119 ENDIF 120 ENDIF 121 IF( .NOT. lskip ) THEN 122 ! !== effective transport ==! 123 IF( ln_wave .AND. ln_sdw ) THEN 124 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 125 zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * ( uu(ji,jj,jk,Kmm) + usd(ji,jj,jk) ) 126 zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * ( vv(ji,jj,jk,Kmm) + vsd(ji,jj,jk) ) 127 zww(ji,jj,jk) = e1e2t(ji,jj) * ( ww(ji,jj,jk) + wsd(ji,jj,jk) ) 128 END_3D 129 ELSE 130 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 131 zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) ! eulerian transport only 132 zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) 133 zww(ji,jj,jk) = e1e2t(ji,jj) * ww(ji,jj,jk) 134 END_3D 135 ENDIF 136 ! 137 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections 138 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 139 zuu(ji,jj,jk) = zuu(ji,jj,jk) + un_td(ji,jj,jk) 140 zvv(ji,jj,jk) = zvv(ji,jj,jk) + vn_td(ji,jj,jk) 141 END_3D 142 ENDIF 143 ! 144 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 145 zuu(ji,jj,jpk) = 0._wp ! no transport trough the bottom 146 zvv(ji,jj,jpk) = 0._wp 147 zww(ji,jj,jpk) = 0._wp 148 END_2D 149 ! 150 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 151 IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad ) & 152 & CALL ldf_eiv_trp( kt, nit000, zuu(A2D(nn_hls),:), zvv(A2D(nn_hls),:), zww(A2D(nn_hls),:), & 153 & 'TRA', Kmm, Krhs ) ! add the eiv transport (if necessary) 154 ! 155 IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu(A2D(nn_hls),:), zvv(A2D(nn_hls),:), zww(A2D(nn_hls),:), & 156 & 'TRA', Kmm ) ! add the mle transport (if necessary) 157 ! 158 ! TEMP: [tiling] This change not necessary if using XIOS (subdomain support) 159 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 160 CALL iom_put( "uocetr_eff", zuu ) ! output effective transport 161 CALL iom_put( "vocetr_eff", zvv ) 162 CALL iom_put( "wocetr_eff", zww ) 163 ENDIF 164 ! 165 !!gm ??? 166 ! TEMP: [tiling] This change not necessary if using XIOS (subdomain support) 167 CALL dia_ptr( kt, Kmm, zvv(A2D(nn_hls),:) ) ! diagnose the effective MSF 168 !!gm ??? 169 ! 170 171 IF( l_trdtra ) THEN !* Save ta and sa trends 172 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 173 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 174 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 175 ENDIF 176 ! 177 ! NOTE: [tiling-comms-merge] These lbc_lnk calls are still needed (pts in the zco case because zps_hde is not called in step, zuu/zvv/zww in all cases, I think because DO loop bounds need to be updated in DYN as done in TRA) 178 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 179 ! 180 CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order 181 IF (nn_hls.EQ.2) CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kmm), 'T', 1. ) 182 CALL tra_adv_cen ( kt, nit000, 'TRA', zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v ) 183 CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order 184 IF (nn_hls.EQ.2) THEN 185 CALL lbc_lnk_multi( 'traadv', pts(:,:,:,:,Kbb), 'T', 1., pts(:,:,:,:,Kmm), 'T', 1.) 186 CALL lbc_lnk_multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1., zww(:,:,:), 'W', 1.) 187 #if defined key_loop_fusion 188 CALL tra_adv_fct_lf ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 189 #else 190 CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 191 #endif 192 ELSE 193 CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 194 END IF 195 CASE ( np_MUS ) ! MUSCL 196 ! NOTE: [tiling-comms-merge] I added this lbc_lnk as it did not validate against the trunk when using ln_zco 197 IF (nn_hls.EQ.2) THEN 198 CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 199 #if defined key_loop_fusion 200 CALL tra_adv_mus_lf ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 201 #else 202 CALL tra_adv_mus ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 203 #endif 204 ELSE 205 CALL tra_adv_mus ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups ) 206 END IF 207 CASE ( np_UBS ) ! UBS 208 IF (nn_hls.EQ.2) CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 209 CALL tra_adv_ubs ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v ) 210 CASE ( np_QCK ) ! QUICKEST 211 IF (nn_hls.EQ.2) THEN 212 CALL lbc_lnk_multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1.) 213 CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 214 END IF 215 CALL tra_adv_qck ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs ) 216 ! 217 END SELECT 218 ! 219 IF( l_trdtra ) THEN ! save the advective trends for further diagnostics 220 DO jk = 1, jpkm1 221 ztrdt(:,:,jk) = pts(:,:,jk,jp_tem,Krhs) - ztrdt(:,:,jk) 222 ztrds(:,:,jk) = pts(:,:,jk,jp_sal,Krhs) - ztrds(:,:,jk) 223 END DO 224 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_totad, ztrdt ) 225 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_totad, ztrds ) 226 DEALLOCATE( ztrdt, ztrds ) 227 ENDIF 228 229 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from tra_adv_*) and if XIOS has subdomain support (ldf_eiv_dia) 230 IF( ln_tile .AND. ntile == 0 ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 1 ) 231 168 232 ENDIF 169 233 ! ! print mean trends (used for debugging) 170 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv - Ta: ', mask1=tmask, 234 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv - Ta: ', mask1=tmask, & 171 235 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 236 237 ! TEMP: [tiling] This change not necessary if using XIOS (subdomain support) 238 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 239 DEALLOCATE( zuu, zvv, zww ) 240 ENDIF 172 241 ! 173 242 IF( ln_timing ) CALL timing_stop( 'tra_adv' ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traadv_cen.F90
r13497 r14046 71 71 INTEGER , INTENT(in ) :: kn_cen_h ! =2/4 (2nd or 4th order scheme) 72 72 INTEGER , INTENT(in ) :: kn_cen_v ! =2/4 (2nd or 4th order scheme) 73 ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 73 74 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components 74 75 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation … … 78 79 REAL(wp) :: zC2t_u, zC4t_u ! local scalars 79 80 REAL(wp) :: zC2t_v, zC4t_v ! - - 80 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwx, zwy, zwz, ztu, ztv, ztw81 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zwy, zwz, ztu, ztv, ztw 81 82 !!---------------------------------------------------------------------- 82 83 ! 83 IF( kt == kit000 ) THEN 84 IF(lwp) WRITE(numout,*) 85 IF(lwp) WRITE(numout,*) 'tra_adv_cen : centered advection scheme on ', cdtype, ' order h/v =', kn_cen_h,'/', kn_cen_v 86 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ ' 84 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 85 IF( kt == kit000 ) THEN 86 IF(lwp) WRITE(numout,*) 87 IF(lwp) WRITE(numout,*) 'tra_adv_cen : centered advection scheme on ', cdtype, ' order h/v =', kn_cen_h,'/', kn_cen_v 88 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ ' 89 ENDIF 90 ! ! set local switches 91 l_trd = .FALSE. 92 l_hst = .FALSE. 93 l_ptr = .FALSE. 94 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 95 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 96 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 97 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 87 98 ENDIF 88 ! ! set local switches89 l_trd = .FALSE.90 l_hst = .FALSE.91 l_ptr = .FALSE.92 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.93 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE.94 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &95 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE.96 99 ! 97 100 ! … … 112 115 ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero 113 116 ztv(:,:,jpk) = 0._wp 114 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! masked gradient117 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) ! masked gradient 115 118 ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 116 119 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 117 120 END_3D 118 CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond.121 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. 119 122 ! 120 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes123 DO_3D( nn_hls-1, 0, nn_hls-1, 0, 1, jpkm1 ) ! Horizontal advective fluxes 121 124 zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! C2 interpolation of T at u- & v-points (x2) 122 125 zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) … … 128 131 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v 129 132 END_3D 130 CALL lbc_lnk_multi( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. )133 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. ) 131 134 ! 132 135 CASE DEFAULT … … 155 158 END_2D 156 159 ELSE ! no ice-shelf cavities (only ocean surface) 157 zwz(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kmm) 160 DO_2D( 1, 1, 1, 1 ) 161 zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) 162 END_2D 158 163 ENDIF 159 164 ENDIF … … 171 176 CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kmm) ) 172 177 CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) ) 173 END 174 ! ! "Poleward" heat and salt transports 178 ENDIF 179 ! ! "Poleward" heat and salt transports 175 180 IF( l_ptr ) CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) 176 181 ! ! heat and salt transport -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traadv_fct.F90
r13497 r14046 34 34 PUBLIC tra_adv_fct ! called by traadv.F90 35 35 PUBLIC interp_4th_cpt ! called by traadv_cen.F90 36 PUBLIC tridia_solver ! called by traadv_fct_lf.F90 37 PUBLIC nonosc ! called by traadv_fct_lf.F90 - key_agrif 36 38 37 39 LOGICAL :: l_trd ! flag to compute trends … … 79 81 INTEGER , INTENT(in ) :: kn_fct_v ! order of the FCT scheme (=2 or 4) 80 82 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 83 ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 84 ! NOTE: [tiling-comms-merge] These were changed to INTENT(inout) but they are not modified, so it is reverted 81 85 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components 82 86 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation 83 87 ! 84 INTEGER :: ji, jj, jk, jn ! dummy loop indices 88 INTEGER :: ji, jj, jk, jn ! dummy loop indices 85 89 REAL(wp) :: ztra ! local scalar 86 90 REAL(wp) :: zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u ! - - 87 91 REAL(wp) :: zfm_ui, zfm_vj, zfm_wk, zC2t_v, zC4t_v ! - - 88 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw92 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw 89 93 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz, zptry 90 94 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zwinf, zwdia, zwsup … … 92 96 !!---------------------------------------------------------------------- 93 97 ! 94 IF( kt == kit000 ) THEN 95 IF(lwp) WRITE(numout,*) 96 IF(lwp) WRITE(numout,*) 'tra_adv_fct : FCT advection scheme on ', cdtype 97 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 98 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 99 IF( kt == kit000 ) THEN 100 IF(lwp) WRITE(numout,*) 101 IF(lwp) WRITE(numout,*) 'tra_adv_fct : FCT advection scheme on ', cdtype 102 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 103 ENDIF 104 ! NOTE: [tiling-comms-merge] Bug fix- move array zeroing out of this IF block 105 ! 106 l_trd = .FALSE. ! set local switches 107 l_hst = .FALSE. 108 l_ptr = .FALSE. 109 ll_zAimp = .FALSE. 110 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 111 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 112 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 113 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 114 ! 98 115 ENDIF 116 99 117 !! -- init to 0 100 118 zwi(:,:,:) = 0._wp … … 108 126 ztw(:,:,:) = 0._wp 109 127 ! 110 l_trd = .FALSE. ! set local switches111 l_hst = .FALSE.112 l_ptr = .FALSE.113 ll_zAimp = .FALSE.114 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.115 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE.116 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &117 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE.118 !119 128 IF( l_trd .OR. l_hst ) THEN 120 ALLOCATE( ztrdx( jpi,jpj,jpk), ztrdy(jpi,jpj,jpk), ztrdz(jpi,jpj,jpk) )129 ALLOCATE( ztrdx(A2D(nn_hls),jpk), ztrdy(A2D(nn_hls),jpk), ztrdz(A2D(nn_hls),jpk) ) 121 130 ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp 122 131 ENDIF 123 132 ! 124 IF( l_ptr ) THEN 125 ALLOCATE( zptry( jpi,jpj,jpk) )133 IF( l_ptr ) THEN 134 ALLOCATE( zptry(A2D(nn_hls),jpk) ) 126 135 zptry(:,:,:) = 0._wp 127 136 ENDIF 128 ! ! surface & bottom value : flux set to zero one for all129 zwz(:,:, 1 ) = 0._wp130 zwx(:,:,jpk) = 0._wp ; zwy(:,:,jpk) = 0._wp ; zwz(:,:,jpk) = 0._wp131 !132 zwi(:,:,:) = 0._wp133 137 ! 134 138 ! If adaptive vertical advection, check if it is needed on this PE at this time 135 139 IF( ln_zad_Aimp ) THEN 136 IF( MAXVAL( ABS( wi( :,:,:) ) ) > 0._wp ) ll_zAimp = .TRUE.140 IF( MAXVAL( ABS( wi(A2D(nn_hls),:) ) ) > 0._wp ) ll_zAimp = .TRUE. 137 141 END IF 138 142 ! If active adaptive vertical advection, build tridiagonal matrix 139 143 IF( ll_zAimp ) THEN 140 ALLOCATE(zwdia( jpi,jpj,jpk), zwinf(jpi,jpj,jpk),zwsup(jpi,jpj,jpk))141 DO_3D( 0, 0, 0, 0, 1, jpkm1 )144 ALLOCATE(zwdia(A2D(nn_hls),jpk), zwinf(A2D(nn_hls),jpk), zwsup(A2D(nn_hls),jpk)) 145 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) 142 146 zwdia(ji,jj,jk) = 1._wp + p2dt * ( MAX( wi(ji,jj,jk) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) & 143 147 & / e3t(ji,jj,jk,Krhs) … … 151 155 ! !== upstream advection with initial mass fluxes & intermediate update ==! 152 156 ! !* upstream tracer flux in the i and j direction 153 DO_3D( 1, 0, 1, 0, 1, jpkm1 )157 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) 154 158 ! upstream scheme 155 159 zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) … … 178 182 ENDIF 179 183 ! 180 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme184 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) !* trend and after field with monotonic scheme 181 185 ! ! total intermediate advective trends 182 186 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & … … 194 198 ! 195 199 ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; 196 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask)200 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 197 201 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 198 202 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) … … 206 210 ! 207 211 END IF 208 ! 212 ! 209 213 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics (contribution of upstream fluxes) 210 214 ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:) … … 218 222 ! 219 223 CASE( 2 ) !- 2nd order centered 220 DO_3D( 1, 0, 1, 0, 1, jpkm1 )224 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) 221 225 zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj,jk,jn,Kmm) ) - zwx(ji,jj,jk) 222 226 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj+1,jk,jn,Kmm) ) - zwy(ji,jj,jk) … … 238 242 CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 239 243 ! 240 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! Horizontal advective fluxes244 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 241 245 zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj ,jk,jn,Kmm) ! 2 x C2 interpolation of T at u- & v-points 242 246 zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji ,jj+1,jk,jn,Kmm) 243 ! ! C4 minus upstream advective fluxes 247 ! ! C4 minus upstream advective fluxes 244 248 zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( zC2t_u + zltu(ji,jj,jk) - zltu(ji+1,jj,jk) ) - zwx(ji,jj,jk) 245 249 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( zC2t_v + zltv(ji,jj,jk) - zltv(ji,jj+1,jk) ) - zwy(ji,jj,jk) 246 250 END_3D 251 IF (nn_hls.EQ.2) CALL lbc_lnk_multi( 'traadv_fct', zwx, 'U', -1.0_wp, zwy, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 247 252 ! 248 253 CASE( 41 ) !- 4th order centered ==>> !!gm coding attempt need to be tested 249 254 ztu(:,:,jpk) = 0._wp ! Bottom value : flux set to zero 250 255 ztv(:,:,jpk) = 0._wp 251 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) ! 1st derivative (gradient)256 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) ! 1st derivative (gradient) 252 257 ztu(ji,jj,jk) = ( pt(ji+1,jj ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 253 258 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 254 259 END_3D 255 CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 260 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 261 ! 262 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 256 263 ! 257 264 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes … … 265 272 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) 266 273 END_3D 274 IF (nn_hls.EQ.2) CALL lbc_lnk_multi( 'traadv_fct', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 267 275 ! 268 276 END SELECT … … 271 279 ! 272 280 CASE( 2 ) !- 2nd order centered 273 DO_3D( 0, 0, 0, 0, 2, jpkm1 )281 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) 274 282 zwz(ji,jj,jk) = ( pW(ji,jj,jk) * 0.5_wp * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) & 275 283 & - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) … … 278 286 CASE( 4 ) !- 4th order COMPACT 279 287 CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw ) ! zwt = COMPACT interpolation of T at w-point 280 DO_3D( 0, 0, 0, 0, 2, jpkm1 )288 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) 281 289 zwz(ji,jj,jk) = ( pW(ji,jj,jk) * ztw(ji,jj,jk) - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) 282 290 END_3D … … 286 294 zwz(:,:,1) = 0._wp ! only ocean surface as interior zwz values have been w-masked 287 295 ENDIF 288 ! 296 ! 297 IF (nn_hls.EQ.1) THEN 298 CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'T', 1.0_wp ) 299 ELSE 300 CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp) 301 END IF 302 ! 303 IF (nn_hls.EQ.1) THEN 304 CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'T', 1.0_wp ) 305 ELSE 306 CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp) 307 END IF 308 ! 289 309 IF ( ll_zAimp ) THEN 290 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !* trend and after field with monotonic scheme310 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) !* trend and after field with monotonic scheme 291 311 ! ! total intermediate advective trends 292 312 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 293 313 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 294 314 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) * r1_e1e2t(ji,jj) 295 ztw(ji,jj,jk) 315 ztw(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 296 316 END_3D 297 317 ! 298 318 CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) 299 319 ! 300 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! Interior value ( multiplied by wmask)320 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) ! Interior value ( multiplied by wmask) 301 321 zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 302 322 zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 303 zwz(ji,jj,jk) = 323 zwz(ji,jj,jk) = zwz(ji,jj,jk) + 0.5 * e1e2t(ji,jj) * ( zfp_wk * ztw(ji,jj,jk) + zfm_wk * ztw(ji,jj,jk-1) ) * wmask(ji,jj,jk) 304 324 END_3D 305 325 END IF 306 !307 CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'W', 1.0_wp )308 326 ! 309 327 ! !== monotonicity algorithm ==! … … 334 352 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 335 353 END_3D 336 END IF 337 ! 354 END IF 355 ! NOTE: [tiling-comms-merge] I tested this 356 ! NOT TESTED - NEED l_trd OR l_hst TRUE 338 357 IF( l_trd .OR. l_hst ) THEN ! trend diagnostics // heat/salt transport 339 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< add anti-diffusive fluxes 358 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< add anti-diffusive fluxes 340 359 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! to upstream fluxes 341 360 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! … … 350 369 ! 351 370 ENDIF 371 ! NOTE: [tiling-comms-merge] I tested this 372 ! NOT TESTED - NEED l_ptr TRUE 352 373 IF( l_ptr ) THEN ! "Poleward" transports 353 374 zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:) ! <<< add anti-diffusive fluxes … … 360 381 DEALLOCATE( zwdia, zwinf, zwsup ) 361 382 ENDIF 362 IF( l_trd .OR. l_hst ) THEN 383 IF( l_trd .OR. l_hst ) THEN 363 384 DEALLOCATE( ztrdx, ztrdy, ztrdz ) 364 385 ENDIF … … 383 404 !! in-space based differencing for fluid 384 405 !!---------------------------------------------------------------------- 385 INTEGER , INTENT(in ) :: Kmm ! time level index 386 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 387 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pbef, paft ! before & after field 388 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(inout) :: paa, pbb, pcc ! monotonic fluxes in the 3 directions 406 INTEGER , INTENT(in ) :: Kmm ! time level index 407 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 408 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pbef ! before field 409 REAL(wp), DIMENSION(A2D(nn_hls) ,jpk), INTENT(in ) :: paft ! after field 410 REAL(wp), DIMENSION(A2D(nn_hls) ,jpk), INTENT(inout) :: paa, pbb, pcc ! monotonic fluxes in the 3 directions 389 411 ! 390 412 INTEGER :: ji, jj, jk ! dummy loop indices … … 392 414 REAL(dp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars 393 415 REAL(dp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - - 394 REAL(dp), DIMENSION( jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo416 REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo, zbup, zbdo 395 417 !!---------------------------------------------------------------------- 396 418 ! … … 402 424 ! -------------------- 403 425 ! max/min of pbef & paft with large negative/positive value (-/+zbig) inside land 404 zbup = MAX( pbef * tmask - zbig * ( 1._wp - tmask ), & 405 & paft * tmask - zbig * ( 1._wp - tmask ) ) 406 zbdo = MIN( pbef * tmask + zbig * ( 1._wp - tmask ), & 407 & paft * tmask + zbig * ( 1._wp - tmask ) ) 426 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 427 zbup(ji,jj,jk) = MAX( pbef(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1._wp - tmask(ji,jj,jk) ), & 428 & paft(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1._wp - tmask(ji,jj,jk) ) ) 429 zbdo(ji,jj,jk) = MIN( pbef(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1._wp - tmask(ji,jj,jk) ), & 430 & paft(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1._wp - tmask(ji,jj,jk) ) ) 431 END_3D 408 432 409 433 DO jk = 1, jpkm1 410 434 ikm1 = MAX(jk-1,1) 411 DO_2D( 0, 0, 0, 0)435 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 412 436 413 437 ! search maximum in neighbourhood … … 439 463 END_2D 440 464 END DO 441 CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1.0_wp , zbetdo, 'T', 1.0_wp ) ! lateral boundary cond. (unchanged sign)465 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1.0_wp , zbetdo, 'T', 1.0_wp ) ! lateral boundary cond. (unchanged sign) 442 466 443 467 ! 3. monotonic flux in the i & j direction (paa & pbb) 444 468 ! ---------------------------------------- 445 DO_3D( 0, 0, 0, 0, 1, jpkm1 )469 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 446 470 zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 447 471 zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) … … 461 485 pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) 462 486 END_3D 463 CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1.0_wp , pbb, 'V', -1.0_wp ) ! lateral boundary condition (changed sign)464 487 ! 465 488 END SUBROUTINE nonosc … … 537 560 !!---------------------------------------------------------------------- 538 561 REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pt_in ! field at t-point 539 REAL(wp),DIMENSION( jpi,jpj,jpk), INTENT( out) :: pt_out ! field interpolated at w-point562 REAL(wp),DIMENSION(A2D(nn_hls) ,jpk), INTENT( out) :: pt_out ! field interpolated at w-point 540 563 ! 541 564 INTEGER :: ji, jj, jk ! dummy loop integers 542 565 INTEGER :: ikt, ikb ! local integers 543 REAL(wp),DIMENSION( jpi,jpj,jpk) :: zwd, zwi, zws, zwrm, zwt566 REAL(wp),DIMENSION(A2D(nn_hls),jpk) :: zwd, zwi, zws, zwrm, zwt 544 567 !!---------------------------------------------------------------------- 545 568 ! 546 569 ! !== build the three diagonal matrix & the RHS ==! 547 570 ! 548 DO_3D( 0, 0, 0, 0, 3, jpkm1 ) ! interior (from jk=3 to jpk-1)571 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 3, jpkm1 ) ! interior (from jk=3 to jpk-1) 549 572 zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp ! diagonal 550 573 zwi (ji,jj,jk) = wmask(ji,jj,jk) ! lower diagonal … … 565 588 END IF 566 589 ! 567 DO_2D( 0, 0, 0, 0) ! 2nd order centered at top & bottom590 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! 2nd order centered at top & bottom 568 591 ikt = mikt(ji,jj) + 1 ! w-point below the 1st wet point 569 592 ikb = MAX(mbkt(ji,jj), 2) ! - above the last wet point … … 582 605 ! !== tridiagonal solver ==! 583 606 ! 584 DO_2D( 0, 0, 0, 0) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1607 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 585 608 zwt(ji,jj,2) = zwd(ji,jj,2) 586 609 END_2D 587 DO_3D( 0, 0, 0, 0, 3, jpkm1 )610 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 3, jpkm1 ) 588 611 zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 589 612 END_3D 590 613 ! 591 DO_2D( 0, 0, 0, 0) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1614 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 592 615 pt_out(ji,jj,2) = zwrm(ji,jj,2) 593 616 END_2D 594 DO_3D( 0, 0, 0, 0, 3, jpkm1 )617 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 3, jpkm1 ) 595 618 pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) 596 619 END_3D 597 620 598 DO_2D( 0, 0, 0, 0) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk621 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 599 622 pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 600 623 END_2D 601 DO_3DS( 0, 0, 0, 0, jpk-2, 2, -1 )624 DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpk-2, 2, -1 ) 602 625 pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 603 626 END_3D … … 626 649 !! The 3d array zwt is used as a work space array. 627 650 !!---------------------------------------------------------------------- 628 REAL(wp),DIMENSION( :,:,:), INTENT(in ) :: pD, pU, PL ! 3-diagonal matrix629 REAL(wp),DIMENSION( :,:,:), INTENT(in ) :: pRHS ! Right-Hand-Side630 REAL(wp),DIMENSION( :,:,:), INTENT( out) :: pt_out !!gm field at level=F(klev)631 INTEGER , INTENT(in ) :: klev ! =1 pt_out at w-level632 ! ! =0 pt at t-level651 REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pD, pU, PL ! 3-diagonal matrix 652 REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pRHS ! Right-Hand-Side 653 REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT( out) :: pt_out !!gm field at level=F(klev) 654 INTEGER , INTENT(in ) :: klev ! =1 pt_out at w-level 655 ! ! =0 pt at t-level 633 656 INTEGER :: ji, jj, jk ! dummy loop integers 634 657 INTEGER :: kstart ! local indices 635 REAL(wp),DIMENSION( jpi,jpj,jpk) :: zwt ! 3D work array658 REAL(wp),DIMENSION(A2D(nn_hls),jpk) :: zwt ! 3D work array 636 659 !!---------------------------------------------------------------------- 637 660 ! 638 661 kstart = 1 + klev 639 662 ! 640 DO_2D( 0, 0, 0, 0) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1663 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 641 664 zwt(ji,jj,kstart) = pD(ji,jj,kstart) 642 665 END_2D 643 DO_3D( 0, 0, 0, 0, kstart+1, jpkm1 )666 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, kstart+1, jpkm1 ) 644 667 zwt(ji,jj,jk) = pD(ji,jj,jk) - pL(ji,jj,jk) * pU(ji,jj,jk-1) /zwt(ji,jj,jk-1) 645 668 END_3D 646 669 ! 647 DO_2D( 0, 0, 0, 0) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1670 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 648 671 pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) 649 672 END_2D 650 DO_3D( 0, 0, 0, 0, kstart+1, jpkm1 )673 DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, kstart+1, jpkm1 ) 651 674 pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1) 652 675 END_3D 653 676 654 DO_2D( 0, 0, 0, 0) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk677 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 655 678 pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 656 679 END_2D 657 DO_3DS( 0, 0, 0, 0, jpk-2, kstart, -1 )680 DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpk-2, kstart, -1 ) 658 681 pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - pU(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 659 682 END_3D -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traadv_mus.F90
r13497 r14046 81 81 LOGICAL , INTENT(in ) :: ld_msc_ups ! use upstream scheme within muscl 82 82 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 83 ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 83 84 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume flux components 84 85 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation … … 88 89 REAL(wp) :: zu, z0u, zzwx, zw , zalpha ! local scalars 89 90 REAL(wp) :: zv, z0v, zzwy, z0w ! - - 90 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwx, zslpx ! 3D workspace91 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwy, zslpy ! - -91 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zslpx ! 3D workspace 92 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zslpy ! - - 92 93 !!---------------------------------------------------------------------- 93 94 ! 94 IF( kt == kit000 ) THEN 95 IF(lwp) WRITE(numout,*) 96 IF(lwp) WRITE(numout,*) 'tra_adv : MUSCL advection scheme on ', cdtype 97 IF(lwp) WRITE(numout,*) ' : mixed up-stream ', ld_msc_ups 98 IF(lwp) WRITE(numout,*) '~~~~~~~' 99 IF(lwp) WRITE(numout,*) 100 ! 101 ! Upstream / MUSCL scheme indicator 102 ! 103 ALLOCATE( xind(jpi,jpj,jpk), STAT=ierr ) 104 xind(:,:,:) = 1._wp ! set equal to 1 where up-stream is not needed 105 ! 106 IF( ld_msc_ups ) THEN ! define the upstream indicator (if asked) 107 ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) 108 upsmsk(:,:) = 0._wp ! not upstream by default 109 ! 110 DO jk = 1, jpkm1 111 xind(:,:,jk) = 1._wp & ! =>1 where up-stream is not needed 112 & - MAX ( rnfmsk(:,:) * rnfmsk_z(jk), & ! =>0 near runoff mouths (& closed sea outflows) 113 & upsmsk(:,:) ) * tmask(:,:,jk) ! =>0 in some user defined area 114 END DO 115 ENDIF 116 ! 117 ENDIF 118 ! 119 l_trd = .FALSE. 120 l_hst = .FALSE. 121 l_ptr = .FALSE. 122 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 123 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 124 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 125 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 95 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 96 IF( kt == kit000 ) THEN 97 IF(lwp) WRITE(numout,*) 98 IF(lwp) WRITE(numout,*) 'tra_adv : MUSCL advection scheme on ', cdtype 99 IF(lwp) WRITE(numout,*) ' : mixed up-stream ', ld_msc_ups 100 IF(lwp) WRITE(numout,*) '~~~~~~~' 101 IF(lwp) WRITE(numout,*) 102 ! 103 ! Upstream / MUSCL scheme indicator 104 ! 105 ALLOCATE( xind(jpi,jpj,jpk), STAT=ierr ) 106 xind(:,:,:) = 1._wp ! set equal to 1 where up-stream is not needed 107 ! 108 IF( ld_msc_ups ) THEN ! define the upstream indicator (if asked) 109 ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) 110 upsmsk(:,:) = 0._wp ! not upstream by default 111 ! 112 DO jk = 1, jpkm1 113 xind(:,:,jk) = 1._wp & ! =>1 where up-stream is not needed 114 & - MAX ( rnfmsk(:,:) * rnfmsk_z(jk), & ! =>0 near runoff mouths (& closed sea outflows) 115 & upsmsk(:,:) ) * tmask(:,:,jk) ! =>0 in some user defined area 116 END DO 117 ENDIF 118 ! 119 ENDIF 120 ! 121 l_trd = .FALSE. 122 l_hst = .FALSE. 123 l_ptr = .FALSE. 124 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 125 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 126 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 127 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 128 ENDIF 126 129 ! 127 130 DO jn = 1, kjpt !== loop over the tracers ==! … … 132 135 zwx(:,:,jpk) = 0._wp ! bottom values 133 136 zwy(:,:,jpk) = 0._wp 134 DO_3D( 1, 0, 1, 0, 1, jpkm1 )137 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) 135 138 zwx(ji,jj,jk) = umask(ji,jj,jk) * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 136 139 zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( pt(ji,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 137 140 END_3D 138 141 ! lateral boundary conditions (changed sign) 139 CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp )142 IF ( nn_hls.EQ.1 ) CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) 140 143 ! !-- Slopes of tracer 141 144 zslpx(:,:,jpk) = 0._wp ! bottom values 142 145 zslpy(:,:,jpk) = 0._wp 143 DO_3D( 0, 1, 0, 1, 1, jpkm1 )146 DO_3D( nn_hls-1, 1, nn_hls-1, 1, 1, jpkm1 ) 144 147 zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji-1,jj ,jk) ) & 145 148 & * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji-1,jj ,jk) ) ) … … 148 151 END_3D 149 152 ! 150 DO_3D( 0, 1, 0, 1, 1, jpkm1 ) !-- Slopes limitation153 DO_3D( nn_hls-1, 1, nn_hls-1, 1, 1, jpkm1 ) !-- Slopes limitation 151 154 zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji ,jj,jk) ), & 152 155 & 2.*ABS( zwx (ji-1,jj,jk) ), & … … 157 160 END_3D 158 161 ! 159 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- MUSCL horizontal advective fluxes162 DO_3D( nn_hls-1, 0, nn_hls-1, 0, 1, jpkm1 ) !-- MUSCL horizontal advective fluxes 160 163 ! MUSCL fluxes 161 164 z0u = SIGN( 0.5_wp, pU(ji,jj,jk) ) … … 173 176 zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 174 177 END_3D 175 CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) ! lateral boundary conditions (changed sign)178 IF ( nn_hls.EQ.1 ) CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) ! lateral boundary conditions (changed sign) 176 179 ! 177 180 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- Tracer advective trend … … 195 198 zwx(:,:, 1 ) = 0._wp ! surface & bottom boundary conditions 196 199 zwx(:,:,jpk) = 0._wp 197 DO jk = 2, jpkm1! interior values198 zwx( :,:,jk) = tmask(:,:,jk) * ( pt(:,:,jk-1,jn,Kbb) - pt(:,:,jk,jn,Kbb) )199 END DO200 DO_3D( 1, 1, 1, 1, 2, jpkm1 ) ! interior values 201 zwx(ji,jj,jk) = tmask(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 202 END_3D 200 203 ! !-- Slopes of tracer 201 204 zslpx(:,:,1) = 0._wp ! surface values … … 223 226 END_2D 224 227 ELSE ! no cavities: only at the ocean surface 225 zwx(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 228 DO_2D( 1, 1, 1, 1 ) 229 zwx(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) 230 END_2D 226 231 ENDIF 227 232 ENDIF -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traadv_qck.F90
r13497 r14046 91 91 INTEGER , INTENT(in ) :: kjpt ! number of tracers 92 92 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 93 ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 94 ! NOTE: [tiling-comms-merge] These were changed to INTENT(inout) but they are not modified, so it is reverted 93 95 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components 94 96 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation 95 97 !!---------------------------------------------------------------------- 96 98 ! 97 IF( kt == kit000 ) THEN 98 IF(lwp) WRITE(numout,*) 99 IF(lwp) WRITE(numout,*) 'tra_adv_qck : 3rd order quickest advection scheme on ', cdtype 100 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 101 IF(lwp) WRITE(numout,*) 99 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 100 IF( kt == kit000 ) THEN 101 IF(lwp) WRITE(numout,*) 102 IF(lwp) WRITE(numout,*) 'tra_adv_qck : 3rd order quickest advection scheme on ', cdtype 103 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 104 IF(lwp) WRITE(numout,*) 105 ENDIF 106 ! 107 l_trd = .FALSE. 108 l_ptr = .FALSE. 109 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 110 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 102 111 ENDIF 103 !104 l_trd = .FALSE.105 l_ptr = .FALSE.106 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.107 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE.108 !109 112 ! 110 113 ! ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme … … 127 130 INTEGER , INTENT(in ) :: kjpt ! number of tracers 128 131 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 132 ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 129 133 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU ! i-velocity components 130 134 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation … … 132 136 INTEGER :: ji, jj, jk, jn ! dummy loop indices 133 137 REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars 134 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwx, zfu, zfc, zfd138 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwx, zfu, zfc, zfd 135 139 !---------------------------------------------------------------------- 136 140 ! … … 142 146 ! 143 147 !!gm why not using a SHIFT instruction... 144 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !--- Computation of the ustream and downstream value of the tracer and the mask148 DO_3D( 0, 0, nn_hls-1, nn_hls-1, 1, jpkm1 ) !--- Computation of the ustream and downstream value of the tracer and the mask 145 149 zfc(ji,jj,jk) = pt(ji-1,jj,jk,jn,Kbb) ! Upstream in the x-direction for the tracer 146 150 zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb) ! Downstream in the x-direction for the tracer 147 151 END_3D 148 CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions152 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 149 153 150 154 ! 151 155 ! Horizontal advective fluxes 152 156 ! --------------------------- 153 DO_3D( 0, 0, 0, 0, 1, jpkm1 )157 DO_3D( 0, 0, nn_hls-1, 0, 1, jpkm1 ) 154 158 zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 155 159 zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk) ! FU in the x-direction for T 156 160 END_3D 157 161 ! 158 DO_3D( 0, 0, 0, 0, 1, jpkm1 )162 DO_3D( 0, 0, nn_hls-1, 0, 1, jpkm1 ) 159 163 zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 160 164 zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) … … 164 168 END_3D 165 169 !--- Lateral boundary conditions 166 CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwx(:,:,:), 'T', 1.0_wp )170 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwx(:,:,:), 'T', 1.0_wp ) 167 171 168 172 !--- QUICKEST scheme … … 170 174 ! 171 175 ! Mask at the T-points in the x-direction (mask=0 or mask=1) 172 DO_3D( 0, 0, 0, 0, 1, jpkm1 )176 DO_3D( 0, 0, nn_hls-1, nn_hls-1, 1, jpkm1 ) 173 177 zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 174 178 END_3D 175 CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions179 IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 176 180 177 181 ! 178 182 ! Tracer flux on the x-direction 179 DO jk = 1, jpkm1 180 ! 181 DO_2D( 0, 0, 0, 0 ) 182 zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 183 !--- If the second ustream point is a land point 184 !--- the flux is computed by the 1st order UPWIND scheme 185 zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk) 186 zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 187 zwx(ji,jj,jk) = zwx(ji,jj,jk) * pU(ji,jj,jk) 188 END_2D 189 END DO 190 ! 191 CALL lbc_lnk( 'traadv_qck', zwx(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 183 DO_3D( 0, 0, 1, 0, 1, jpkm1 ) 184 zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 185 !--- If the second ustream point is a land point 186 !--- the flux is computed by the 1st order UPWIND scheme 187 zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk) 188 zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 189 zwx(ji,jj,jk) = zwx(ji,jj,jk) * pU(ji,jj,jk) 190 END_3D 192 191 ! 193 192 ! Computation of the trend … … 216 215 INTEGER , INTENT(in ) :: kjpt ! number of tracers 217 216 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 217 ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 218 218 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pV ! j-velocity components 219 219 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation … … 221 221 INTEGER :: ji, jj, jk, jn ! dummy loop indices 222 222 REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars 223 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwy, zfu, zfc, zfd ! 3D workspace223 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwy, zfu, zfc, zfd ! 3D workspace 224 224 !---------------------------------------------------------------------- 225 225 ! … … 233 233 ! 234 234 !--- Computation of the ustream and downstream value of the tracer and the mask 235 DO_2D( 0, 0, 0, 0 )235 DO_2D( nn_hls-1, nn_hls-1, 0, 0 ) 236 236 ! Upstream in the x-direction for the tracer 237 237 zfc(ji,jj,jk) = pt(ji,jj-1,jk,jn,Kbb) … … 240 240 END_2D 241 241 END DO 242 CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 243 242 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 244 243 245 244 ! … … 247 246 ! --------------------------- 248 247 ! 249 DO_3D( 0, 0, 0, 0, 1, jpkm1 )248 DO_3D( nn_hls-1, 0, 0, 0, 1, jpkm1 ) 250 249 zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 251 250 zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk) ! FU in the x-direction for T 252 251 END_3D 253 252 ! 254 DO_3D( 0, 0, 0, 0, 1, jpkm1 )253 DO_3D( nn_hls-1, 0, 0, 0, 1, jpkm1 ) 255 254 zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 256 255 zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) … … 261 260 262 261 !--- Lateral boundary conditions 263 CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwy(:,:,:), 'T', 1.0_wp )262 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwy(:,:,:), 'T', 1.0_wp ) 264 263 265 264 !--- QUICKEST scheme … … 267 266 ! 268 267 ! Mask at the T-points in the x-direction (mask=0 or mask=1) 269 DO_3D( 0, 0, 0, 0, 1, jpkm1 )268 DO_3D( nn_hls-1, nn_hls-1, 0, 0, 1, jpkm1 ) 270 269 zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 271 270 END_3D 272 CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp ) !--- Lateral boundary conditions271 IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp ) !--- Lateral boundary conditions 273 272 ! 274 273 ! Tracer flux on the x-direction 275 DO jk = 1, jpkm1 276 ! 277 DO_2D( 0, 0, 0, 0 ) 278 zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 279 !--- If the second ustream point is a land point 280 !--- the flux is computed by the 1st order UPWIND scheme 281 zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk) 282 zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 283 zwy(ji,jj,jk) = zwy(ji,jj,jk) * pV(ji,jj,jk) 284 END_2D 285 END DO 286 ! 287 CALL lbc_lnk( 'traadv_qck', zwy(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 274 DO_3D( 1, 0, 0, 0, 1, jpkm1 ) 275 zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) ) ! if pU > 0 : zdir = 1 otherwise zdir = 0 276 !--- If the second ustream point is a land point 277 !--- the flux is computed by the 1st order UPWIND scheme 278 zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk) 279 zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 280 zwy(ji,jj,jk) = zwy(ji,jj,jk) * pV(ji,jj,jk) 281 END_3D 288 282 ! 289 283 ! Computation of the trend … … 313 307 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 314 308 INTEGER , INTENT(in ) :: kjpt ! number of tracers 315 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity 309 ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 310 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pW ! vertical velocity 316 311 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! active tracers and RHS of tracer equation 317 312 ! 318 313 INTEGER :: ji, jj, jk, jn ! dummy loop indices 319 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwz ! 3D workspace314 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwz ! 3D workspace 320 315 !!---------------------------------------------------------------------- 321 316 ! … … 332 327 IF( ln_linssh ) THEN !* top value (only in linear free surf. as zwz is multiplied by wmask) 333 328 IF( ln_isfcav ) THEN ! ice-shelf cavities (top of the ocean) 334 DO_2D( 1, 1, 1, 1)329 DO_2D( 0, 0, 0, 0 ) 335 330 zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm) ! linear free surface 336 331 END_2D 337 332 ELSE ! no ocean cavities (only ocean surface) 338 zwz(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kmm) 333 DO_2D( 0, 0, 0, 0 ) 334 zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) 335 END_2D 339 336 ENDIF 340 337 ENDIF … … 359 356 !! ** Method : 360 357 !!---------------------------------------------------------------------- 361 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in ) :: pfu ! second upwind point362 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in ) :: pfd ! first douwning point363 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point)364 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux358 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfu ! second upwind point 359 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfd ! first douwning point 360 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point) 361 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: puc ! input as Courant number ; output as flux 365 362 !! 366 363 INTEGER :: ji, jj, jk ! dummy loop indices … … 369 366 !---------------------------------------------------------------------- 370 367 ! 371 DO_3D( 1, 1, 1, 1, 1, jpkm1 )368 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 372 369 zc = puc(ji,jj,jk) ! Courant number 373 370 zcurv = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traadv_ubs.F90
r13497 r14046 92 92 INTEGER , INTENT(in ) :: kn_ubs_v ! number of tracers 93 93 REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step 94 ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 94 95 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pU, pV, pW ! 3 ocean volume transport components 95 96 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) :: pt ! tracers and RHS of tracer equation … … 99 100 REAL(wp) :: zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk ! - - 100 101 REAL(wp) :: zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn ! - - 101 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace 102 !!---------------------------------------------------------------------- 103 ! 104 IF( kt == kit000 ) THEN 105 IF(lwp) WRITE(numout,*) 106 IF(lwp) WRITE(numout,*) 'tra_adv_ubs : horizontal UBS advection scheme on ', cdtype 107 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 102 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace 103 !!---------------------------------------------------------------------- 104 ! 105 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 106 IF( kt == kit000 ) THEN 107 IF(lwp) WRITE(numout,*) 108 IF(lwp) WRITE(numout,*) 'tra_adv_ubs : horizontal UBS advection scheme on ', cdtype 109 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 110 ENDIF 111 ! 112 l_trd = .FALSE. 113 l_hst = .FALSE. 114 l_ptr = .FALSE. 115 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 116 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 117 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 118 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 108 119 ENDIF 109 !110 l_trd = .FALSE.111 l_hst = .FALSE.112 l_ptr = .FALSE.113 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE.114 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE.115 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. &116 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE.117 120 ! 118 121 ztw (:,:, 1 ) = 0._wp ! surface & bottom value : set to zero for all tracers 119 122 zltu(:,:,jpk) = 0._wp ; zltv(:,:,jpk) = 0._wp 120 123 ztw (:,:,jpk) = 0._wp ; zti (:,:,jpk) = 0._wp 121 !122 124 ! ! =========== 123 125 DO jn = 1, kjpt ! tracer loop … … 125 127 ! 126 128 DO jk = 1, jpkm1 !== horizontal laplacian of before tracer ==! 127 DO_2D( 1, 0, 1, 0) ! First derivative (masked gradient)129 DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) ! First derivative (masked gradient) 128 130 zeeu = e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk) 129 131 zeev = e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk) … … 131 133 ztv(ji,jj,jk) = zeev * ( pt(ji ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 132 134 END_2D 133 DO_2D( 0, 0, 0, 0) ! Second derivative (divergence)135 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! Second derivative (divergence) 134 136 zcoef = 1._wp / ( 6._wp * e3t(ji,jj,jk,Kmm) ) 135 137 zltu(ji,jj,jk) = ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) * zcoef … … 138 140 ! 139 141 END DO 140 CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_wp ) ; CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn)142 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_ubs', zltu, 'T', 1.0_wp, zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 141 143 ! 142 144 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== Horizontal advective fluxes ==! (UBS) … … 153 155 END_3D 154 156 ! 155 zltu(:,:,:) = pt(:,:,:,jn,Krhs) ! store the initial trends before its update 157 DO_3D( 1, 1, 1, 1, 1, jpk ) 158 zltu(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) ! store the initial trends before its update 159 END_3D 156 160 ! 157 161 DO jk = 1, jpkm1 !== add the horizontal advective trend ==! … … 165 169 END DO 166 170 ! 167 zltu(:,:,:) = pt(:,:,:,jn,Krhs) - zltu(:,:,:) ! Horizontal advective trend used in vertical 2nd order FCT case 168 ! ! and/or in trend diagnostic (l_trd=T) 169 ! 171 DO_3D( 1, 1, 1, 1, 1, jpk ) 172 zltu(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltu(ji,jj,jk) ! Horizontal advective trend used in vertical 2nd order FCT case 173 END_3D ! and/or in trend diagnostic (l_trd=T) 174 ! 170 175 IF( l_trd ) THEN ! trend diagnostics 171 176 CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztu, pU, pt(:,:,:,jn,Kmm) ) … … 185 190 CASE( 2 ) ! 2nd order FCT 186 191 ! 187 IF( l_trd ) zltv(:,:,:) = pt(:,:,:,jn,Krhs) ! store pt(:,:,:,:,Krhs) if trend diag. 192 IF( l_trd ) THEN 193 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 194 zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) ! store pt(:,:,:,:,Krhs) if trend diag. 195 END_3D 196 ENDIF 188 197 ! 189 198 ! !* upstream advection with initial mass fluxes & intermediate update ==! … … 199 208 END_2D 200 209 ELSE ! no cavities: only at the ocean surface 201 ztw(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 210 DO_2D( 1, 1, 1, 1 ) 211 ztw(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) 212 END_2D 202 213 ENDIF 203 214 ENDIF … … 209 220 zti(ji,jj,jk) = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 210 221 END_3D 211 CALL lbc_lnk( 'traadv_ubs', zti, 'T', 1.0_wp ) ! Lateral boundary conditions on zti, zsi (unchanged sign)212 222 ! 213 223 ! !* anti-diffusive flux : high order minus low order … … 226 236 ztw(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) 227 237 END_3D 228 IF( ln_linssh ) ztw(:,:, 1 ) = pW(:,:,1) * pt(:,:,1,jn,Kmm) !!gm ISF & 4th COMPACT doesn't work 238 IF( ln_linssh ) THEN 239 DO_2D( 1, 1, 1, 1 ) 240 ztw(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) !!gm ISF & 4th COMPACT doesn't work 241 END_2D 242 ENDIF 229 243 ! 230 244 END SELECT … … 262 276 !! in-space based differencing for fluid 263 277 !!---------------------------------------------------------------------- 264 INTEGER , INTENT(in ) 265 REAL(wp), INTENT(in ) 266 REAL(wp), DIMENSION 267 REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) :: paft ! after field268 REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) :: pcc ! monotonic flux in the k direction278 INTEGER , INTENT(in ) :: Kmm ! time level index 279 REAL(wp), INTENT(in ) :: p2dt ! tracer time-step 280 REAL(wp), DIMENSION(jpi,jpj,jpk) :: pbef ! before field 281 REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: paft ! after field 282 REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls) ,jpk) :: pcc ! monotonic flux in the k direction 269 283 ! 270 284 INTEGER :: ji, jj, jk ! dummy loop indices 271 285 INTEGER :: ikm1 ! local integer 272 286 REAL(wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zrtrn ! local scalars 273 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zbetup, zbetdo! 3D workspace287 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo ! 3D workspace 274 288 !!---------------------------------------------------------------------- 275 289 ! … … 281 295 ! -------------------- 282 296 ! ! large negative value (-zbig) inside land 283 pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) - zbig * ( 1.e0 - tmask(:,:,:) ) 284 paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) - zbig * ( 1.e0 - tmask(:,:,:) ) 297 DO_3D( 0, 0, 0, 0, 1, jpk ) 298 pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1.e0 - tmask(ji,jj,jk) ) 299 paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1.e0 - tmask(ji,jj,jk) ) 300 END_3D 285 301 ! 286 302 DO jk = 1, jpkm1 ! search maximum in neighbourhood … … 293 309 END DO 294 310 ! ! large positive value (+zbig) inside land 295 pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) + zbig * ( 1.e0 - tmask(:,:,:) ) 296 paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) + zbig * ( 1.e0 - tmask(:,:,:) ) 311 DO_3D( 0, 0, 0, 0, 1, jpk ) 312 pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1.e0 - tmask(ji,jj,jk) ) 313 paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1.e0 - tmask(ji,jj,jk) ) 314 END_3D 297 315 ! 298 316 DO jk = 1, jpkm1 ! search minimum in neighbourhood … … 305 323 END DO 306 324 ! ! restore masked values to zero 307 pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) 308 paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) 325 DO_3D( 0, 0, 0, 0, 1, jpk ) 326 pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) 327 paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) 328 END_3D 309 329 ! 310 330 ! Positive and negative part of fluxes and beta terms -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traatf.F90
r13295 r14046 156 156 ENDIF 157 157 ! 158 CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kbb) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kbb) , 'T', 1.0_wp, & 159 & pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_wp, & 160 & pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp ) 161 ! 158 CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_wp ) 159 162 160 ENDIF 163 161 ! … … 210 208 DO jn = 1, kjpt 211 209 ! 212 DO_3D( 0, 0, 0, 0, 1, jpkm1 )210 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 213 211 ztn = pt(ji,jj,jk,jn,Kmm) 214 212 ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb) ! time laplacian on tracers … … 275 273 zfact2 = zfact1 * r1_rho0 276 274 DO jn = 1, kjpt 277 DO_3D( 0, 0, 0, 0, 1, jpkm1 )275 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 278 276 ze3t_b = e3t(ji,jj,jk,Kbb) 279 277 ze3t_n = e3t(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traatf_qco.F90
r13295 r14046 149 149 ENDIF 150 150 ! 151 CALL lbc_lnk_multi( 'traatfqco', pts(:,:,:,jp_tem,Kbb) , 'T', 1., pts(:,:,:,jp_sal,Kbb) , 'T', 1., & 152 & pts(:,:,:,jp_tem,Kmm) , 'T', 1., pts(:,:,:,jp_sal,Kmm) , 'T', 1., & 153 & pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. ) 154 ! 151 CALL lbc_lnk_multi( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1., pts(:,:,:,jp_sal,Kmm) , 'T', 1. ) 152 155 153 ENDIF 156 154 ! … … 203 201 DO jn = 1, kjpt 204 202 ! 205 DO_3D( 0, 0, 0, 0, 1, jpkm1 )203 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 206 204 ztn = pt(ji,jj,jk,jn,Kmm) 207 205 ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb) ! time laplacian on tracers … … 268 266 zfact2 = zfact1 * r1_rho0 269 267 DO jn = 1, kjpt 270 DO_3D( 0, 0, 0, 0, 1, jpkm1 )268 DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 271 269 ze3t_b = e3t(ji,jj,jk,Kbb) 272 270 ze3t_n = e3t(ji,jj,jk,Kmm) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/trabbc.F90
r13295 r14046 80 80 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 81 81 ! 82 INTEGER :: ji, jj ! dummy loop indices82 INTEGER :: ji, jj, jk ! dummy loop indices 83 83 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt ! 3D workspace 84 84 !!---------------------------------------------------------------------- … … 86 86 IF( ln_timing ) CALL timing_start('tra_bbc') 87 87 ! 88 IF( l_trdtra ) THEN! Save the input temperature trend88 IF( l_trdtra ) THEN ! Save the input temperature trend 89 89 ALLOCATE( ztrdt(jpi,jpj,jpk) ) 90 90 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) … … 96 96 END_2D 97 97 ! 98 CALL lbc_lnk( 'trabbc', pts(:,:,:,jp_tem,Krhs) , 'T', 1.0_wp )99 !100 98 IF( l_trdtra ) THEN ! Send the trend for diagnostics 101 99 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) … … 104 102 ENDIF 105 103 ! 106 CALL iom_put ( "hfgeou" , rho0_rcp * qgh_trd0(:,:) ) 104 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 105 CALL iom_put ( "hfgeou" , rho0_rcp * qgh_trd0(:,:) ) 106 ENDIF 107 107 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbc - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 108 108 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/trabbl.F90
r13532 r14046 106 106 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 107 107 ! 108 INTEGER :: ji, jj, jk ! Dummy loop indices 108 109 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 109 110 !!---------------------------------------------------------------------- … … 112 113 ! 113 114 IF( l_trdtra ) THEN !* Save the T-S input trends 114 ALLOCATE( ztrdt(jpi,jpj,jpk) 115 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 115 116 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 116 117 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) … … 125 126 CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_ldf - Ta: ', mask1=tmask, & 126 127 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 127 ! lateral boundary conditions ; just need for outputs128 CALL lbc_lnk_multi( 'trabbl', ahu_bbl, 'U', 1.0_wp , ahv_bbl, 'V', 1.0_wp )129 CALL iom_put( "ahu_bbl", ahu_bbl ) ! bbl diffusive flux i-coef130 CALL iom_put( "ahv_bbl", ahv_bbl ) ! bbl diffusive flux j-coef128 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 129 CALL iom_put( "ahu_bbl", ahu_bbl ) ! bbl diffusive flux i-coef 130 CALL iom_put( "ahv_bbl", ahv_bbl ) ! bbl diffusive flux j-coef 131 ENDIF 131 132 ! 132 133 ENDIF … … 136 137 CALL tra_bbl_adv( pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, Kmm ) 137 138 IF(sn_cfctl%l_prtctl) & 138 CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_adv - Ta: ', mask1=tmask, 139 CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_adv - Ta: ', mask1=tmask, & 139 140 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 140 ! lateral boundary conditions ; just need for outputs 141 CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 142 CALL iom_put( "uoce_bbl", utr_bbl ) ! bbl i-transport 143 CALL iom_put( "voce_bbl", vtr_bbl ) ! bbl j-transport 141 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 142 ! lateral boundary conditions ; just need for outputs 143 ! NOTE: [tiling-comms-merge] The diagnostic results change along the north fold if this is removed 144 CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 145 CALL iom_put( "uoce_bbl", utr_bbl ) ! bbl i-transport 146 CALL iom_put( "voce_bbl", vtr_bbl ) ! bbl j-transport 147 ENDIF 144 148 ! 145 149 ENDIF … … 187 191 INTEGER :: ik ! local integers 188 192 REAL(wp) :: zbtr ! local scalars 189 REAL(wp), DIMENSION( jpi,jpj) :: zptb ! workspace193 REAL(wp), DIMENSION(A2D(nn_hls)) :: zptb ! workspace 190 194 !!---------------------------------------------------------------------- 191 195 ! … … 235 239 INTEGER :: iis , iid , ijs , ijd ! local integers 236 240 INTEGER :: ikus, ikud, ikvs, ikvd ! - - 241 INTEGER :: isi, isj ! - - 237 242 REAL(wp) :: zbtr, ztra ! local scalars 238 243 REAL(wp) :: zu_bbl, zv_bbl ! - - 239 244 !!---------------------------------------------------------------------- 240 245 ! 246 IF( ntsi == Nis0 ) THEN ; isi = 1 ; ELSE ; isi = 0 ; ENDIF ! Avoid double-counting when using tiling 247 IF( ntsj == Njs0 ) THEN ; isj = 1 ; ELSE ; isj = 0 ; ENDIF 241 248 ! ! =========== 242 249 DO jn = 1, kjpt ! tracer loop 243 250 ! ! =========== 244 DO jj = 1, jpjm1 245 DO ji = 1, jpim1 ! CAUTION start from i=1 to update i=2 when cyclic east-west 246 IF( utr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero i-direction bbl advection 247 ! down-slope i/k-indices (deep) & up-slope i/k indices (shelf) 248 iid = ji + MAX( 0, mgrhu(ji,jj) ) ; iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 249 ikud = mbku_d(ji,jj) ; ikus = mbku(ji,jj) 250 zu_bbl = ABS( utr_bbl(ji,jj) ) 251 ! 252 ! ! up -slope T-point (shelf bottom point) 253 zbtr = r1_e1e2t(iis,jj) / e3t(iis,jj,ikus,Kmm) 254 ztra = zu_bbl * ( pt(iid,jj,ikus,jn) - pt(iis,jj,ikus,jn) ) * zbtr 255 pt_rhs(iis,jj,ikus,jn) = pt_rhs(iis,jj,ikus,jn) + ztra 256 ! 257 DO jk = ikus, ikud-1 ! down-slope upper to down T-point (deep column) 258 zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,jk,Kmm) 259 ztra = zu_bbl * ( pt(iid,jj,jk+1,jn) - pt(iid,jj,jk,jn) ) * zbtr 260 pt_rhs(iid,jj,jk,jn) = pt_rhs(iid,jj,jk,jn) + ztra 261 END DO 262 ! 263 zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,ikud,Kmm) 264 ztra = zu_bbl * ( pt(iis,jj,ikus,jn) - pt(iid,jj,ikud,jn) ) * zbtr 265 pt_rhs(iid,jj,ikud,jn) = pt_rhs(iid,jj,ikud,jn) + ztra 266 ENDIF 267 ! 268 IF( vtr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero j-direction bbl advection 269 ! down-slope j/k-indices (deep) & up-slope j/k indices (shelf) 270 ijd = jj + MAX( 0, mgrhv(ji,jj) ) ; ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 271 ikvd = mbkv_d(ji,jj) ; ikvs = mbkv(ji,jj) 272 zv_bbl = ABS( vtr_bbl(ji,jj) ) 273 ! 274 ! up -slope T-point (shelf bottom point) 275 zbtr = r1_e1e2t(ji,ijs) / e3t(ji,ijs,ikvs,Kmm) 276 ztra = zv_bbl * ( pt(ji,ijd,ikvs,jn) - pt(ji,ijs,ikvs,jn) ) * zbtr 277 pt_rhs(ji,ijs,ikvs,jn) = pt_rhs(ji,ijs,ikvs,jn) + ztra 278 ! 279 DO jk = ikvs, ikvd-1 ! down-slope upper to down T-point (deep column) 280 zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,jk,Kmm) 281 ztra = zv_bbl * ( pt(ji,ijd,jk+1,jn) - pt(ji,ijd,jk,jn) ) * zbtr 282 pt_rhs(ji,ijd,jk,jn) = pt_rhs(ji,ijd,jk,jn) + ztra 283 END DO 284 ! ! down-slope T-point (deep bottom point) 285 zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,ikvd,Kmm) 286 ztra = zv_bbl * ( pt(ji,ijs,ikvs,jn) - pt(ji,ijd,ikvd,jn) ) * zbtr 287 pt_rhs(ji,ijd,ikvd,jn) = pt_rhs(ji,ijd,ikvd,jn) + ztra 288 ENDIF 289 END DO 251 ! NOTE: [tiling-comms-merge] Bug fix- correct order of indices 252 DO_2D( isj, 0, isi, 0 ) ! CAUTION start from i=1 to update i=2 when cyclic east-west 253 IF( utr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero i-direction bbl advection 254 ! down-slope i/k-indices (deep) & up-slope i/k indices (shelf) 255 iid = ji + MAX( 0, mgrhu(ji,jj) ) ; iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 256 ikud = mbku_d(ji,jj) ; ikus = mbku(ji,jj) 257 zu_bbl = ABS( utr_bbl(ji,jj) ) 258 ! 259 ! ! up -slope T-point (shelf bottom point) 260 zbtr = r1_e1e2t(iis,jj) / e3t(iis,jj,ikus,Kmm) 261 ztra = zu_bbl * ( pt(iid,jj,ikus,jn) - pt(iis,jj,ikus,jn) ) * zbtr 262 pt_rhs(iis,jj,ikus,jn) = pt_rhs(iis,jj,ikus,jn) + ztra 263 ! 264 DO jk = ikus, ikud-1 ! down-slope upper to down T-point (deep column) 265 zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,jk,Kmm) 266 ztra = zu_bbl * ( pt(iid,jj,jk+1,jn) - pt(iid,jj,jk,jn) ) * zbtr 267 pt_rhs(iid,jj,jk,jn) = pt_rhs(iid,jj,jk,jn) + ztra 268 END DO 269 ! 270 zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,ikud,Kmm) 271 ztra = zu_bbl * ( pt(iis,jj,ikus,jn) - pt(iid,jj,ikud,jn) ) * zbtr 272 pt_rhs(iid,jj,ikud,jn) = pt_rhs(iid,jj,ikud,jn) + ztra 273 ENDIF 290 274 ! 291 END DO 292 ! ! =========== 293 END DO ! end tracer 294 ! ! =========== 275 IF( vtr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero j-direction bbl advection 276 ! down-slope j/k-indices (deep) & up-slope j/k indices (shelf) 277 ijd = jj + MAX( 0, mgrhv(ji,jj) ) ; ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 278 ikvd = mbkv_d(ji,jj) ; ikvs = mbkv(ji,jj) 279 zv_bbl = ABS( vtr_bbl(ji,jj) ) 280 ! 281 ! up -slope T-point (shelf bottom point) 282 zbtr = r1_e1e2t(ji,ijs) / e3t(ji,ijs,ikvs,Kmm) 283 ztra = zv_bbl * ( pt(ji,ijd,ikvs,jn) - pt(ji,ijs,ikvs,jn) ) * zbtr 284 pt_rhs(ji,ijs,ikvs,jn) = pt_rhs(ji,ijs,ikvs,jn) + ztra 285 ! 286 DO jk = ikvs, ikvd-1 ! down-slope upper to down T-point (deep column) 287 zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,jk,Kmm) 288 ztra = zv_bbl * ( pt(ji,ijd,jk+1,jn) - pt(ji,ijd,jk,jn) ) * zbtr 289 pt_rhs(ji,ijd,jk,jn) = pt_rhs(ji,ijd,jk,jn) + ztra 290 END DO 291 ! ! down-slope T-point (deep bottom point) 292 zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,ikvd,Kmm) 293 ztra = zv_bbl * ( pt(ji,ijs,ikvs,jn) - pt(ji,ijd,ikvd,jn) ) * zbtr 294 pt_rhs(ji,ijd,ikvd,jn) = pt_rhs(ji,ijd,ikvd,jn) + ztra 295 ENDIF 296 END_2D 297 ! ! =========== 298 END DO ! end tracer 299 ! ! =========== 295 300 END SUBROUTINE tra_bbl_adv 296 301 … … 333 338 REAL(wp) :: za, zb, zgdrho ! local scalars 334 339 REAL(wp) :: zsign, zsigna, zgbbl ! - - 335 REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts, zab ! 3D workspace 336 REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb, zdep ! 2D workspace 337 !!---------------------------------------------------------------------- 338 ! 339 IF( kt == kit000 ) THEN 340 IF(lwp) WRITE(numout,*) 341 IF(lwp) WRITE(numout,*) 'trabbl:bbl : Compute bbl velocities and diffusive coefficients in ', cdtype 342 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 340 REAL(wp), DIMENSION(A2D(nn_hls),jpts) :: zts, zab ! 3D workspace 341 REAL(wp), DIMENSION(A2D(nn_hls)) :: zub, zvb, zdep ! 2D workspace 342 !!---------------------------------------------------------------------- 343 ! 344 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 345 IF( kt == kit000 ) THEN 346 IF(lwp) WRITE(numout,*) 347 IF(lwp) WRITE(numout,*) 'trabbl:bbl : Compute bbl velocities and diffusive coefficients in ', cdtype 348 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 349 ENDIF 343 350 ENDIF 344 351 ! !* bottom variables (T, S, alpha, beta, depth, velocity) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/tradmp.F90
r13295 r14046 95 95 ! 96 96 INTEGER :: ji, jj, jk, jn ! dummy loop indices 97 REAL(wp), DIMENSION( jpi,jpj,jpk,jpts) :: zts_dta97 REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts) :: zts_dta 98 98 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: ztrdts 99 99 !!---------------------------------------------------------------------- … … 102 102 ! 103 103 IF( l_trdtra ) THEN !* Save ta and sa trends 104 ALLOCATE( ztrdts(jpi,jpj,jpk,jpts) ) 105 ztrdts(:,:,:,:) = pts(:,:,:,:,Krhs) 104 ALLOCATE( ztrdts(jpi,jpj,jpk,jpts) ) 105 ztrdts(:,:,:,:) = pts(:,:,:,:,Krhs) 106 106 ENDIF 107 107 ! !== input T-S data at kt ==! … … 144 144 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) ) 145 145 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) ) 146 DEALLOCATE( ztrdts ) 146 DEALLOCATE( ztrdts ) 147 147 ENDIF 148 148 ! ! Control print -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traisf.F90
r13295 r14046 11 11 !!---------------------------------------------------------------------- 12 12 USE isf_oce ! Ice shelf variables 13 USE par_oce , ONLY : nijtile, ntile, ntsi, ntei, ntsj, ntej 13 14 USE dom_oce ! ocean space domain variables 14 15 USE isfutils, ONLY : debug ! debug option … … 46 47 IF( ln_timing ) CALL timing_start('tra_isf') 47 48 ! 48 IF( kt == nit000 ) THEN 49 IF(lwp) WRITE(numout,*) 50 IF(lwp) WRITE(numout,*) 'tra_isf : Ice shelf heat fluxes' 51 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 49 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 50 IF( kt == nit000 ) THEN 51 IF(lwp) WRITE(numout,*) 52 IF(lwp) WRITE(numout,*) 'tra_isf : Ice shelf heat fluxes' 53 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 54 ENDIF 52 55 ENDIF 53 56 ! … … 76 79 ! 77 80 IF ( ln_isfdebug ) THEN 78 CALL debug('tra_isf: pts(:,:,:,:,Krhs) T', pts(:,:,:,1,Krhs)) 79 CALL debug('tra_isf: pts(:,:,:,:,Krhs) S', pts(:,:,:,2,Krhs)) 81 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 82 CALL debug('tra_isf: pts(:,:,:,:,Krhs) T', pts(:,:,:,1,Krhs)) 83 CALL debug('tra_isf: pts(:,:,:,:,Krhs) S', pts(:,:,:,2,Krhs)) 84 ENDIF 80 85 END IF 81 86 ! … … 101 106 INTEGER :: ji,jj,jk ! loop index 102 107 INTEGER :: ikt, ikb ! top and bottom level of the tbl 103 REAL(wp), DIMENSION( jpi,jpj):: ztc ! total ice shelf tracer trend108 REAL(wp), DIMENSION(A2D(nn_hls)) :: ztc ! total ice shelf tracer trend 104 109 !!---------------------------------------------------------------------- 105 110 ! 106 111 ! compute 2d total trend due to isf 107 ztc(:,:) = 0.5_wp * ( ptsc(:,:,jp_tem) + ptsc_b(:,:,jp_tem) ) / phtbl(:,:) 112 DO_2D( 0, 0, 0, 0 ) 113 ztc(ji,jj) = 0.5_wp * ( ptsc(ji,jj,jp_tem) + ptsc_b(ji,jj,jp_tem) ) / phtbl(ji,jj) 114 END_2D 108 115 ! 109 116 ! update pts(:,:,:,:,Krhs) 110 DO_2D( 1, 1, 1, 1)117 DO_2D( 0, 0, 0, 0 ) 111 118 ! 112 119 ikt = ktop(ji,jj) … … 137 144 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: ptsc 138 145 !!---------------------------------------------------------------------- 139 INTEGER :: j k146 INTEGER :: ji, jj, jk 140 147 !!---------------------------------------------------------------------- 141 148 ! 142 DO jk = 1,jpk 143 ptsa(:,:,jk,jp_tem) = & 144 & ptsa(:,:,jk,jp_tem) + ptsc(:,:,jk,jp_tem) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 145 ptsa(:,:,jk,jp_sal) = & 146 & ptsa(:,:,jk,jp_sal) + ptsc(:,:,jk,jp_sal) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 147 END DO 149 DO_3D( 0, 0, 0, 0, 1, jpk ) 150 ptsa(ji,jj,jk,jp_tem) = ptsa(ji,jj,jk,jp_tem) + ptsc(ji,jj,jk,jp_tem) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 151 ptsa(ji,jj,jk,jp_sal) = ptsa(ji,jj,jk,jp_sal) + ptsc(ji,jj,jk,jp_sal) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 152 END_3D 148 153 ! 149 154 END SUBROUTINE tra_isf_cpl -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traldf.F90
r12377 r14046 17 17 USE oce ! ocean dynamics and tracers 18 18 USE dom_oce ! ocean space and time domain 19 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from tra_ldf_blp, zps_hde*) 20 USE domain, ONLY : dom_tile 19 21 USE phycst ! physical constants 20 22 USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. … … 37 39 PUBLIC tra_ldf ! called by step.F90 38 40 PUBLIC tra_ldf_init ! called by nemogcm.F90 39 41 40 42 !!---------------------------------------------------------------------- 41 43 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 56 58 !! 57 59 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 60 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from tra_ldf_blp, zps_hde*) 61 LOGICAL :: lskip 58 62 !!---------------------------------------------------------------------- 59 63 ! 60 64 IF( ln_timing ) CALL timing_start('tra_ldf') 61 65 ! 66 lskip = .FALSE. 67 62 68 IF( l_trdtra ) THEN !* Save ta and sa trends 63 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 64 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 69 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 70 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 65 71 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 66 72 ENDIF 67 ! 68 SELECT CASE ( nldf_tra ) !* compute lateral mixing trend and add it to the general trend 69 CASE ( np_lap ) ! laplacian: iso-level operator 70 CALL tra_ldf_lap ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) 71 CASE ( np_lap_i ) ! laplacian: standard iso-neutral operator (Madec) 72 CALL tra_ldf_iso ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) 73 CASE ( np_lap_it ) ! laplacian: triad iso-neutral operator (griffies) 74 CALL tra_ldf_triad( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) 75 CASE ( np_blp , np_blp_i , np_blp_it ) ! bilaplacian: iso-level & iso-neutral operators 76 CALL tra_ldf_blp ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, nldf_tra ) 77 END SELECT 78 ! 79 IF( l_trdtra ) THEN !* save the horizontal diffusive trends for further diagnostics 80 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 81 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) 82 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_ldf, ztrdt ) 83 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_ldf, ztrds ) 84 DEALLOCATE( ztrdt, ztrds ) 73 74 ! TEMP: [tiling] These changes not necessary after extra haloes development (lbc_lnk removed from tra_ldf_blp, zps_hde*) 75 IF( nldf_tra == np_blp .OR. nldf_tra == np_blp_i .OR. nldf_tra == np_blp_it ) THEN 76 IF( ln_tile ) THEN 77 IF( ntile == 1 ) THEN 78 CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 79 ELSE 80 lskip = .TRUE. 81 ENDIF 82 ENDIF 83 ENDIF 84 IF( .NOT. lskip ) THEN 85 ! 86 SELECT CASE ( nldf_tra ) !* compute lateral mixing trend and add it to the general trend 87 CASE ( np_lap ) ! laplacian: iso-level operator 88 CALL tra_ldf_lap ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) 89 CASE ( np_lap_i ) ! laplacian: standard iso-neutral operator (Madec) 90 CALL tra_ldf_iso ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) 91 CASE ( np_lap_it ) ! laplacian: triad iso-neutral operator (griffies) 92 CALL tra_ldf_triad( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, 1 ) 93 CASE ( np_blp , np_blp_i , np_blp_it ) ! bilaplacian: iso-level & iso-neutral operators 94 ! NOTE: [tiling-comms-merge] This lbc_lnk is still needed in the zco case, because zps_hde is not called in step 95 IF(nn_hls.EQ.2) CALL lbc_lnk( 'tra_ldf', pts(:,:,:,:,Kbb), 'T',1.) 96 CALL tra_ldf_blp ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, nldf_tra ) 97 END SELECT 98 ! 99 IF( l_trdtra ) THEN !* save the horizontal diffusive trends for further diagnostics 100 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 101 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) 102 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_ldf, ztrdt ) 103 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_ldf, ztrds ) 104 DEALLOCATE( ztrdt, ztrds ) 105 ENDIF 106 107 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from tra_ldf_blp, zps_hde*) 108 IF( ln_tile .AND. ntile == 0 ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 1 ) 85 109 ENDIF 86 110 ! !* print mean trends (used for debugging) 87 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' ldf - Ta: ', mask1=tmask, 111 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' ldf - Ta: ', mask1=tmask, & 88 112 & tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 89 113 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traldf_iso.F90
r13497 r14046 19 19 USE oce ! ocean dynamics and active tracers 20 20 USE dom_oce ! ocean space and time domain 21 USE domutl, ONLY : is_tile 21 22 USE trc_oce ! share passive tracers/Ocean variables 22 23 USE zdf_oce ! ocean vertical physics … … 49 50 CONTAINS 50 51 51 SUBROUTINE tra_ldf_iso( kt, Kmm, kit000, cdtype, pahu, pahv, & 52 & pgu , pgv , pgui, pgvi, & 53 & pt , pt2 , pt_rhs , kjpt , kpass ) 52 SUBROUTINE tra_ldf_iso( kt, Kmm, kit000, cdtype, pahu, pahv, & 53 & pgu , pgv , pgui, pgvi, & 54 & pt, pt2, pt_rhs, kjpt, kpass ) 55 !! 56 INTEGER , INTENT(in ) :: kt ! ocean time-step index 57 INTEGER , INTENT(in ) :: kit000 ! first time step index 58 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 59 INTEGER , INTENT(in ) :: kjpt ! number of tracers 60 INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage 61 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 62 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 63 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 64 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 65 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) 66 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) 67 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend 68 !! 69 CALL tra_ldf_iso_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu), & 70 & pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), & 71 & pt, is_tile(pt), pt2, is_tile(pt2), pt_rhs, is_tile(pt_rhs), kjpt, kpass ) 72 END SUBROUTINE tra_ldf_iso 73 74 75 SUBROUTINE tra_ldf_iso_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah, & 76 & pgu , pgv , ktg , pgui, pgvi, ktgi, & 77 & pt, ktt, pt2, ktt2, pt_rhs, ktt_rhs, kjpt, kpass ) 54 78 !!---------------------------------------------------------------------- 55 79 !! *** ROUTINE tra_ldf_iso *** … … 92 116 !! ** Action : Update pt_rhs arrays with the before rotated diffusion 93 117 !!---------------------------------------------------------------------- 94 INTEGER , INTENT(in ) :: kt ! ocean time-step index 95 INTEGER , INTENT(in ) :: kit000 ! first time step index 96 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 97 INTEGER , INTENT(in ) :: kjpt ! number of tracers 98 INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage 99 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 100 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 101 REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 102 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 103 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) 104 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) 105 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend 118 INTEGER , INTENT(in ) :: kt ! ocean time-step index 119 INTEGER , INTENT(in ) :: kit000 ! first time step index 120 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 121 INTEGER , INTENT(in ) :: kjpt ! number of tracers 122 INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage 123 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 124 INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt2, ktt_rhs 125 REAL(wp), DIMENSION(A2D_T(ktah) ,JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 126 REAL(wp), DIMENSION(A2D_T(ktg) ,KJPT), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 127 REAL(wp), DIMENSION(A2D_T(ktgi) ,KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 128 REAL(wp), DIMENSION(A2D_T(ktt) ,JPK,KJPT), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) 129 REAL(wp), DIMENSION(A2D_T(ktt2) ,JPK,KJPT), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) 130 REAL(wp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend 106 131 ! 107 132 INTEGER :: ji, jj, jk, jn ! dummy loop indices … … 111 136 REAL(wp) :: zmskv, zahv_w, zabe2, zcof2, zcoef4 ! - - 112 137 REAL(wp) :: zcoef0, ze3w_2, zsign ! - - 113 REAL(wp), DIMENSION( jpi,jpj) :: zdkt, zdk1t, z2d114 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zdit, zdjt, zftu, zftv, ztfw138 REAL(wp), DIMENSION(A2D(nn_hls)) :: zdkt, zdk1t, z2d 139 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zdit, zdjt, zftu, zftv, ztfw 115 140 !!---------------------------------------------------------------------- 116 141 ! 117 142 IF( kpass == 1 .AND. kt == kit000 ) THEN 118 IF(lwp) WRITE(numout,*) 119 IF(lwp) WRITE(numout,*) 'tra_ldf_iso : rotated laplacian diffusion operator on ', cdtype 120 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 121 ! 122 akz (:,:,:) = 0._wp 123 ah_wslp2(:,:,:) = 0._wp 143 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 144 IF(lwp) WRITE(numout,*) 145 IF(lwp) WRITE(numout,*) 'tra_ldf_iso : rotated laplacian diffusion operator on ', cdtype 146 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 147 ENDIF 148 ! 149 DO_3D( 0, 0, 0, 0, 1, jpk ) 150 akz (ji,jj,jk) = 0._wp 151 ah_wslp2(ji,jj,jk) = 0._wp 152 END_3D 124 153 ENDIF 125 ! 126 l_hst = .FALSE. 127 l_ptr = .FALSE. 128 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE. 129 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 130 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 154 ! 155 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 156 l_hst = .FALSE. 157 l_ptr = .FALSE. 158 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE. 159 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 160 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 161 ENDIF 131 162 ! 132 163 ! … … 167 198 ! 168 199 IF( ln_traldf_blp ) THEN ! bilaplacian operator 169 DO_3D( 1, 0, 1, 0, 2, jpkm1 )200 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 170 201 akz(ji,jj,jk) = 16._wp & 171 202 & * ah_wslp2 (ji,jj,jk) & … … 175 206 END_3D 176 207 ELSEIF( ln_traldf_lap ) THEN ! laplacian operator 177 DO_3D( 1, 0, 1, 0, 2, jpkm1 )208 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 178 209 ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 179 210 zcoef0 = rDt * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2 ) … … 183 214 ! 184 215 ELSE ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit 185 akz(:,:,:) = ah_wslp2(:,:,:) 216 DO_3D( 0, 0, 0, 0, 1, jpk ) 217 akz(ji,jj,jk) = ah_wslp2(ji,jj,jk) 218 END_3D 186 219 ENDIF 187 220 ENDIF … … 195 228 !!---------------------------------------------------------------------- 196 229 !!gm : bug.... why (x,:,:)? (1,jpj,:) and (jpi,1,:) should be sufficient.... 197 zdit ( 1,:,:) = 0._wp ; zdit (jpi,:,:) = 0._wp198 zdjt ( 1,:,:) = 0._wp ; zdjt (jpi,:,:) = 0._wp230 zdit (ntsi-nn_hls,:,:) = 0._wp ; zdit (ntei+nn_hls,:,:) = 0._wp 231 zdjt (ntsi-nn_hls,:,:) = 0._wp ; zdjt (ntei+nn_hls,:,:) = 0._wp 199 232 !!end 200 233 … … 223 256 DO jk = 1, jpkm1 ! Horizontal slab 224 257 ! 225 ! !== Vertical tracer gradient 226 zdk1t(:,:) = ( pt(:,:,jk,jn) - pt(:,:,jk+1,jn) ) * wmask(:,:,jk+1) ! level jk+1 227 ! 228 IF( jk == 1 ) THEN ; zdkt(:,:) = zdk1t(:,:) ! surface: zdkt(jk=1)=zdkt(jk=2) 229 ELSE ; zdkt(:,:) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * wmask(:,:,jk) 230 ENDIF 258 DO_2D( 1, 1, 1, 1 ) 259 ! !== Vertical tracer gradient 260 zdk1t(ji,jj) = ( pt(ji,jj,jk,jn) - pt(ji,jj,jk+1,jn) ) * wmask(ji,jj,jk+1) ! level jk+1 261 ! 262 IF( jk == 1 ) THEN ; zdkt(ji,jj) = zdk1t(ji,jj) ! surface: zdkt(jk=1)=zdkt(jk=2) 263 ELSE ; zdkt(ji,jj) = ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) * wmask(ji,jj,jk) 264 ENDIF 265 END_2D 266 ! 231 267 DO_2D( 1, 0, 1, 0 ) !== Horizontal fluxes 232 268 zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) … … 330 366 END DO ! end tracer loop 331 367 ! 332 END SUBROUTINE tra_ldf_iso 368 END SUBROUTINE tra_ldf_iso_t 333 369 334 370 !!============================================================================== -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traldf_lap_blp.F90
r13497 r14046 13 13 USE oce ! ocean dynamics and active tracers 14 14 USE dom_oce ! ocean space and time domain 15 USE domutl, ONLY : is_tile 15 16 USE ldftra ! lateral physics: eddy diffusivity 16 17 USE traldf_iso ! iso-neutral lateral diffusion (standard operator) (tra_ldf_iso routine) … … 46 47 CONTAINS 47 48 48 SUBROUTINE tra_ldf_lap( kt, Kmm, kit000, cdtype, pahu, pahv , & 49 & pgu , pgv , pgui, pgvi, & 50 & pt , pt_rhs, kjpt, kpass ) 49 SUBROUTINE tra_ldf_lap( kt, Kmm, kit000, cdtype, pahu, pahv, & 50 & pgu , pgv , pgui, pgvi, & 51 & pt, pt_rhs, kjpt, kpass ) 52 !! 53 INTEGER , INTENT(in ) :: kt ! ocean time-step index 54 INTEGER , INTENT(in ) :: kit000 ! first time step index 55 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 56 INTEGER , INTENT(in ) :: kjpt ! number of tracers 57 INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage 58 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 59 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 60 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 61 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 62 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! before tracer fields 63 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend 64 !! 65 CALL tra_ldf_lap_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu), & 66 & pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), & 67 & pt, is_tile(pt), pt_rhs, is_tile(pt_rhs), kjpt, kpass ) 68 END SUBROUTINE tra_ldf_lap 69 70 71 SUBROUTINE tra_ldf_lap_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah, & 72 & pgu , pgv , ktg , pgui, pgvi, ktgi, & 73 & pt, ktt, pt_rhs, ktt_rhs, kjpt, kpass ) 51 74 !!---------------------------------------------------------------------- 52 75 !! *** ROUTINE tra_ldf_lap *** … … 72 95 INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage 73 96 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 74 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 75 REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 76 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 77 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! before tracer fields 78 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend 79 ! 80 INTEGER :: ji, jj, jk, jn ! dummy loop indices 81 REAL(wp) :: zsign ! local scalars 82 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztu, ztv, zaheeu, zaheev 83 !!---------------------------------------------------------------------- 84 ! 85 IF( kt == nit000 .AND. lwp ) THEN 86 WRITE(numout,*) 87 WRITE(numout,*) 'tra_ldf_lap : iso-level laplacian diffusion on ', cdtype, ', pass=', kpass 88 WRITE(numout,*) '~~~~~~~~~~~ ' 89 ENDIF 90 ! 91 l_hst = .FALSE. 92 l_ptr = .FALSE. 93 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE. 94 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 95 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 97 INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt_rhs 98 REAL(wp), DIMENSION(A2D_T(ktah), JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 99 REAL(wp), DIMENSION(A2D_T(ktg), KJPT), INTENT(in ) :: pgu, pgv ! tracer gradient at pstep levels 100 REAL(wp), DIMENSION(A2D_T(ktgi), KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 101 REAL(wp), DIMENSION(A2D_T(ktt), JPK,KJPT), INTENT(in ) :: pt ! before tracer fields 102 REAL(wp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend 103 ! 104 INTEGER :: ji, jj, jk, jn ! dummy loop indices 105 INTEGER :: isi, iei, isj, iej ! local integers 106 REAL(wp) :: zsign ! local scalars 107 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: ztu, ztv, zaheeu, zaheev 108 !!---------------------------------------------------------------------- 109 ! 110 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 111 IF( kt == nit000 .AND. lwp ) THEN 112 WRITE(numout,*) 113 WRITE(numout,*) 'tra_ldf_lap : iso-level laplacian diffusion on ', cdtype, ', pass=', kpass 114 WRITE(numout,*) '~~~~~~~~~~~ ' 115 ENDIF 116 ! 117 l_hst = .FALSE. 118 l_ptr = .FALSE. 119 IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) ) l_ptr = .TRUE. 120 IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 121 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) ) l_hst = .TRUE. 122 ENDIF 96 123 ! 97 124 ! !== Initialization of metric arrays used for all tracers ==! … … 99 126 ELSE ; zsign = -1._wp 100 127 ENDIF 101 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 128 129 IF( ntsi == Nis0 ) THEN ; isi = nn_hls - 1 ; ELSE ; isi = 0 ; ENDIF ! Avoid double-counting when using tiling 130 IF( ntsj == Njs0 ) THEN ; isj = nn_hls - 1 ; ELSE ; isj = 0 ; ENDIF 131 IF( ntei == Nie0 ) THEN ; iei = nn_hls - 1 ; ELSE ; iei = 0 ; ENDIF 132 IF( ntej == Nje0 ) THEN ; iej = nn_hls - 1 ; ELSE ; iej = 0 ; ENDIF 133 134 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) !== First derivative (gradient) ==! 102 135 zaheeu(ji,jj,jk) = zsign * pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) !!gm * umask(ji,jj,jk) pah masked! 103 136 zaheev(ji,jj,jk) = zsign * pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) !!gm * vmask(ji,jj,jk) … … 108 141 ! ! =========== ! 109 142 ! 110 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== First derivative (gradient) ==!143 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) !== First derivative (gradient) ==! 111 144 ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj ,jk,jn) - pt(ji,jj,jk,jn) ) 112 145 ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( pt(ji ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) 113 146 END_3D 114 147 IF( ln_zps ) THEN ! set gradient at bottom/top ocean level 115 DO_2D( 1, 0, 1, 0) ! bottom148 DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) ! bottom 116 149 ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn) 117 150 ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn) 118 151 END_2D 119 152 IF( ln_isfcav ) THEN ! top in ocean cavities only 120 DO_2D( 1, 0, 1, 0)153 DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) 121 154 IF( miku(ji,jj) > 1 ) ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn) 122 155 IF( mikv(ji,jj) > 1 ) ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn) … … 125 158 ENDIF 126 159 ! 127 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !== Second derivative (divergence) added to the general tracer trends ==! 160 ! NOTE: [tiling-comms-merge] Bounds changed to avoid repeating this calculation for overlapping rows when using tiling 161 DO_3D( isj, iej, isi, iei, 1, jpkm1 ) !== Second derivative (divergence) added to the general tracer trends ==! 128 162 pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & 129 163 & + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) & … … 142 176 ! ! ================== 143 177 ! 144 END SUBROUTINE tra_ldf_lap 178 END SUBROUTINE tra_ldf_lap_t 145 179 146 180 … … 173 207 ! 174 208 INTEGER :: ji, jj, jk, jn ! dummy loop indices 175 REAL(wp), DIMENSION( jpi,jpj,jpk,kjpt) :: zlap ! laplacian at t-point176 REAL(wp), DIMENSION( jpi,jpj, kjpt) :: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points)177 REAL(wp), DIMENSION( jpi,jpj, kjpt) :: zgui, zgvi ! top GRADh of the laplacian (u- and v-points)209 REAL(wp), DIMENSION(A2D(nn_hls),jpk,kjpt) :: zlap ! laplacian at t-point 210 REAL(wp), DIMENSION(A2D(nn_hls), kjpt) :: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points) 211 REAL(wp), DIMENSION(A2D(nn_hls), kjpt) :: zgui, zgvi ! top GRADh of the laplacian (u- and v-points) 178 212 !!--------------------------------------------------------------------- 179 213 ! 180 IF( kt == kit000 .AND. lwp ) THEN 181 WRITE(numout,*) 182 SELECT CASE ( kldf ) 183 CASE ( np_blp ) ; WRITE(numout,*) 'tra_ldf_blp : iso-level bilaplacian operator on ', cdtype 184 CASE ( np_blp_i ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (Standard)' 185 CASE ( np_blp_it ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (triad)' 186 END SELECT 187 WRITE(numout,*) '~~~~~~~~~~~' 214 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 215 IF( kt == kit000 .AND. lwp ) THEN 216 WRITE(numout,*) 217 SELECT CASE ( kldf ) 218 CASE ( np_blp ) ; WRITE(numout,*) 'tra_ldf_blp : iso-level bilaplacian operator on ', cdtype 219 CASE ( np_blp_i ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (Standard)' 220 CASE ( np_blp_it ) ; WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (triad)' 221 END SELECT 222 WRITE(numout,*) '~~~~~~~~~~~' 223 ENDIF 188 224 ENDIF 189 225 … … 200 236 END SELECT 201 237 ! 238 ! NOTE: [tiling-comms-merge] Needed for both nn_hls as tra_ldf_iso and tra_ldf_triad have not yet been adjusted to work with nn_hls = 2. In the zps case the lbc_lnk in zps_hde handles this, but in the zco case zlap always needs this lbc_lnk. I did try adjusting the bounds in tra_ldf_iso and tra_ldf_triad so this lbc_lnk was only needed for nn_hls = 1, but this was not correct and I did not have time to figure out why 202 239 CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1.0_wp ) ! Lateral boundary conditions (unchanged sign) 203 240 ! ! Partial top/bottom cell: GRADh( zlap ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traldf_triad.F90
r13497 r14046 13 13 USE oce ! ocean dynamics and active tracers 14 14 USE dom_oce ! ocean space and time domain 15 ! TEMP: [tiling] This change not necessary if XIOS has subdomain support 16 USE domain, ONLY : dom_tile 17 USE domutl, ONLY : is_tile 15 18 USE phycst ! physical constants 16 19 USE trc_oce ! share passive tracers/Ocean variables … … 33 36 PUBLIC tra_ldf_triad ! routine called by traldf.F90 34 37 35 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zdkt3d !: vertical tracer gradient at 2 levels36 37 38 LOGICAL :: l_ptr ! flag to compute poleward transport 38 39 LOGICAL :: l_hst ! flag to compute heat transport … … 49 50 CONTAINS 50 51 51 SUBROUTINE tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, & 52 & pgu , pgv , pgui, pgvi , & 53 & pt , pt2, pt_rhs, kjpt, kpass ) 52 SUBROUTINE tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, & 53 & pgu , pgv , pgui, pgvi, & 54 & pt, pt2, pt_rhs, kjpt, kpass ) 55 !! 56 INTEGER , INTENT(in ) :: kt ! ocean time-step index 57 INTEGER , INTENT(in ) :: kit000 ! first time step index 58 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 59 INTEGER , INTENT(in ) :: kjpt ! number of tracers 60 INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage 61 INTEGER , INTENT(in ) :: Kmm ! ocean time level indices 62 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 63 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels 64 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 65 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) 66 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) 67 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pt_rhs ! tracer trend 68 !! 69 CALL tra_ldf_triad_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu), & 70 & pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), & 71 & pt, is_tile(pt), pt2, is_tile(pt2), pt_rhs, is_tile(pt_rhs), kjpt, kpass ) 72 END SUBROUTINE tra_ldf_triad 73 74 75 SUBROUTINE tra_ldf_triad_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah, & 76 & pgu , pgv , ktg , pgui, pgvi, ktgi, & 77 & pt, ktt, pt2, ktt2, pt_rhs, ktt_rhs, kjpt, kpass ) 54 78 !!---------------------------------------------------------------------- 55 79 !! *** ROUTINE tra_ldf_triad *** … … 77 101 INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage 78 102 INTEGER , INTENT(in) :: Kmm ! ocean time level indices 79 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 80 REAL(wp), DIMENSION(jpi,jpj ,kjpt), INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels 81 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 82 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) 83 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) 84 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pt_rhs ! tracer trend 103 INTEGER , INTENT(in ) :: ktah, ktg, ktgi, ktt, ktt2, ktt_rhs 104 REAL(wp), DIMENSION(A2D_T(ktah), JPK) , INTENT(in ) :: pahu, pahv ! eddy diffusivity at u- and v-points [m2/s] 105 REAL(wp), DIMENSION(A2D_T(ktg), KJPT), INTENT(in ) :: pgu , pgv ! tracer gradient at pstep levels 106 REAL(wp), DIMENSION(A2D_T(ktgi), KJPT), INTENT(in ) :: pgui, pgvi ! tracer gradient at top levels 107 REAL(wp), DIMENSION(A2D_T(ktt), JPK,KJPT), INTENT(in ) :: pt ! tracer (kpass=1) or laplacian of tracer (kpass=2) 108 REAL(wp), DIMENSION(A2D_T(ktt2), JPK,KJPT), INTENT(in ) :: pt2 ! tracer (only used in kpass=2) 109 REAL(wp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) :: pt_rhs ! tracer trend 85 110 ! 86 111 INTEGER :: ji, jj, jk, jn ! dummy loop indices … … 94 119 REAL(wp) :: ze1ur, ze2vr, ze3wr, zdxt, zdyt, zdzt 95 120 REAL(wp) :: zah, zah_slp, zaei_slp 96 REAL(wp), DIMENSION(jpi,jpj ) :: z2d ! 2D workspace 97 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ! 3D - 121 REAL(wp), DIMENSION(A2D(nn_hls),0:1) :: zdkt3d ! vertical tracer gradient at 2 levels 122 REAL(wp), DIMENSION(A2D(nn_hls) ) :: z2d ! 2D workspace 123 REAL(wp), DIMENSION(A2D(nn_hls) ,jpk) :: zdit, zdjt, zftu, zftv, ztfw ! 3D - 124 ! TEMP: [tiling] This can be A2D(nn_hls) if XIOS has subdomain support 125 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw 98 126 !!---------------------------------------------------------------------- 99 127 ! 100 IF( .NOT.ALLOCATED(zdkt3d) ) THEN 101 ALLOCATE( zdkt3d(jpi,jpj,0:1) , STAT=ierr ) 102 CALL mpp_sum ( 'traldf_triad', ierr ) 103 IF( ierr > 0 ) CALL ctl_stop('STOP', 'tra_ldf_triad: unable to allocate arrays') 104 ENDIF 105 ! 106 IF( kpass == 1 .AND. kt == kit000 ) THEN 107 IF(lwp) WRITE(numout,*) 108 IF(lwp) WRITE(numout,*) 'tra_ldf_triad : rotated laplacian diffusion operator on ', cdtype 109 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' 110 ENDIF 111 ! 112 l_hst = .FALSE. 113 l_ptr = .FALSE. 114 IF( cdtype == 'TRA' ) THEN 115 IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf') ) l_ptr = .TRUE. 116 IF( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 117 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) l_hst = .TRUE. 128 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 129 IF( kpass == 1 .AND. kt == kit000 ) THEN 130 IF(lwp) WRITE(numout,*) 131 IF(lwp) WRITE(numout,*) 'tra_ldf_triad : rotated laplacian diffusion operator on ', cdtype 132 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' 133 ENDIF 134 ! 135 l_hst = .FALSE. 136 l_ptr = .FALSE. 137 IF( cdtype == 'TRA' ) THEN 138 IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf') ) l_ptr = .TRUE. 139 IF( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 140 & iom_use("uadv_salttr") .OR. iom_use("vadv_salttr") ) l_hst = .TRUE. 141 ENDIF 118 142 ENDIF 119 143 ! … … 128 152 IF( kpass == 1 ) THEN !== first pass only and whatever the tracer is ==! 129 153 ! 130 akz (:,:,:) = 0._wp 131 ah_wslp2(:,:,:) = 0._wp 132 IF( ln_ldfeiv_dia ) THEN 133 zpsi_uw(:,:,:) = 0._wp 134 zpsi_vw(:,:,:) = 0._wp 135 ENDIF 154 DO_3D( 0, 0, 0, 0, 1, jpk ) 155 akz (ji,jj,jk) = 0._wp 156 ah_wslp2(ji,jj,jk) = 0._wp 157 END_3D 136 158 ! 137 159 DO ip = 0, 1 ! i-k triads 138 160 DO kp = 0, 1 139 DO_3D( 1, 0, 1, 0, 1, jpkm1 )140 ze3wr = 1._wp / e3w(ji +ip,jj,jk+kp,Kmm)141 zbu = e1e2u(ji ,jj) * e3u(ji,jj,jk,Kmm)142 zah = 0.25_wp * pahu(ji ,jj,jk)143 zslope_skew = triadi_g(ji +ip,jj,jk,1-ip,kp)161 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 162 ze3wr = 1._wp / e3w(ji,jj,jk+kp,Kmm) 163 zbu = e1e2u(ji-ip,jj) * e3u(ji-ip,jj,jk,Kmm) 164 zah = 0.25_wp * pahu(ji-ip,jj,jk) 165 zslope_skew = triadi_g(ji,jj,jk,1-ip,kp) 144 166 ! Subtract s-coordinate slope at t-points to give slope rel to s-surfaces (do this by *adding* gradient of depth) 145 zslope2 = zslope_skew + ( gdept(ji +1,jj,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e1u(ji,jj) * umask(ji,jj,jk+kp)167 zslope2 = zslope_skew + ( gdept(ji-ip+1,jj,jk,Kmm) - gdept(ji-ip,jj,jk,Kmm) ) * r1_e1u(ji-ip,jj) * umask(ji-ip,jj,jk+kp) 146 168 zslope2 = zslope2 *zslope2 147 ah_wslp2(ji +ip,jj,jk+kp) = ah_wslp2(ji+ip,jj,jk+kp) + zah * zbu * ze3wr * r1_e1e2t(ji+ip,jj) * zslope2148 akz (ji +ip,jj,jk+kp) = akz (ji+ip,jj,jk+kp) + zah * r1_e1u(ji,jj) &149 & * r1_e1u(ji ,jj) * umask(ji,jj,jk+kp)169 ah_wslp2(ji,jj,jk+kp) = ah_wslp2(ji,jj,jk+kp) + zah * zbu * ze3wr * r1_e1e2t(ji,jj) * zslope2 170 akz (ji,jj,jk+kp) = akz (ji,jj,jk+kp) + zah * r1_e1u(ji-ip,jj) & 171 & * r1_e1u(ji-ip,jj) * umask(ji-ip,jj,jk+kp) 150 172 ! 151 IF( ln_ldfeiv_dia ) zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp) &152 & + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * zslope_skew153 173 END_3D 154 174 END DO … … 157 177 DO jp = 0, 1 ! j-k triads 158 178 DO kp = 0, 1 159 DO_3D( 1, 0, 1, 0, 1, jpkm1 )160 ze3wr = 1.0_wp / e3w(ji,jj +jp,jk+kp,Kmm)161 zbv = e1e2v(ji,jj ) * e3v(ji,jj,jk,Kmm)162 zah = 0.25_wp * pahv(ji,jj ,jk)163 zslope_skew = triadj_g(ji,jj +jp,jk,1-jp,kp)179 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 180 ze3wr = 1.0_wp / e3w(ji,jj,jk+kp,Kmm) 181 zbv = e1e2v(ji,jj-jp) * e3v(ji,jj-jp,jk,Kmm) 182 zah = 0.25_wp * pahv(ji,jj-jp,jk) 183 zslope_skew = triadj_g(ji,jj,jk,1-jp,kp) 164 184 ! Subtract s-coordinate slope at t-points to give slope rel to s surfaces 165 185 ! (do this by *adding* gradient of depth) 166 zslope2 = zslope_skew + ( gdept(ji,jj +1,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp)186 zslope2 = zslope_skew + ( gdept(ji,jj-jp+1,jk,Kmm) - gdept(ji,jj-jp,jk,Kmm) ) * r1_e2v(ji,jj-jp) * vmask(ji,jj-jp,jk+kp) 167 187 zslope2 = zslope2 * zslope2 168 ah_wslp2(ji,jj +jp,jk+kp) = ah_wslp2(ji,jj+jp,jk+kp) + zah * zbv * ze3wr * r1_e1e2t(ji,jj+jp) * zslope2169 akz (ji,jj +jp,jk+kp) = akz (ji,jj+jp,jk+kp) + zah * r1_e2v(ji,jj) &170 & * r1_e2v(ji,jj ) * vmask(ji,jj,jk+kp)188 ah_wslp2(ji,jj,jk+kp) = ah_wslp2(ji,jj,jk+kp) + zah * zbv * ze3wr * r1_e1e2t(ji,jj) * zslope2 189 akz (ji,jj,jk+kp) = akz (ji,jj,jk+kp) + zah * r1_e2v(ji,jj-jp) & 190 & * r1_e2v(ji,jj-jp) * vmask(ji,jj-jp,jk+kp) 171 191 ! 172 IF( ln_ldfeiv_dia ) zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp) &173 & + 0.25 * aeiv(ji,jj,jk) * e1v(ji,jj) * zslope_skew174 192 END_3D 175 193 END DO … … 179 197 ! 180 198 IF( ln_traldf_blp ) THEN ! bilaplacian operator 181 DO_3D( 1, 0, 1, 0, 2, jpkm1 )199 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 182 200 akz(ji,jj,jk) = 16._wp & 183 201 & * ah_wslp2 (ji,jj,jk) & … … 187 205 END_3D 188 206 ELSEIF( ln_traldf_lap ) THEN ! laplacian operator 189 DO_3D( 1, 0, 1, 0, 2, jpkm1 )207 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 190 208 ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 191 209 zcoef0 = rDt * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2 ) … … 195 213 ! 196 214 ELSE ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit 197 akz(:,:,:) = ah_wslp2(:,:,:) 198 ENDIF 199 ! 200 IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' ) CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) 215 DO_3D( 0, 0, 0, 0, 1, jpk ) 216 akz(ji,jj,jk) = ah_wslp2(ji,jj,jk) 217 END_3D 218 ENDIF 219 ! 220 ! TEMP: [tiling] These changes not necessary if XIOS has subdomain support 221 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 222 IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' ) THEN 223 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 224 225 zpsi_uw(:,:,:) = 0._wp 226 zpsi_vw(:,:,:) = 0._wp 227 228 DO jp = 0, 1 229 DO kp = 0, 1 230 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 231 zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp) & 232 & + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * triadi_g(ji+jp,jj,jk,1-jp,kp) 233 zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp) & 234 & + 0.25_wp * aeiv(ji,jj,jk) * e1v(ji,jj) * triadj_g(ji,jj+jp,jk,1-jp,kp) 235 END_3D 236 END DO 237 END DO 238 CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) 239 240 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = nijtile ) 241 ENDIF 242 ENDIF 201 243 ! 202 244 ENDIF !== end 1st pass only ==! … … 234 276 DO jk = 1, jpkm1 235 277 ! !== Vertical tracer gradient at level jk and jk+1 236 zdkt3d(:,:,1) = ( pt(:,:,jk,jn) - pt(:,:,jk+1,jn) ) * tmask(:,:,jk+1) 278 DO_2D( 1, 1, 1, 1 ) 279 zdkt3d(ji,jj,1) = ( pt(ji,jj,jk,jn) - pt(ji,jj,jk+1,jn) ) * tmask(ji,jj,jk+1) 280 END_2D 237 281 ! 238 282 ! ! surface boundary condition: zdkt3d(jk=0)=zdkt3d(jk=1) 239 283 IF( jk == 1 ) THEN ; zdkt3d(:,:,0) = zdkt3d(:,:,1) 240 ELSE ; zdkt3d(:,:,0) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * tmask(:,:,jk) 284 ELSE 285 DO_2D( 1, 1, 1, 1 ) 286 zdkt3d(ji,jj,0) = ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 287 END_2D 241 288 ENDIF 242 289 ! … … 380 427 END DO ! end tracer loop 381 428 ! ! =============== 382 END SUBROUTINE tra_ldf_triad 429 END SUBROUTINE tra_ldf_triad_t 383 430 384 431 !!============================================================================== -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/tramle.F90
r13497 r14046 79 79 !! Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 80 80 !!---------------------------------------------------------------------- 81 INTEGER 82 INTEGER 83 INTEGER 84 CHARACTER(len=3) 85 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: pu ! in : 3 ocean transport components86 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: pv ! out: same 3 transport components87 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(inout) :: pw ! increased by the MLE induced transport81 INTEGER , INTENT(in ) :: kt ! ocean time-step index 82 INTEGER , INTENT(in ) :: kit000 ! first time step index 83 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 84 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 85 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: pu ! in : 3 ocean transport components 86 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: pv ! out: same 3 transport components 87 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) :: pw ! increased by the MLE induced transport 88 88 ! 89 89 INTEGER :: ji, jj, jk ! dummy loop indices … … 91 91 REAL(wp) :: zcuw, zmuw, zc ! local scalar 92 92 REAL(wp) :: zcvw, zmvw ! - - 93 INTEGER , DIMENSION(jpi,jpj) :: inml_mle 94 REAL(wp), DIMENSION(jpi,jpj) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH 95 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw 93 INTEGER , DIMENSION(A2D(nn_hls)) :: inml_mle 94 REAL(wp), DIMENSION(A2D(nn_hls)) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_MH 95 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw 96 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 97 REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: zLf_NH 98 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zpsiu_mle, zpsiv_mle 96 99 !!---------------------------------------------------------------------- 97 100 ! 98 101 ! !== MLD used for MLE ==! 99 102 ! ! compute from the 10m density to deal with the diurnal cycle 100 inml_mle(:,:) = mbkt(:,:) + 1 ! init. to number of ocean w-level (T-level + 1) 103 DO_2D( 1, 1, 1, 1 ) 104 inml_mle(ji,jj) = mbkt(ji,jj) + 1 ! init. to number of ocean w-level (T-level + 1) 105 END_2D 101 106 IF ( nla10 > 0 ) THEN ! avoid case where first level is thicker than 10m 102 107 DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) ! from the bottom to nlb10 (10m) … … 135 140 END SELECT 136 141 ! ! convert density into buoyancy 137 zbm(:,:) = + grav * zbm(:,:) / MAX( e3t(:,:,1,Kmm), zmld(:,:) ) 142 DO_2D( 1, 1, 1, 1 ) 143 zbm(ji,jj) = + grav * zbm(ji,jj) / MAX( e3t(ji,jj,1,Kmm), zmld(ji,jj) ) 144 END_2D 138 145 ! 139 146 ! … … 206 213 END DO 207 214 215 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 208 216 IF( cdtype == 'TRA') THEN !== outputs ==! 209 ! 210 zLf_NH(:,:) = SQRT( rb_c * zmld(:,:) ) * r1_ft(:,:) ! Lf = N H / f 211 CALL iom_put( "Lf_NHpf" , zLf_NH ) ! Lf = N H / f 217 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 218 ALLOCATE( zLf_NH(jpi,jpj), zpsiu_mle(jpi,jpj,jpk), zpsiv_mle(jpi,jpj,jpk) ) 219 zpsiu_mle(:,:,:) = 0._wp ; zpsiv_mle(:,:,:) = 0._wp 220 ENDIF 221 ! 222 DO_2D( 0, 0, 0, 0 ) 223 zLf_NH(ji,jj) = SQRT( rb_c * zmld(ji,jj) ) * r1_ft(ji,jj) ! Lf = N H / f 224 END_2D 212 225 ! 213 226 ! divide by cross distance to give streamfunction with dimensions m^2/s 214 DO jk = 1, ikmax+1 215 zpsi_uw(:,:,jk) = zpsi_uw(:,:,jk) * r1_e2u(:,:) 216 zpsi_vw(:,:,jk) = zpsi_vw(:,:,jk) * r1_e1v(:,:) 217 END DO 218 CALL iom_put( "psiu_mle", zpsi_uw ) ! i-mle streamfunction 219 CALL iom_put( "psiv_mle", zpsi_vw ) ! j-mle streamfunction 227 DO_3D( 0, 0, 0, 0, 1, ikmax+1 ) 228 zpsiu_mle(ji,jj,jk) = zpsi_uw(ji,jj,jk) * r1_e2u(ji,jj) 229 zpsiv_mle(ji,jj,jk) = zpsi_vw(ji,jj,jk) * r1_e1v(ji,jj) 230 END_3D 231 232 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 233 CALL iom_put( "Lf_NHpf" , zLf_NH ) ! Lf = N H / f 234 CALL iom_put( "psiu_mle", zpsiu_mle ) ! i-mle streamfunction 235 CALL iom_put( "psiv_mle", zpsiv_mle ) ! j-mle streamfunction 236 DEALLOCATE( zLf_NH, zpsiu_mle, zpsiv_mle ) 237 ENDIF 220 238 ENDIF 221 239 ! … … 283 301 IF( ierr /= 0 ) CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' ) 284 302 z1_t2 = 1._wp / ( rn_time * rn_time ) 285 DO_2D( 0, 1, 0, 1) ! "coriolis+ time^-1" at u- & v-points303 DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls ) ! "coriolis+ time^-1" at u- & v-points 286 304 zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp 287 305 zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp … … 289 307 rfv(ji,jj) = SQRT( zfv * zfv + z1_t2 ) 290 308 END_2D 291 CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp )309 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) 292 310 ! 293 311 ELSEIF( nn_mle == 1 ) THEN ! MLE array allocation & initialisation -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/tranpc.F90
r13497 r14046 17 17 USE oce ! ocean dynamics and active tracers 18 18 USE dom_oce ! ocean space and time domain 19 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed) 20 USE domain, ONLY : dom_tile 19 21 USE phycst ! physical constants 20 22 USE zdf_oce ! ocean vertical physics … … 32 34 33 35 PUBLIC tra_npc ! routine called by step.F90 36 37 INTEGER :: nnpcc ! number of statically instable water column 34 38 35 39 !! * Substitutions … … 64 68 ! 65 69 INTEGER :: ji, jj, jk ! dummy loop indices 66 INTEGER :: inpcc ! number of statically instable water column67 70 INTEGER :: jiter, ikbot, ikp, ikup, ikdown, ilayer, ik_low ! local integers 68 71 LOGICAL :: l_bottom_reached, l_column_treated … … 70 73 REAL(wp) :: zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_rDt 71 74 REAL(wp), PARAMETER :: zn2_zero = 1.e-14_wp ! acceptance criteria for neutrality (N2==0) 72 REAL(wp), DIMENSION( jpk ) :: zvn2! vertical profile of N2 at 1 given point...73 REAL(wp), DIMENSION( jpk,jpts) :: zvts, zvab! vertical profile of T & S , and alpha & betaat 1 given point74 REAL(wp), DIMENSION( jpi,jpj,jpk ) :: zn2 ! N^275 REAL(wp), DIMENSION( jpi,jpj,jpk,jpts) :: zab! alpha and beta75 REAL(wp), DIMENSION( jpk ) :: zvn2 ! vertical profile of N2 at 1 given point... 76 REAL(wp), DIMENSION( jpk,jpts) :: zvts, zvab ! vertical profile of T & S , and alpha & betaat 1 given point 77 REAL(wp), DIMENSION(A2D(nn_hls),jpk ) :: zn2 ! N^2 78 REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts) :: zab ! alpha and beta 76 79 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace 77 80 ! 78 81 LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is 79 82 INTEGER :: ilc1, jlc1, klc1, nncpu ! actually happening in a water column at point "ilc1, jlc1" 83 INTEGER :: isi, isj, iei, iej 80 84 LOGICAL :: lp_monitor_point = .FALSE. ! in CPU domain "nncpu" 81 85 !!---------------------------------------------------------------------- … … 87 91 IF( l_trdtra ) THEN !* Save initial after fields 88 92 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 89 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 93 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 90 94 ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) 91 95 ENDIF … … 101 105 CALL bn2 ( pts(:,:,:,:,Kaa), zab, zn2, Kmm ) ! after Brunt-Vaisala (given on W-points) 102 106 ! 103 inpcc = 0 104 ! 105 DO_2D( 0, 0, 0, 0 ) ! interior column only 107 IF( ntile == 0 .OR. ntile == 1 ) nnpcc = 0 ! Do only on the first tile 108 ! 109 IF( ntsi == Nis0 ) THEN ; isi = nn_hls ; ELSE ; isi = 0 ; ENDIF ! Avoid double-counting when using tiling 110 IF( ntsj == Njs0 ) THEN ; isj = nn_hls ; ELSE ; isj = 0 ; ENDIF 111 IF( ntei == Nie0 ) THEN ; iei = nn_hls ; ELSE ; iei = 0 ; ENDIF 112 IF( ntej == Nje0 ) THEN ; iej = nn_hls ; ELSE ; iej = 0 ; ENDIF 113 ! 114 ! NOTE: [tiling-comms-merge] Bounds changed to avoid repeating this calculation for overlapping rows when using tiling 115 DO_2D( isj, iej, isi, iei ) ! interior column only 106 116 ! 107 117 IF( tmask(ji,jj,2) == 1 ) THEN ! At least 2 ocean points … … 160 170 ENDIF 161 171 ! 162 IF( jiter == 1 ) inpcc = inpcc + 1172 IF( jiter == 1 ) nnpcc = nnpcc + 1 163 173 ! 164 174 IF( lp_monitor_point ) WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer … … 310 320 ENDIF 311 321 ! 312 CALL lbc_lnk_multi( 'tranpc', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp )313 !314 IF( lwp .AND. l_LB_debug ) THEN315 WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', inpcc316 WRITE(numout,*)322 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 323 IF( lwp .AND. l_LB_debug ) THEN 324 WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', nnpcc 325 WRITE(numout,*) 326 ENDIF 317 327 ENDIF 318 328 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/traqsr.F90
r13497 r14046 22 22 USE phycst ! physical constants 23 23 USE dom_oce ! ocean space and time domain 24 USE domain, ONLY : dom_tile 24 25 USE sbc_oce ! surface boundary condition: ocean 25 26 USE trc_oce ! share SMS/Ocean variables … … 107 108 ! 108 109 INTEGER :: ji, jj, jk ! dummy loop indices 109 INTEGER :: irgb 110 INTEGER :: irgb, isi, iei, isj, iej ! local integers 110 111 REAL(wp) :: zchl, zcoef, z1_2 ! local scalars 111 112 REAL(wp) :: zc0 , zc1 , zc2 , zc3 ! - - … … 120 121 IF( ln_timing ) CALL timing_start('tra_qsr') 121 122 ! 122 IF( kt == nit000 ) THEN 123 IF(lwp) WRITE(numout,*) 124 IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation' 125 IF(lwp) WRITE(numout,*) '~~~~~~~' 123 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 124 IF( kt == nit000 ) THEN 125 IF(lwp) WRITE(numout,*) 126 IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation' 127 IF(lwp) WRITE(numout,*) '~~~~~~~' 128 ENDIF 126 129 ENDIF 127 130 ! 128 131 IF( l_trdtra ) THEN ! trends diagnostic: save the input temperature trend 129 ALLOCATE( ztrdt(jpi,jpj,jpk) ) 132 ALLOCATE( ztrdt(jpi,jpj,jpk) ) 130 133 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 131 134 ENDIF … … 134 137 ! ! before qsr induced heat content ! 135 138 ! !-----------------------------------! 139 ! NOTE: [tiling-comms-merge] Many DO loop bounds changed (probably more than necessary) to avoid changing results when using tiling. Some bounds were also adjusted to account for those changed in tra_atf 140 IF( ntsi == Nis0 ) THEN ; isi = nn_hls ; ELSE ; isi = 0 ; ENDIF ! Avoid double-counting when using tiling 141 IF( ntsj == Njs0 ) THEN ; isj = nn_hls ; ELSE ; isj = 0 ; ENDIF 142 IF( ntei == Nie0 ) THEN ; iei = nn_hls ; ELSE ; iei = 0 ; ENDIF 143 IF( ntej == Nje0 ) THEN ; iej = nn_hls ; ELSE ; iej = 0 ; ENDIF 144 136 145 IF( kt == nit000 ) THEN !== 1st time step ==! 137 146 IF( ln_rstart .AND. iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 .AND. .NOT.l_1st_euler ) THEN ! read in restart 138 IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field read in the restart file'139 147 z1_2 = 0.5_wp 140 CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b, ldxios = lrxios ) ! before heat content trend due to Qsr flux 148 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 149 IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field read in the restart file' 150 CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b ) ! before heat content trend due to Qsr flux 151 ENDIF 141 152 ELSE ! No restart or restart not found: Euler forward time stepping 142 153 z1_2 = 1._wp 143 qsr_hc_b(:,:,:) = 0._wp 154 DO_3D( isj, iej, isi, iei, 1, jpk ) 155 qsr_hc_b(ji,jj,jk) = 0._wp 156 END_3D 144 157 ENDIF 145 158 ELSE !== Swap of qsr heat content ==! 146 159 z1_2 = 0.5_wp 147 qsr_hc_b(:,:,:) = qsr_hc(:,:,:) 160 DO_3D( isj, iej, isi, iei, 1, jpk ) 161 qsr_hc_b(ji,jj,jk) = qsr_hc(ji,jj,jk) 162 END_3D 148 163 ENDIF 149 164 ! … … 154 169 CASE( np_BIO ) !== bio-model fluxes ==! 155 170 ! 156 DO jk = 1, nksr157 qsr_hc( :,:,jk) = r1_rho0_rcp * ( etot3(:,:,jk) - etot3(:,:,jk+1) )158 END DO171 DO_3D( isj, iej, isi, iei, 1, nksr ) 172 qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( etot3(ji,jj,jk) - etot3(ji,jj,jk+1) ) 173 END_3D 159 174 ! 160 175 CASE( np_RGB , np_RGBc ) !== R-G-B fluxes ==! 161 176 ! 162 ALLOCATE( ze0 ( jpi,jpj) , ze1 (jpi,jpj) , &163 & ze2 ( jpi,jpj) , ze3 (jpi,jpj) , &164 & ztmp3d( jpi,jpj,nksr + 1) )177 ALLOCATE( ze0 (A2D(nn_hls)) , ze1 (A2D(nn_hls)) , & 178 & ze2 (A2D(nn_hls)) , ze3 (A2D(nn_hls)) , & 179 & ztmp3d(A2D(nn_hls),nksr + 1) ) 165 180 ! 166 181 IF( nqsr == np_RGBc ) THEN !* Variable Chlorophyll 167 CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step 182 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only for the full domain 183 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Use full domain 184 CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step 185 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 1 ) ! Revert to tile domain 186 ENDIF 168 187 ! 169 188 ! Separation in R-G-B depending on the surface Chl … … 172 191 ! most expensive calculations) 173 192 ! 174 DO_2D( 0, 0, 0, 0)193 DO_2D( isj, iej, isi, iei ) 175 194 ! zlogc = log(zchl) 176 195 zlogc = LOG ( MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) ) … … 191 210 192 211 ! 193 DO_3D( 0, 0, 0, 0, 1, nksr + 1 )212 DO_3D( isj, iej, isi, iei, 1, nksr + 1 ) 194 213 ! zchl = ALOG( ze0(ji,jj) ) 195 214 zlogc = ze0(ji,jj) … … 216 235 zlui = 41 + 20.*LOG10(zchl) + 1.e-15 217 236 DO jk = 1, nksr + 1 218 ztmp3d(:,:,jk) = zlui 237 ztmp3d(:,:,jk) = zlui 219 238 END DO 220 239 ENDIF 221 240 ! 222 241 zcoef = ( 1. - rn_abs ) / 3._wp !* surface equi-partition in R-G-B 223 DO_2D( 0, 0, 0, 0)242 DO_2D( isj, iej, isi, iei ) 224 243 ze0(ji,jj) = rn_abs * qsr(ji,jj) 225 244 ze1(ji,jj) = zcoef * qsr(ji,jj) … … 232 251 ! 233 252 ! !* interior equi-partition in R-G-B depending on vertical profile of Chl 234 DO_3D( 0, 0, 0, 0, 2, nksr + 1 )253 DO_3D( isj, iej, isi, iei, 2, nksr + 1 ) 235 254 ze3t = e3t(ji,jj,jk-1,Kmm) 236 255 irgb = NINT( ztmp3d(ji,jj,jk) ) … … 246 265 END_3D 247 266 ! 248 DO_3D( 0, 0, 0, 0, 1, nksr ) !* now qsr induced heat content267 DO_3D( isj, iej, isi, iei, 1, nksr ) !* now qsr induced heat content 249 268 qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( ztmp3d(ji,jj,jk) - ztmp3d(ji,jj,jk+1) ) 250 269 END_3D … … 256 275 zz0 = rn_abs * r1_rho0_rcp ! surface equi-partition in 2-bands 257 276 zz1 = ( 1. - rn_abs ) * r1_rho0_rcp 258 DO_3D( 0, 0, 0, 0, 1, nksr ) ! solar heat absorbed at T-point in the top 400m277 DO_3D( isj, iej, isi, iei, 1, nksr ) !* now qsr induced heat content 259 278 zc0 = zz0 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk ,Kmm)*xsi1r ) 260 279 zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r ) … … 274 293 ! 275 294 ! sea-ice: store the 1st ocean level attenuation coefficient 276 DO_2D( 0, 0, 0, 0)295 DO_2D( isj, iej, isi, iei ) 277 296 IF( qsr(ji,jj) /= 0._wp ) THEN ; fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rho0_rcp * qsr(ji,jj) ) 278 297 ELSE ; fraqsr_1lev(ji,jj) = 1._wp 279 298 ENDIF 280 299 END_2D 281 CALL lbc_lnk( 'traqsr', fraqsr_1lev(:,:), 'T', 1._wp ) 282 ! 283 IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution 284 ALLOCATE( zetot(jpi,jpj,jpk) ) 285 zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero 286 DO jk = nksr, 1, -1 287 zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rho0_rcp 288 END DO 289 CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation 290 DEALLOCATE( zetot ) 291 ENDIF 292 ! 293 IF( lrst_oce ) THEN ! write in the ocean restart file 294 IF( lwxios ) CALL iom_swap( cwxios_context ) 295 CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b' , qsr_hc , ldxios = lwxios ) 296 CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev, ldxios = lwxios ) 297 IF( lwxios ) CALL iom_swap( cxios_context ) 300 ! 301 ! TEMP: [tiling] This change not necessary and working array can use A2D(nn_hls) if using XIOS (subdomain support) 302 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only for the full domain 303 IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution 304 ALLOCATE( zetot(jpi,jpj,jpk) ) 305 zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero 306 DO jk = nksr, 1, -1 307 zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rho0_rcp 308 END DO 309 CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation 310 DEALLOCATE( zetot ) 311 ENDIF 312 ENDIF 313 ! 314 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 315 IF( lrst_oce ) THEN ! write in the ocean restart file 316 CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b' , qsr_hc ) 317 CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev ) 318 ENDIF 298 319 ENDIF 299 320 ! … … 301 322 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 302 323 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_qsr, ztrdt ) 303 DEALLOCATE( ztrdt ) 324 DEALLOCATE( ztrdt ) 304 325 ENDIF 305 326 ! ! print mean trends (used for debugging) … … 431 452 ! 1st ocean level attenuation coefficient (used in sbcssm) 432 453 IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN 433 CALL iom_get( numror, jpdom_auto, 'fraqsr_1lev' , fraqsr_1lev , ldxios = lrxios)454 CALL iom_get( numror, jpdom_auto, 'fraqsr_1lev' , fraqsr_1lev ) 434 455 ELSE 435 456 fraqsr_1lev(:,:) = 1._wp ! default : no penetration 436 457 ENDIF 437 458 ! 438 IF( lwxios ) THEN439 CALL iom_set_rstw_var_active('qsr_hc_b')440 CALL iom_set_rstw_var_active('fraqsr_1lev')441 ENDIF442 !443 459 END SUBROUTINE tra_qsr_init 444 460 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/trasbc.F90
r13497 r14046 76 76 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 77 77 ! 78 INTEGER :: ji, jj, jk, jn ! dummy loop indices79 INTEGER :: ikt, ikb 80 REAL(wp) :: zfact, z1_e3t, zdep, ztim ! local scalar78 INTEGER :: ji, jj, jk, jn ! dummy loop indices 79 INTEGER :: ikt, ikb, isi, iei, isj, iej ! local integers 80 REAL(wp) :: zfact, z1_e3t, zdep, ztim ! local scalar 81 81 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, ztrds 82 82 !!---------------------------------------------------------------------- … … 84 84 IF( ln_timing ) CALL timing_start('tra_sbc') 85 85 ! 86 IF( kt == nit000 ) THEN 87 IF(lwp) WRITE(numout,*) 88 IF(lwp) WRITE(numout,*) 'tra_sbc : TRAcer Surface Boundary Condition' 89 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 86 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 87 IF( kt == nit000 ) THEN 88 IF(lwp) WRITE(numout,*) 89 IF(lwp) WRITE(numout,*) 'tra_sbc : TRAcer Surface Boundary Condition' 90 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 91 ENDIF 90 92 ENDIF 91 93 ! 92 94 IF( l_trdtra ) THEN !* Save ta and sa trends 93 ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) )95 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 94 96 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 95 97 ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 96 98 ENDIF 97 99 ! 100 ! NOTE: [tiling-comms-merge] Many DO loop bounds changed to avoid changing results when using tiling. Some bounds were also adjusted to account for those changed in tra_atf 101 IF( ntsi == Nis0 ) THEN ; isi = nn_hls ; ELSE ; isi = 0 ; ENDIF ! Avoid double-counting when using tiling 102 IF( ntsj == Njs0 ) THEN ; isj = nn_hls ; ELSE ; isj = 0 ; ENDIF 103 IF( ntei == Nie0 ) THEN ; iei = nn_hls ; ELSE ; iei = 0 ; ENDIF 104 IF( ntej == Nje0 ) THEN ; iej = nn_hls ; ELSE ; iej = 0 ; ENDIF 105 98 106 !!gm This should be moved into sbcmod.F90 module ? (especially now that ln_traqsr is read in namsbc namelist) 99 107 IF( .NOT.ln_traqsr ) THEN ! no solar radiation penetration 100 qns(:,:) = qns(:,:) + qsr(:,:) ! total heat flux in qns 101 qsr(:,:) = 0._wp ! qsr set to zero 108 DO_2D( isj, iej, isi, iei ) 109 qns(ji,jj) = qns(ji,jj) + qsr(ji,jj) ! total heat flux in qns 110 qsr(ji,jj) = 0._wp ! qsr set to zero 111 END_2D 102 112 ENDIF 103 113 … … 109 119 IF( ln_rstart .AND. & ! Restart: read in restart file 110 120 & iom_varid( numror, 'sbc_hc_b', ldstop = .FALSE. ) > 0 ) THEN 111 IF(lwp) WRITE(numout,*) ' nit000-1 sbc tracer content field read in the restart file'112 121 zfact = 0.5_wp 113 sbc_tsc(:,:,:) = 0._wp 114 CALL iom_get( numror, jpdom_auto, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem), ldxios = lrxios ) ! before heat content sbc trend 115 CALL iom_get( numror, jpdom_auto, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal), ldxios = lrxios ) ! before salt content sbc trend 122 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 123 IF(lwp) WRITE(numout,*) ' nit000-1 sbc tracer content field read in the restart file' 124 sbc_tsc(:,:,:) = 0._wp 125 CALL iom_get( numror, jpdom_auto, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem) ) ! before heat content sbc trend 126 CALL iom_get( numror, jpdom_auto, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal) ) ! before salt content sbc trend 127 ENDIF 116 128 ELSE ! No restart or restart not found: Euler forward time stepping 117 129 zfact = 1._wp 118 sbc_tsc(:,:,:) = 0._wp 119 sbc_tsc_b(:,:,:) = 0._wp 130 DO_2D( isj, iej, isi, iei ) 131 sbc_tsc(ji,jj,:) = 0._wp 132 sbc_tsc_b(ji,jj,:) = 0._wp 133 END_2D 120 134 ENDIF 121 135 ELSE !* other time-steps: swap of forcing fields 122 136 zfact = 0.5_wp 123 sbc_tsc_b(:,:,:) = sbc_tsc(:,:,:) 137 DO_2D( isj, iej, isi, iei ) 138 sbc_tsc_b(ji,jj,:) = sbc_tsc(ji,jj,:) 139 END_2D 124 140 ENDIF 125 141 ! !== Now sbc tracer content fields ==! 126 DO_2D( 0, 1, 0, 0)142 DO_2D( isj, iej, isi, iei ) 127 143 sbc_tsc(ji,jj,jp_tem) = r1_rho0_rcp * qns(ji,jj) ! non solar heat flux 128 144 sbc_tsc(ji,jj,jp_sal) = r1_rho0 * sfx(ji,jj) ! salt flux due to freezing/melting 129 145 END_2D 130 146 IF( ln_linssh ) THEN !* linear free surface 131 DO_2D( 0, 1, 0, 0) !==>> add concentration/dilution effect due to constant volume cell147 DO_2D( isj, iej, isi, iei ) !==>> add concentration/dilution effect due to constant volume cell 132 148 sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) 133 149 sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) 134 150 END_2D !==>> output c./d. term 135 IF( iom_use('emp_x_sst') ) CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) 136 IF( iom_use('emp_x_sss') ) CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) 151 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 152 IF( iom_use('emp_x_sst') ) CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) 153 IF( iom_use('emp_x_sss') ) CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) 154 ENDIF 137 155 ENDIF 138 156 ! 139 157 DO jn = 1, jpts !== update tracer trend ==! 140 DO_2D( 0, 1, 0, 0 ) 158 ! NOTE: [tiling-comms-merge] This looped over nn_hls, which changes the results when using tiling 159 DO_2D( 0, 0, 0, 0 ) 141 160 pts(ji,jj,1,jn,Krhs) = pts(ji,jj,1,jn,Krhs) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) & 142 161 & / e3t(ji,jj,1,Kmm) … … 144 163 END DO 145 164 ! 146 IF( lrst_oce ) THEN !== write sbc_tsc in the ocean restart file ==!147 IF( l wxios ) CALL iom_swap( cwxios_context )148 CALL iom_rstput( kt, nitrst, numrow, 'sbc_hc_b', sbc_tsc(:,:,jp_tem), ldxios = lwxios)149 CALL iom_rstput( kt, nitrst, numrow, 'sbc_sc_b', sbc_tsc(:,:,jp_sal), ldxios = lwxios)150 IF( lwxios ) CALL iom_swap( cxios_context )165 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 166 IF( lrst_oce ) THEN !== write sbc_tsc in the ocean restart file ==! 167 CALL iom_rstput( kt, nitrst, numrow, 'sbc_hc_b', sbc_tsc(:,:,jp_tem) ) 168 CALL iom_rstput( kt, nitrst, numrow, 'sbc_sc_b', sbc_tsc(:,:,jp_sal) ) 169 ENDIF 151 170 ENDIF 152 171 ! … … 157 176 IF( ln_rnf ) THEN ! input of heat and salt due to river runoff 158 177 zfact = 0.5_wp 159 DO_2D( 0, 1, 0, 0 )178 DO_2D( 0, 0, 0, 0 ) 160 179 IF( rnf(ji,jj) /= 0._wp ) THEN 161 180 zdep = zfact / h_rnf(ji,jj) … … 170 189 ENDIF 171 190 172 IF( iom_use('rnf_x_sst') ) CALL iom_put( "rnf_x_sst", rnf*pts(:,:,1,jp_tem,Kmm) ) ! runoff term on sst 173 IF( iom_use('rnf_x_sss') ) CALL iom_put( "rnf_x_sss", rnf*pts(:,:,1,jp_sal,Kmm) ) ! runoff term on sss 191 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 192 IF( iom_use('rnf_x_sst') ) CALL iom_put( "rnf_x_sst", rnf*pts(:,:,1,jp_tem,Kmm) ) ! runoff term on sst 193 IF( iom_use('rnf_x_sss') ) CALL iom_put( "rnf_x_sss", rnf*pts(:,:,1,jp_sal,Kmm) ) ! runoff term on sss 194 ENDIF 174 195 175 196 #if defined key_asminc … … 182 203 ! 183 204 IF( ln_linssh ) THEN 184 DO_2D( 0, 1, 0, 0 )205 DO_2D( 0, 0, 0, 0 ) 185 206 ztim = ssh_iau(ji,jj) / e3t(ji,jj,1,Kmm) 186 207 pts(ji,jj,1,jp_tem,Krhs) = pts(ji,jj,1,jp_tem,Krhs) + pts(ji,jj,1,jp_tem,Kmm) * ztim … … 188 209 END_2D 189 210 ELSE 190 DO_2D( 0, 1, 0, 0 )211 DO_2D( 0, 0, 0, 0 ) 191 212 ztim = ssh_iau(ji,jj) / ( ht(ji,jj) + 1. - ssmask(ji, jj) ) 192 213 pts(ji,jj,:,jp_tem,Krhs) = pts(ji,jj,:,jp_tem,Krhs) + pts(ji,jj,:,jp_tem,Kmm) * ztim … … 204 225 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_nsr, ztrdt ) 205 226 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_nsr, ztrds ) 206 DEALLOCATE( ztrdt , ztrds ) 227 DEALLOCATE( ztrdt , ztrds ) 207 228 ENDIF 208 229 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/trazdf.F90
r13497 r14046 13 13 !!---------------------------------------------------------------------- 14 14 USE oce ! ocean dynamics and tracers variables 15 USE dom_oce ! ocean space and time domain variables 15 USE dom_oce ! ocean space and time domain variables 16 16 USE domvvl ! variable volume 17 17 USE phycst ! physical constant 18 18 USE zdf_oce ! ocean vertical physics variables 19 USE zdfmfc ! Mass FLux Convection 19 20 USE sbc_oce ! surface boundary condition: ocean 20 21 USE ldftra ! lateral diffusion: eddy diffusivity … … 55 56 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation 56 57 ! 57 INTEGER :: j k ! Dummy loop indices58 INTEGER :: ji, jj, jk ! Dummy loop indices 58 59 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds ! 3D workspace 59 60 !!--------------------------------------------------------------------- … … 62 63 ! 63 64 IF( kt == nit000 ) THEN 64 IF(lwp)WRITE(numout,*) 65 IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' 66 IF(lwp)WRITE(numout,*) '~~~~~~~ ' 65 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 66 IF(lwp)WRITE(numout,*) 67 IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' 68 IF(lwp)WRITE(numout,*) '~~~~~~~ ' 69 ENDIF 67 70 ENDIF 68 71 ! 69 72 IF( l_trdtra ) THEN !* Save ta and sa trends 70 ALLOCATE( ztrdt(jpi,jpj,jpk) 73 ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 71 74 ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 72 75 ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) … … 80 83 ! JMM avoid negative salinities near river outlet ! Ugly fix 81 84 ! JMM : restore negative salinities to small salinities: 82 WHERE( pts( :,:,:,jp_sal,Kaa) < 0._wp ) pts(:,:,:,jp_sal,Kaa) = 0.1_wp85 WHERE( pts(A2D(0),:,jp_sal,Kaa) < 0._wp ) pts(A2D(0),:,jp_sal,Kaa) = 0.1_wp 83 86 !!gm 84 87 85 88 IF( l_trdtra ) THEN ! save the vertical diffusive trends for further diagnostics 86 DO jk = 1, jpk m189 DO jk = 1, jpk 87 90 ztrdt(:,:,jk) = ( ( pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa) & 88 91 & - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb) ) & … … 94 97 & - ztrds(:,:,jk) 95 98 END DO 99 ! NOTE: [tiling-comms-merge] The diagnostic results change along the north fold if this is removed 96 100 !!gm this should be moved in trdtra.F90 and done on all trends 97 101 CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp ) … … 140 144 INTEGER :: ji, jj, jk, jn ! dummy loop indices 141 145 REAL(wp) :: zrhs, zzwi, zzws ! local scalars 142 REAL(wp), DIMENSION( jpi,jpj,jpk) :: zwi, zwt, zwd, zws146 REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zwi, zwt, zwd, zws 143 147 !!--------------------------------------------------------------------- 144 148 ! … … 154 158 ! 155 159 ! vertical mixing coef.: avt for temperature, avs for salinity and passive tracers 156 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN ; zwt(:,:,2:jpk) = avt(:,:,2:jpk) 157 ELSE ; zwt(:,:,2:jpk) = avs(:,:,2:jpk) 160 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 161 DO_3D( 1, 1, 1, 1, 2, jpk ) 162 zwt(ji,jj,jk) = avt(ji,jj,jk) 163 END_3D 164 ELSE 165 DO_3D( 1, 1, 1, 1, 2, jpk ) 166 zwt(ji,jj,jk) = avs(ji,jj,jk) 167 END_3D 158 168 ENDIF 159 169 zwt(:,:,1) = 0._wp … … 189 199 ENDIF 190 200 ! 201 ! Modification of diagonal to add MF scheme 202 IF ( ln_zdfmfc ) THEN 203 CALL diag_mfc( zwi, zwd, zws, p2dt, Kaa ) 204 END IF 205 ! 191 206 !! Matrix inversion from the first level 192 207 !!---------------------------------------------------------------------- … … 217 232 ENDIF 218 233 ! 234 ! Modification of rhs to add MF scheme 235 IF ( ln_zdfmfc ) THEN 236 CALL rhs_mfc( pt(:,:,:,jn,Krhs), jn ) 237 END IF 238 ! 219 239 DO_2D( 0, 0, 0, 0 ) !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 220 240 pt(ji,jj,1,jn,Kaa) = e3t(ji,jj,1,Kbb) * pt(ji,jj,1,jn,Kbb) & 221 & + p2dt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs) 241 & + p2dt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs) 222 242 END_2D 223 243 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 224 zrhs = e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) & 244 zrhs = e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) & 225 245 & + p2dt * e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk,jn,Krhs) ! zrhs=right hand side 226 246 pt(ji,jj,jk,jn,Kaa) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pt(ji,jj,jk-1,jn,Kaa) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRA/zpshde.F90
r13497 r14046 17 17 USE oce ! ocean: dynamics and tracers variables 18 18 USE dom_oce ! domain: ocean variables 19 USE domutl, ONLY : is_tile 19 20 USE phycst ! physical constants 20 21 USE eosbn2 ! ocean equation of state … … 40 41 CONTAINS 41 42 42 SUBROUTINE zps_hde( kt, Kmm, kjpt, pta, pgtu, pgtv, & 43 & prd, pgru, pgrv ) 43 SUBROUTINE zps_hde( kt, Kmm, kjpt, pta, pgtu, pgtv, & 44 & prd, pgru, pgrv ) 45 !! 46 INTEGER , INTENT(in ) :: kt ! ocean time-step index 47 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 48 INTEGER , INTENT(in ) :: kjpt ! number of tracers 49 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pta ! 4D tracers fields 50 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 51 REAL(wp), DIMENSION(:,:,:) , INTENT(inout), OPTIONAL :: prd ! 3D density anomaly fields 52 REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) 53 ! 54 INTEGER :: itrd, itgr 55 !! 56 IF( PRESENT(prd) ) THEN ; itrd = is_tile(prd) ; ELSE ; itrd = 0 ; ENDIF 57 IF( PRESENT(pgru) ) THEN ; itgr = is_tile(pgru) ; ELSE ; itgr = 0 ; ENDIF 58 59 CALL zps_hde_t( kt, Kmm, kjpt, pta, is_tile(pta), pgtu, pgtv, is_tile(pgtu), & 60 & prd, itrd, pgru, pgrv, itgr ) 61 END SUBROUTINE zps_hde 62 63 64 SUBROUTINE zps_hde_t( kt, Kmm, kjpt, pta, ktta, pgtu, pgtv, ktgt, & 65 & prd, ktrd, pgru, pgrv, ktgr ) 44 66 !!---------------------------------------------------------------------- 45 67 !! *** ROUTINE zps_hde *** … … 85 107 !! - pgru, pgrv: horizontal gradient of rho (if present) at u- & v-points 86 108 !!---------------------------------------------------------------------- 87 INTEGER , INTENT(in ) :: kt ! ocean time-step index 88 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 89 INTEGER , INTENT(in ) :: kjpt ! number of tracers 90 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields 91 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 92 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields 93 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) 109 INTEGER , INTENT(in ) :: kt ! ocean time-step index 110 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 111 INTEGER , INTENT(in ) :: kjpt ! number of tracers 112 INTEGER , INTENT(in ) :: ktta, ktgt, ktrd, ktgr 113 REAL(wp), DIMENSION(A2D_T(ktta),JPK,KJPT), INTENT(inout) :: pta ! 4D tracers fields 114 REAL(wp), DIMENSION(A2D_T(ktgt) ,KJPT), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 115 REAL(wp), DIMENSION(A2D_T(ktrd),JPK ), INTENT(inout), OPTIONAL :: prd ! 3D density anomaly fields 116 REAL(wp), DIMENSION(A2D_T(ktgr) ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) 94 117 ! 95 118 INTEGER :: ji, jj, jn ! Dummy loop indices 96 119 INTEGER :: iku, ikv, ikum1, ikvm1 ! partial step level (ocean bottom level) at u- and v-points 97 120 REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! local scalars 98 REAL(wp), DIMENSION( jpi,jpj) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos99 REAL(wp), DIMENSION( jpi,jpj,kjpt) :: zti, ztj !121 REAL(wp), DIMENSION(A2D(nn_hls)) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos 122 REAL(wp), DIMENSION(A2D(nn_hls),kjpt) :: zti, ztj ! 100 123 !!---------------------------------------------------------------------- 101 124 ! 102 125 IF( ln_timing ) CALL timing_start( 'zps_hde') 126 ! NOTE: [tiling-comms-merge] Some lbc_lnks in tra_adv and tra_ldf can be taken out in the zps case, because this lbc_lnk is called when zps_hde is called in the stp routine. In the zco case they are still needed. 127 IF (nn_hls.EQ.2) THEN 128 CALL lbc_lnk( 'zpshde', pta, 'T', 1.0_wp) 129 IF(PRESENT(prd)) CALL lbc_lnk( 'zpshde', prd, 'T', 1.0_wp) 130 END IF 103 131 ! 104 132 pgtu(:,:,:) = 0._wp ; zti (:,:,:) = 0._wp ; zhi (:,:) = 0._wp … … 107 135 DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! 108 136 ! 109 DO_2D( 1, 0, 1, 0 )137 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! Gradient of density at the last level 110 138 iku = mbku(ji,jj) ; ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points 111 139 ikv = mbkv(ji,jj) ; ikvm1 = MAX( ikv - 1 , 1 ) ! if level first is a p-step, ik.m1=1 … … 146 174 END DO 147 175 ! 148 CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond.176 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. 149 177 ! 150 178 IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) 151 179 pgru(:,:) = 0._wp 152 180 pgrv(:,:) = 0._wp ! depth of the partial step level 153 DO_2D( 1, 0, 1, 0)181 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 154 182 iku = mbku(ji,jj) 155 183 ikv = mbkv(ji,jj) … … 167 195 CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj 168 196 ! 169 DO_2D( 1, 0, 1, 0) ! Gradient of density at the last level197 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) ! Gradient of density at the last level 170 198 iku = mbku(ji,jj) 171 199 ikv = mbkv(ji,jj) … … 179 207 ENDIF 180 208 END_2D 181 CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions209 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions 182 210 ! 183 211 END IF … … 185 213 IF( ln_timing ) CALL timing_stop( 'zps_hde') 186 214 ! 187 END SUBROUTINE zps_hde 215 END SUBROUTINE zps_hde_t 188 216 189 217 190 218 SUBROUTINE zps_hde_isf( kt, Kmm, kjpt, pta, pgtu, pgtv, pgtui, pgtvi, & 191 & prd, pgru, pgrv, pgrui, pgrvi ) 219 & prd, pgru, pgrv, pgrui, pgrvi ) 220 !! 221 INTEGER , INTENT(in ) :: kt ! ocean time-step index 222 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 223 INTEGER , INTENT(in ) :: kjpt ! number of tracers 224 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pta ! 4D tracers fields 225 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 226 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) 227 REAL(wp), DIMENSION(:,:,:) , INTENT(inout), OPTIONAL :: prd ! 3D density anomaly fields 228 REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) 229 REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) 230 ! 231 INTEGER :: itrd, itgr, itgri 232 !! 233 IF( PRESENT(prd) ) THEN ; itrd = is_tile(prd) ; ELSE ; itrd = 0 ; ENDIF 234 IF( PRESENT(pgru) ) THEN ; itgr = is_tile(pgru) ; ELSE ; itgr = 0 ; ENDIF 235 IF( PRESENT(pgrui) ) THEN ; itgri = is_tile(pgrui) ; ELSE ; itgri = 0 ; ENDIF 236 237 CALL zps_hde_isf_t( kt, Kmm, kjpt, pta, is_tile(pta), pgtu, pgtv, is_tile(pgtu), pgtui, pgtvi, is_tile(pgtui), & 238 & prd, itrd, pgru, pgrv, itgr, pgrui, pgrvi, itgri ) 239 END SUBROUTINE zps_hde_isf 240 241 242 SUBROUTINE zps_hde_isf_t( kt, Kmm, kjpt, pta, ktta, pgtu, pgtv, ktgt, pgtui, pgtvi, ktgti, & 243 & prd, ktrd, pgru, pgrv, ktgr, pgrui, pgrvi, ktgri ) 192 244 !!---------------------------------------------------------------------- 193 245 !! *** ROUTINE zps_hde_isf *** … … 236 288 !! - pgru, pgrv, pgrui, pgtvi: horizontal gradient of rho (if present) at u- & v-points 237 289 !!---------------------------------------------------------------------- 238 INTEGER , INTENT(in ) :: kt ! ocean time-step index 239 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 240 INTEGER , INTENT(in ) :: kjpt ! number of tracers 241 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields 242 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 243 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) 244 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields 245 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) 246 REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) 290 INTEGER , INTENT(in ) :: kt ! ocean time-step index 291 INTEGER , INTENT(in ) :: Kmm ! ocean time level index 292 INTEGER , INTENT(in ) :: kjpt ! number of tracers 293 INTEGER , INTENT(in ) :: ktta, ktgt, ktgti, ktrd, ktgr, ktgri 294 REAL(wp), DIMENSION(A2D_T(ktta),JPK,KJPT), INTENT(inout) :: pta ! 4D tracers fields 295 REAL(wp), DIMENSION(A2D_T(ktgt) ,KJPT), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts 296 REAL(wp), DIMENSION(A2D_T(ktgti) ,KJPT), INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) 297 REAL(wp), DIMENSION(A2D_T(ktrd),JPK ), INTENT(inout), OPTIONAL :: prd ! 3D density anomaly fields 298 REAL(wp), DIMENSION(A2D_T(ktgr) ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) 299 REAL(wp), DIMENSION(A2D_T(ktgri) ), INTENT( out), OPTIONAL :: pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) 247 300 ! 248 301 INTEGER :: ji, jj, jn ! Dummy loop indices 249 302 INTEGER :: iku, ikv, ikum1, ikvm1,ikup1, ikvp1 ! partial step level (ocean bottom level) at u- and v-points 250 303 REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! temporary scalars 251 REAL(wp), DIMENSION( jpi,jpj) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos252 REAL(wp), DIMENSION( jpi,jpj,kjpt) :: zti, ztj !304 REAL(wp), DIMENSION(A2D(nn_hls)) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos 305 REAL(wp), DIMENSION(A2D(nn_hls),kjpt) :: zti, ztj ! 253 306 !!---------------------------------------------------------------------- 254 307 ! 255 308 IF( ln_timing ) CALL timing_start( 'zps_hde_isf') 256 309 ! 310 IF (nn_hls.EQ.2) THEN 311 CALL lbc_lnk( 'zpshde', pta, 'T', 1.0_wp) 312 IF (PRESENT(prd)) CALL lbc_lnk( 'zpshde', prd, 'T', 1.0_wp) 313 END IF 314 257 315 pgtu (:,:,:) = 0._wp ; pgtv (:,:,:) =0._wp 258 316 pgtui(:,:,:) = 0._wp ; pgtvi(:,:,:) =0._wp … … 262 320 DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! 263 321 ! 264 DO_2D( 1, 0, 1, 0)322 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 265 323 266 324 iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 ) ! last and before last ocean level at u- & v-points … … 302 360 END DO 303 361 ! 304 CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond.362 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. 305 363 306 364 ! horizontal derivative of density anomalies (rd) … … 308 366 pgru(:,:)=0.0_wp ; pgrv(:,:)=0.0_wp ; 309 367 ! 310 DO_2D( 1, 0, 1, 0)368 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 311 369 312 370 iku = mbku(ji,jj) … … 329 387 CALL eos( ztj, zhj, zrj ) 330 388 331 DO_2D( 1, 0, 1, 0 ) ! Gradient of density at the last level389 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 332 390 iku = mbku(ji,jj) 333 391 ikv = mbkv(ji,jj) … … 344 402 END_2D 345 403 346 CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions404 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions 347 405 ! 348 406 END IF … … 351 409 ! 352 410 DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! ! 353 DO_2D( 1, 0, 1, 0)411 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 354 412 iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1 355 413 ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1 … … 395 453 ! 396 454 END DO 397 CALL lbc_lnk_multi( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond.455 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. 398 456 399 457 IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) 400 458 ! 401 459 pgrui(:,:) =0.0_wp; pgrvi(:,:) =0.0_wp; 402 DO_2D( 1, 0, 1, 0)460 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 403 461 404 462 iku = miku(ji,jj) … … 420 478 CALL eos( ztj, zhj, zrj ) ! at the partial step depth output in zri, zrj 421 479 ! 422 DO_2D( 1, 0, 1, 0 ) ! Gradient of density at the last level480 DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 423 481 iku = miku(ji,jj) 424 482 ikv = mikv(ji,jj) … … 434 492 435 493 END_2D 436 CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions494 IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions 437 495 ! 438 496 END IF … … 440 498 IF( ln_timing ) CALL timing_stop( 'zps_hde_isf') 441 499 ! 442 END SUBROUTINE zps_hde_isf 500 END SUBROUTINE zps_hde_isf_t 443 501 444 502 !!====================================================================== -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/TRD/trdini.F90
r12377 r14046 11 11 !!---------------------------------------------------------------------- 12 12 USE dom_oce ! ocean domain 13 USE domain, ONLY : dom_tile 13 14 USE trd_oce ! trends: ocean variables 14 15 USE trdken ! trends: 3D kinetic energy … … 88 89 ! 89 90 ! IF( .NOT.ln_linssh .AND. ( l_trdtra .OR. l_trddyn ) ) CALL ctl_stop( 'trend diagnostics with variable volume not validated' ) 90 91 92 IF( ln_tile .AND. ( l_trdtra .OR. l_trddyn ) ) THEN 93 CALL ctl_warn('Tiling is not yet implemented for the trends diagnostics; ln_tile is forced to FALSE') 94 ln_tile = .FALSE. 95 CALL dom_tile( ntsi, ntsj, ntei, ntej ) 96 ENDIF 97 91 98 !!gm : Potential BUG : 3D output only for vector invariant form! add a ctl_stop or code the flux form case 92 99 !!gm : bug/pb for vertical advection of tracer in vvl case: add T.dt[eta] in the output... -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/USR/usrdef_nam.F90
r13286 r14046 70 70 kk_cfg = nn_GYRE 71 71 ! 72 kpi = 30 * nn_GYRE + 2 ! 72 kpi = 30 * nn_GYRE + 2 ! 73 73 kpj = 20 * nn_GYRE + 2 74 74 #if defined key_agrif -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ZDF/zdf_oce.F90
r10425 r14046 40 40 LOGICAL , PUBLIC :: ln_zdfswm !: surface wave-induced mixing flag 41 41 LOGICAL , PUBLIC :: ln_zdfiwm !: internal wave-induced mixing flag 42 LOGICAL , PUBLIC :: ln_zdfmfc !: convection: eddy diffusivity Mass Flux Convection 42 43 ! ! coefficients 43 44 REAL(wp), PUBLIC :: rn_avm0 !: vertical eddy viscosity (m2/s) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ZDF/zdfgls.F90
r13558 r14046 1057 1057 CALL gls_rst( nit000, 'READ' ) ! (en, avt_k, avm_k, hmxl_n) 1058 1058 ! 1059 IF( lwxios ) THEN1060 CALL iom_set_rstw_var_active('en')1061 CALL iom_set_rstw_var_active('avt_k')1062 CALL iom_set_rstw_var_active('avm_k')1063 CALL iom_set_rstw_var_active('hmxl_n')1064 ENDIF1065 !1066 1059 END SUBROUTINE zdf_gls_init 1067 1060 … … 1097 1090 ! 1098 1091 IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN ! all required arrays exist 1099 CALL iom_get( numror, jpdom_auto, 'en' , en , ldxios = lrxios)1100 CALL iom_get( numror, jpdom_auto, 'avt_k' , avt_k , ldxios = lrxios)1101 CALL iom_get( numror, jpdom_auto, 'avm_k' , avm_k , ldxios = lrxios)1102 CALL iom_get( numror, jpdom_auto, 'hmxl_n', hmxl_n , ldxios = lrxios)1092 CALL iom_get( numror, jpdom_auto, 'en' , en ) 1093 CALL iom_get( numror, jpdom_auto, 'avt_k' , avt_k ) 1094 CALL iom_get( numror, jpdom_auto, 'avm_k' , avm_k ) 1095 CALL iom_get( numror, jpdom_auto, 'hmxl_n', hmxl_n ) 1103 1096 ELSE 1104 1097 IF(lwp) WRITE(numout,*) … … 1119 1112 ! ! ------------------- 1120 1113 IF(lwp) WRITE(numout,*) '---- gls-rst ----' 1121 IF( lwxios ) CALL iom_swap( cwxios_context ) 1122 CALL iom_rstput( kt, nitrst, numrow, 'en' , en , ldxios = lwxios ) 1123 CALL iom_rstput( kt, nitrst, numrow, 'avt_k' , avt_k , ldxios = lwxios ) 1124 CALL iom_rstput( kt, nitrst, numrow, 'avm_k' , avm_k , ldxios = lwxios ) 1125 CALL iom_rstput( kt, nitrst, numrow, 'hmxl_n', hmxl_n, ldxios = lwxios ) 1126 IF( lwxios ) CALL iom_swap( cxios_context ) 1114 CALL iom_rstput( kt, nitrst, numrow, 'en' , en ) 1115 CALL iom_rstput( kt, nitrst, numrow, 'avt_k' , avt_k ) 1116 CALL iom_rstput( kt, nitrst, numrow, 'avm_k' , avm_k ) 1117 CALL iom_rstput( kt, nitrst, numrow, 'hmxl_n', hmxl_n ) 1127 1118 ! 1128 1119 ENDIF -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ZDF/zdfosm.F90
r13497 r14046 1437 1437 ghamv(:,:,:) = 0. 1438 1438 ! 1439 IF( lwxios ) THEN1440 CALL iom_set_rstw_var_active('wn')1441 CALL iom_set_rstw_var_active('hbl')1442 CALL iom_set_rstw_var_active('hbli')1443 ENDIF1444 1439 END SUBROUTINE zdf_osm_init 1445 1440 … … 1474 1469 id1 = iom_varid( numror, 'wn' , ldstop = .FALSE. ) 1475 1470 IF( id1 > 0 ) THEN ! 'wn' exists; read 1476 CALL iom_get( numror, jpdom_auto, 'wn', ww , ldxios = lrxios)1471 CALL iom_get( numror, jpdom_auto, 'wn', ww ) 1477 1472 WRITE(numout,*) ' ===>>>> : ww read from restart file' 1478 1473 ELSE … … 1483 1478 id2 = iom_varid( numror, 'hbli' , ldstop = .FALSE. ) 1484 1479 IF( id1 > 0 .AND. id2 > 0) THEN ! 'hbl' exists; read and return 1485 CALL iom_get( numror, jpdom_auto, 'hbl' , hbl , ldxios = lrxios)1486 CALL iom_get( numror, jpdom_auto, 'hbli', hbli , ldxios = lrxios)1480 CALL iom_get( numror, jpdom_auto, 'hbl' , hbl ) 1481 CALL iom_get( numror, jpdom_auto, 'hbli', hbli ) 1487 1482 WRITE(numout,*) ' ===>>>> : hbl & hbli read from restart file' 1488 1483 RETURN … … 1496 1491 !!----------------------------------------------------------------------------- 1497 1492 IF( TRIM(cdrw) == 'WRITE') THEN !* Write hbli into the restart file, then return 1493 IF( ntile /= 0 .AND. ntile /= nijtile ) RETURN ! Do only on the last tile 1494 1498 1495 IF(lwp) WRITE(numout,*) '---- osm-rst ----' 1499 CALL iom_rstput( kt, nitrst, numrow, 'wn' , ww , ldxios = lwxios)1500 CALL iom_rstput( kt, nitrst, numrow, 'hbl' , hbl , ldxios = lwxios)1501 CALL iom_rstput( kt, nitrst, numrow, 'hbli' , hbli , ldxios = lwxios)1496 CALL iom_rstput( kt, nitrst, numrow, 'wn' , ww ) 1497 CALL iom_rstput( kt, nitrst, numrow, 'hbl' , hbl ) 1498 CALL iom_rstput( kt, nitrst, numrow, 'hbli' , hbli ) 1502 1499 RETURN 1503 1500 END IF … … 1550 1547 ! 1551 1548 IF( kt == nit000 ) THEN 1552 IF(lwp) WRITE(numout,*) 1553 IF(lwp) WRITE(numout,*) 'tra_osm : OSM non-local tracer fluxes' 1554 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 1549 IF( ntile == 0 .OR. ntile == 1 ) THEN ! Do only on the first tile 1550 IF(lwp) WRITE(numout,*) 1551 IF(lwp) WRITE(numout,*) 'tra_osm : OSM non-local tracer fluxes' 1552 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 1553 ENDIF 1555 1554 ENDIF 1556 1555 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ZDF/zdfphy.F90
r13558 r14046 21 21 USE zdfddm ! vertical physics: double diffusion mixing 22 22 USE zdfevd ! vertical physics: convection via enhanced vertical diffusion 23 USE zdfmfc ! vertical physics: Mass Flux Convection 23 24 USE zdfiwm ! vertical physics: internal wave-induced mixing 24 25 USE zdfswm ! vertical physics: surface wave-induced mixing … … 78 79 NAMELIST/namzdf/ ln_zdfcst, ln_zdfric, ln_zdftke, ln_zdfgls, & ! type of closure scheme 79 80 & ln_zdfosm, & ! type of closure scheme 81 & ln_zdfmfc, & ! convection : mass flux 80 82 & ln_zdfevd, nn_evdm, rn_evd , & ! convection : evd 81 83 & ln_zdfnpc, nn_npc , nn_npcp, & ! convection : npc … … 112 114 WRITE(numout,*) ' OSMOSIS-OBL closure (OSM) ln_zdfosm = ', ln_zdfosm 113 115 WRITE(numout,*) ' convection: ' 116 WRITE(numout,*) ' convection mass flux (mfc) ln_zdfmfc = ', ln_zdfmfc 114 117 WRITE(numout,*) ' enhanced vertical diffusion ln_zdfevd = ', ln_zdfevd 115 118 WRITE(numout,*) ' applied on momentum (=1/0) nn_evdm = ', nn_evdm … … 172 175 IF( ln_zdfnpc .AND. ln_zdfevd ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfnpc and ln_zdfevd' ) 173 176 IF( ln_zdfosm .AND. ln_zdfevd ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfosm and ln_zdfevd' ) 177 IF( ln_zdfmfc .AND. ln_zdfevd ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfmfc and ln_zdfevd' ) 178 IF( ln_zdfmfc .AND. ln_zdfnpc ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfmfc and ln_zdfnpc' ) 179 IF( ln_zdfmfc .AND. ln_zdfosm ) CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfmfc and ln_zdfosm' ) 174 180 IF( lk_top .AND. ln_zdfnpc ) CALL ctl_stop( 'zdf_phy_init: npc scheme is not working with key_top' ) 175 181 IF( lk_top .AND. ln_zdfosm ) CALL ctl_stop( 'zdf_phy_init: osmosis scheme is not working with key_top' ) 182 IF( lk_top .AND. ln_zdfmfc ) CALL ctl_stop( 'zdf_phy_init: Mass Flux scheme is not working with key_top' ) 176 183 IF(lwp) THEN 177 184 WRITE(numout,*) 178 185 IF ( ln_zdfnpc ) THEN ; WRITE(numout,*) ' ==>>> convection: use non penetrative convective scheme' 179 186 ELSEIF( ln_zdfevd ) THEN ; WRITE(numout,*) ' ==>>> convection: use enhanced vertical diffusion scheme' 187 ELSEIF( ln_zdfmfc ) THEN ; WRITE(numout,*) ' ==>>> convection: use Mass Flux scheme' 180 188 ELSE ; WRITE(numout,*) ' ==>>> convection: no specific scheme used' 181 189 ENDIF … … 205 213 ELSE ; l_zdfsh2 = .TRUE. 206 214 ENDIF 207 215 ! !== Mass Flux Convectiive algorithm ==! 216 IF( ln_zdfmfc ) CALL zdf_mfc_init ! Convection computed with eddy diffusivity mass flux 217 ! 208 218 ! !== gravity wave-driven mixing ==! 209 219 IF( ln_zdfiwm ) CALL zdf_iwm_init ! internal wave-driven mixing -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ZDF/zdfric.F90
r13497 r14046 103 103 CALL ric_rst( nit000, 'READ' ) !* read or initialize all required files 104 104 ! 105 IF( lwxios ) THEN106 CALL iom_set_rstw_var_active('avt_k')107 CALL iom_set_rstw_var_active('avm_k')108 ENDIF109 105 END SUBROUTINE zdf_ric_init 110 106 … … 214 210 ! 215 211 IF( MIN( id1, id2 ) > 0 ) THEN ! restart exists => read it 216 CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k , ldxios = lrxios)217 CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k , ldxios = lrxios)212 CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k ) 213 CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k ) 218 214 ENDIF 219 215 ENDIF … … 223 219 ! ! ------------------- 224 220 IF(lwp) WRITE(numout,*) '---- ric-rst ----' 225 IF( lwxios ) CALL iom_swap( cwxios_context ) 226 CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k, ldxios = lwxios ) 227 CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k, ldxios = lwxios) 228 IF( lwxios ) CALL iom_swap( cxios_context ) 221 CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k ) 222 CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k) 229 223 ! 230 224 ENDIF -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ZDF/zdfsh2.F90
r13497 r14046 6 6 !! History : - ! 2014-10 (A. Barthelemy, G. Madec) original code 7 7 !! NEMO 4.0 ! 2017-04 (G. Madec) remove u-,v-pts avm 8 !! NEMO 4.2 ! 2020-12 (G. Madec, E. Clementi) add Stokes Drift Shear 9 ! ! for wave coupling 8 10 !!---------------------------------------------------------------------- 9 11 … … 13 15 USE oce 14 16 USE dom_oce ! domain: ocean 17 USE sbcwave ! Surface Waves (add Stokes shear) 18 USE sbc_oce , ONLY: ln_stshear !Stoked Drift shear contribution 15 19 ! 16 20 USE in_out_manager ! I/O manager … … 21 25 22 26 PUBLIC zdf_sh2 ! called by zdftke, zdfglf, and zdfric 23 27 24 28 !! * Substitutions 25 29 # include "do_loop_substitute.h90" … … 59 63 !!-------------------------------------------------------------------- 60 64 ! 61 DO jk = 2, jpkm1 62 DO_2D( 1, 0, 1, 0 ) !* 2 x shear production at uw- and vw-points (energy conserving form) 63 zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & 64 & * ( uu(ji,jj,jk-1,Kmm) - uu(ji,jj,jk,Kmm) ) & 65 & * ( uu(ji,jj,jk-1,Kbb) - uu(ji,jj,jk,Kbb) ) & 66 & / ( e3uw(ji,jj,jk ,Kmm) * e3uw(ji,jj,jk,Kbb) ) & 67 & * wumask(ji,jj,jk) 68 zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) ) & 69 & * ( vv(ji,jj,jk-1,Kmm) - vv(ji,jj,jk,Kmm) ) & 70 & * ( vv(ji,jj,jk-1,Kbb) - vv(ji,jj,jk,Kbb) ) & 71 & / ( e3vw(ji,jj,jk ,Kmm) * e3vw(ji,jj,jk,Kbb) ) & 72 & * wvmask(ji,jj,jk) 73 END_2D 65 DO jk = 2, jpkm1 !* Shear production at uw- and vw-points (energy conserving form) 66 IF ( cpl_sdrftx .AND. ln_stshear ) THEN ! Surface Stokes Drift available ===>>> shear + stokes drift contibution 67 DO_2D( 1, 0, 1, 0 ) 68 zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & 69 & * ( uu (ji,jj,jk-1,Kmm) - uu (ji,jj,jk,Kmm) & 70 & + usd(ji,jj,jk-1) - usd(ji,jj,jk) ) & 71 & * ( uu (ji,jj,jk-1,Kbb) - uu (ji,jj,jk,Kbb) ) & 72 & / ( e3uw(ji,jj,jk,Kmm) * e3uw(ji,jj,jk,Kbb) ) * wumask(ji,jj,jk) 73 zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) ) & 74 & * ( vv (ji,jj,jk-1,Kmm) - vv (ji,jj,jk,Kmm) & 75 & + vsd(ji,jj,jk-1) - vsd(ji,jj,jk) ) & 76 & * ( vv (ji,jj,jk-1,Kbb) - vv (ji,jj,jk,Kbb) ) & 77 &/ ( e3vw(ji,jj,jk,Kmm) * e3vw(ji,jj,jk,Kbb) ) * wvmask(ji,jj,jk) 78 END_2D 79 ELSE 80 DO_2D( 1, 0, 1, 0 ) !* 2 x shear production at uw- and vw-points (energy conserving form) 81 zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & 82 & * ( uu(ji,jj,jk-1,Kmm) - uu(ji,jj,jk,Kmm) ) & 83 & * ( uu(ji,jj,jk-1,Kbb) - uu(ji,jj,jk,Kbb) ) & 84 & / ( e3uw(ji,jj,jk ,Kmm) * e3uw(ji,jj,jk,Kbb) ) & 85 & * wumask(ji,jj,jk) 86 zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) ) & 87 & * ( vv(ji,jj,jk-1,Kmm) - vv(ji,jj,jk,Kmm) ) & 88 & * ( vv(ji,jj,jk-1,Kbb) - vv(ji,jj,jk,Kbb) ) & 89 & / ( e3vw(ji,jj,jk ,Kmm) * e3vw(ji,jj,jk,Kbb) ) & 90 & * wvmask(ji,jj,jk) 91 END_2D 92 ENDIF 74 93 DO_2D( 0, 0, 0, 0 ) !* shear production at w-point ! coast mask: =2 at the coast ; =1 otherwise (NB: wmask useless as zsh2 are masked) 75 94 p_sh2(ji,jj,jk) = 0.25 * ( ( zsh2u(ji-1,jj) + zsh2u(ji,jj) ) * ( 2. - umask(ji-1,jj,jk) * umask(ji,jj,jk) ) & 76 95 & + ( zsh2v(ji,jj-1) + zsh2v(ji,jj) ) * ( 2. - vmask(ji,jj-1,jk) * vmask(ji,jj,jk) ) ) 77 96 END_2D 78 END DO 97 END DO 79 98 ! 80 99 END SUBROUTINE zdf_sh2 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/ZDF/zdftke.F90
r13558 r14046 29 29 !! 4.0 ! 2017-04 (G. Madec) remove CPP ddm key & avm at t-point only 30 30 !! - ! 2017-05 (G. Madec) add top/bottom friction as boundary condition 31 !! 4.2 ! 2020-12 (G. Madec, E. Clementi) add wave coupling 32 ! ! following Couvelard et al., 2019 31 33 !!---------------------------------------------------------------------- 32 34 … … 58 60 USE prtctl ! Print control 59 61 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 62 USE sbcwave ! Surface boundary waves 60 63 61 64 IMPLICIT NONE … … 68 71 ! !!** Namelist namzdf_tke ** 69 72 LOGICAL :: ln_mxl0 ! mixing length scale surface value as function of wind stress or not 73 LOGICAL :: ln_mxhsw ! mixing length scale surface value as a fonction of wave height 70 74 INTEGER :: nn_mxlice ! type of scaling under sea-ice (=0/1/2/3) 71 75 REAL(wp) :: rn_mxlice ! ice thickness value when scaling under sea-ice … … 81 85 INTEGER :: nn_etau ! type of depth penetration of surface tke (=0/1/2/3) 82 86 INTEGER :: nn_htau ! type of tke profile of penetration (=0/1) 87 INTEGER :: nn_bc_surf! surface condition (0/1=Dir/Neum) ! Only applicable for wave coupling 88 INTEGER :: nn_bc_bot ! surface condition (0/1=Dir/Neum) ! Only applicable for wave coupling 83 89 REAL(wp) :: rn_efr ! fraction of TKE surface value which penetrates in the ocean 84 90 LOGICAL :: ln_lc ! Langmuir cells (LC) as a source term of TKE or not … … 209 215 REAL(wp) :: zus , zwlc , zind ! - - 210 216 REAL(wp) :: zzd_up, zzd_lw ! - - 217 REAL(wp) :: ztaui, ztauj, z1_norm 211 218 INTEGER , DIMENSION(jpi,jpj) :: imlc 212 REAL(wp), DIMENSION(jpi,jpj) :: zice_fra, zhlc, zus3 219 REAL(wp), DIMENSION(jpi,jpj) :: zice_fra, zhlc, zus3, zWlc2 213 220 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpelc, zdiag, zd_up, zd_lw 214 221 !!-------------------------------------------------------------------- … … 219 226 zfact2 = 1.5_wp * rn_Dt * rn_ediss 220 227 zfact3 = 0.5_wp * rn_ediss 228 ! 229 zpelc(:,:,:) = 0._wp ! need to be initialised in case ln_lc is not used 221 230 ! 222 231 ! ice fraction considered for attenuation of langmuir & wave breaking … … 232 241 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 233 242 ! 234 DO_2D( 0, 0, 0, 0 ) ! en(1) = rn_ebb taum / rau0 (min value rn_emin0) 235 !! clem: this should be the right formulation but it makes the model unstable unless drags are calculated implicitly 236 !! one way around would be to increase zbbirau 237 !! en(ji,jj,1) = MAX( rn_emin0, ( ( 1._wp - fr_i(ji,jj) ) * zbbrau + & 238 !! & fr_i(ji,jj) * zbbirau ) * taum(ji,jj) ) * tmask(ji,jj,1) 243 DO_2D( 0, 0, 0, 0 ) 239 244 en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 245 zdiag(ji,jj,1) = 1._wp/en(ji,jj,1) 246 zd_lw(ji,jj,1) = 1._wp 247 zd_up(ji,jj,1) = 0._wp 240 248 END_2D 241 249 ! … … 274 282 ! 275 283 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 276 IF( ln_lc ) THEN ! Langmuir circulation source term added to tke !(Axell JGR 2002)284 IF( ln_lc ) THEN ! Langmuir circulation source term added to tke (Axell JGR 2002) 277 285 ! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 278 286 ! 279 ! !* total energy produce by LC : cumulative sum over jk 287 ! !* Langmuir velocity scale 288 ! 289 IF ( cpl_sdrftx ) THEN ! Surface Stokes Drift available 290 ! ! Craik-Leibovich velocity scale Wlc = ( u* u_s )^1/2 with u* = (taum/rho0)^1/2 291 ! ! associated kinetic energy : 1/2 (Wlc)^2 = u* u_s 292 ! ! more precisely, it is the dot product that must be used : 293 ! ! 1/2 (W_lc)^2 = MAX( u* u_s + v* v_s , 0 ) only the positive part 294 !!gm ! PS: currently we don't have neither the 2 stress components at t-point !nor the angle between u* and u_s 295 !!gm ! so we will overestimate the LC velocity.... !!gm I will do the work if !LC have an effect ! 296 DO_2D( 0, 0, 0, 0 ) 297 !!XC zWlc2(ji,jj) = 0.5_wp * SQRT( taum(ji,jj) * r1_rho0 * ( ut0sd(ji,jj)**2 +vt0sd(ji,jj)**2 ) ) 298 zWlc2(ji,jj) = 0.5_wp * ( ut0sd(ji,jj)**2 +vt0sd(ji,jj)**2 ) 299 END_2D 300 ! 301 ! Projection of Stokes drift in the wind stress direction 302 ! 303 DO_2D( 0, 0, 0, 0 ) 304 ztaui = 0.5_wp * ( utau(ji,jj) + utau(ji-1,jj) ) 305 ztauj = 0.5_wp * ( vtau(ji,jj) + vtau(ji,jj-1) ) 306 z1_norm = 1._wp / MAX( SQRT(ztaui*ztaui+ztauj*ztauj), 1.e-12 ) * tmask(ji,jj,1) 307 zWlc2(ji,jj) = 0.5_wp * z1_norm * ( MAX( ut0sd(ji,jj)*ztaui + vt0sd(ji,jj)*ztauj, 0._wp ) )**2 308 END_2D 309 CALL lbc_lnk ( 'zdftke', zWlc2, 'T', 1. ) 310 ! 311 ELSE ! Surface Stokes drift deduced from surface stress 312 ! ! Wlc = u_s with u_s = 0.016*U_10m, the surface stokes drift (Axell 2002, Eq.44) 313 ! ! using |tau| = rho_air Cd |U_10m|^2 , it comes: 314 ! ! Wlc = 0.016 * [|tau|/(rho_air Cdrag) ]^1/2 and thus: 315 ! ! 1/2 Wlc^2 = 0.5 * 0.016 * 0.016 |tau| /( rho_air Cdrag ) 316 zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) ! to convert stress in 10m wind using a constant drag 317 DO_2D( 1, 1, 1, 1 ) 318 zWlc2(ji,jj) = zcof * taum(ji,jj) 319 END_2D 320 ! 321 ENDIF 322 ! 323 ! !* Depth of the LC circulation (Axell 2002, Eq.47) 324 ! !- LHS of Eq.47 280 325 zpelc(:,:,1) = MAX( rn2b(:,:,1), 0._wp ) * gdepw(:,:,1,Kmm) * e3w(:,:,1,Kmm) 281 326 DO jk = 2, jpk … … 283 328 & MAX( rn2b(:,:,jk), 0._wp ) * gdepw(:,:,jk,Kmm) * e3w(:,:,jk,Kmm) 284 329 END DO 285 ! !* finite Langmuir Circulation depth286 zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag )330 ! 331 ! !- compare LHS to RHS of Eq.47 287 332 imlc(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point (=2 over land) 288 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) ! Last w-level at which zpelc>=0.5*us*us 289 zus = zcof * taum(ji,jj) ! with us=0.016*wind(starting from jpk-1) 290 IF( zpelc(ji,jj,jk) > zus ) imlc(ji,jj) = jk 333 DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) 334 IF( zpelc(ji,jj,jk) > zWlc2(ji,jj) ) imlc(ji,jj) = jk 291 335 END_3D 292 336 ! ! finite LC depth … … 294 338 zhlc(ji,jj) = gdepw(ji,jj,imlc(ji,jj),Kmm) 295 339 END_2D 340 ! 296 341 zcof = 0.016 / SQRT( zrhoa * zcdrag ) 297 342 DO_2D( 0, 0, 0, 0 ) 298 zus = zcof * SQRT( taum(ji,jj) )! Stokes drift343 zus = SQRT( 2. * zWlc2(ji,jj) ) ! Stokes drift 299 344 zus3(ji,jj) = MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok 300 345 END_2D … … 351 396 & ) * wmask(ji,jj,jk) 352 397 END_3D 398 ! 399 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 400 ! ! Surface boundary condition on tke if 401 ! ! coupling with waves 402 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 403 ! 404 IF ( cpl_phioc .and. ln_phioc ) THEN 405 SELECT CASE (nn_bc_surf) ! Boundary Condition using surface TKE flux from waves 406 407 CASE ( 0 ) ! Dirichlet BC 408 DO_2D( 0, 0, 0, 0 ) ! en(1) = rn_ebb taum / rho0 (min value rn_emin0) 409 IF ( phioc(ji,jj) < 0 ) phioc(ji,jj) = 0._wp 410 en(ji,jj,1) = MAX( rn_emin0, .5 * ( 15.8 * phioc(ji,jj) / rho0 )**(2./3.) ) * tmask(ji,jj,1) 411 zdiag(ji,jj,1) = 1._wp/en(ji,jj,1) ! choose to keep coherence with former estimation of 412 END_2D 413 414 CASE ( 1 ) ! Neumann BC 415 DO_2D( 0, 0, 0, 0 ) 416 IF ( phioc(ji,jj) < 0 ) phioc(ji,jj) = 0._wp 417 en(ji,jj,2) = en(ji,jj,2) + ( rn_Dt * phioc(ji,jj) / rho0 ) /e3w(ji,jj,2,Kmm) 418 en(ji,jj,1) = en(ji,jj,2) + (2 * e3t(ji,jj,1,Kmm) * phioc(ji,jj)/rho0) / ( p_avm(ji,jj,1) + p_avm(ji,jj,2) ) 419 zdiag(ji,jj,2) = zdiag(ji,jj,2) + zd_lw(ji,jj,2) 420 zdiag(ji,jj,1) = 1._wp 421 zd_lw(ji,jj,2) = 0._wp 422 END_2D 423 424 END SELECT 425 426 ENDIF 427 ! 353 428 ! !* Matrix inversion from level 2 (tke prescribed at level 1) 354 DO_3D( 0, 0, 0, 0, 3, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1429 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 355 430 zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 356 431 END_3D 357 DO_2D( 0, 0, 0, 0 ) ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 358 zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1) ! Surface boudary conditions on tke 359 END_2D 360 DO_3D( 0, 0, 0, 0, 3, jpkm1 ) 432 !XC : commented to allow for neumann boundary condition 433 ! DO_2D( 0, 0, 0, 0 ) 434 ! zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1) ! Surface boudary conditions on tke 435 ! END_2D 436 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 361 437 zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1) 362 438 END_3D … … 460 536 zmxlm(:,:,:) = rmxl_min 461 537 zmxld(:,:,:) = rmxl_min 538 ! 539 IF(ln_sdw .AND. ln_mxhsw) THEN 540 zmxlm(:,:,1)= vkarmn * MAX ( 1.6 * hsw(:,:) , 0.02 ) ! surface mixing length = F(wave height) 541 ! from terray et al 1999 and mellor and blumberg 2004 it should be 0.85 and not 1.6 542 zcoef = vkarmn * ( (rn_ediff*rn_ediss)**0.25 ) / rn_ediff 543 zmxlm(:,:,1)= zcoef * MAX ( 1.6 * hsw(:,:) , 0.02 ) ! surface mixing length = F(wave height) 544 ELSE 462 545 ! 463 IF( ln_mxl0 ) THEN ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rho0*g)464 ! 465 zraug = vkarmn * 2.e5_wp / ( rho0 * grav )546 IF( ln_mxl0 ) THEN ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rho0*g) 547 ! 548 zraug = vkarmn * 2.e5_wp / ( rho0 * grav ) 466 549 #if ! defined key_si3 && ! defined key_cice 467 DO_2D( 0, 0, 0, 0 ) ! No sea-ice468 zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1)469 END_2D550 DO_2D( 0, 0, 0, 0 ) ! No sea-ice 551 zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) 552 END_2D 470 553 #else 471 SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice 472 ! 473 CASE( 0 ) ! No scaling under sea-ice 554 SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice 555 ! 556 CASE( 0 ) ! No scaling under sea-ice 557 DO_2D( 0, 0, 0, 0 ) 558 zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) 559 END_2D 560 ! 561 CASE( 1 ) ! scaling with constant sea-ice thickness 562 DO_2D( 0, 0, 0, 0 ) 563 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 564 & fr_i(ji,jj) * rn_mxlice ) * tmask(ji,jj,1) 565 END_2D 566 ! 567 CASE( 2 ) ! scaling with mean sea-ice thickness 568 DO_2D( 0, 0, 0, 0 ) 569 #if defined key_si3 570 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 571 & fr_i(ji,jj) * hm_i(ji,jj) * 2._wp ) * tmask(ji,jj,1) 572 #elif defined key_cice 573 zmaxice = MAXVAL( h_i(ji,jj,:) ) 574 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 575 & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 576 #endif 577 END_2D 578 ! 579 CASE( 3 ) ! scaling with max sea-ice thickness 580 DO_2D( 0, 0, 0, 0 ) 581 zmaxice = MAXVAL( h_i(ji,jj,:) ) 582 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 583 & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 584 END_2D 585 ! 586 END SELECT 587 #endif 588 ! 474 589 DO_2D( 0, 0, 0, 0 ) 475 zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1)590 zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) ) 476 591 END_2D 477 592 ! 478 CASE( 1 ) ! scaling with constant sea-ice thickness 479 DO_2D( 0, 0, 0, 0 ) 480 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 481 & fr_i(ji,jj) * rn_mxlice ) * tmask(ji,jj,1) 482 END_2D 483 ! 484 CASE( 2 ) ! scaling with mean sea-ice thickness 485 DO_2D( 0, 0, 0, 0 ) 486 #if defined key_si3 487 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 488 & fr_i(ji,jj) * hm_i(ji,jj) * 2._wp ) * tmask(ji,jj,1) 489 #elif defined key_cice 490 zmaxice = MAXVAL( h_i(ji,jj,:) ) 491 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 492 & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 493 #endif 494 END_2D 495 ! 496 CASE( 3 ) ! scaling with max sea-ice thickness 497 DO_2D( 0, 0, 0, 0 ) 498 zmaxice = MAXVAL( h_i(ji,jj,:) ) 499 zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 500 & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 501 END_2D 502 ! 503 END SELECT 504 #endif 505 ! 506 DO_2D( 0, 0, 0, 0 ) 507 zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) ) 508 END_2D 509 ! 510 ELSE 511 zmxlm(:,:,1) = rn_mxl0 512 ENDIF 513 593 ELSE 594 zmxlm(:,:,1) = rn_mxl0 595 ENDIF 596 ENDIF 514 597 ! 515 598 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) … … 624 707 & rn_mxl0 , nn_mxlice, rn_mxlice, & 625 708 & nn_pdl , ln_lc , rn_lc , & 626 & nn_etau , nn_htau , rn_efr , nn_eice 709 & nn_etau , nn_htau , rn_efr , nn_eice , & 710 & nn_bc_surf, nn_bc_bot, ln_mxhsw 627 711 !!---------------------------------------------------------------------- 628 712 ! … … 666 750 WRITE(numout,*) ' Langmuir cells parametrization ln_lc = ', ln_lc 667 751 WRITE(numout,*) ' coef to compute vertical velocity of LC rn_lc = ', rn_lc 752 IF ( cpl_phioc .and. ln_phioc ) THEN 753 SELECT CASE( nn_bc_surf) ! Type of scaling under sea-ice 754 CASE( 0 ) ; WRITE(numout,*) ' nn_bc_surf=0 ==>>> DIRICHLET SBC using surface TKE flux from waves' 755 CASE( 1 ) ; WRITE(numout,*) ' nn_bc_surf=1 ==>>> NEUMANN SBC using surface TKE flux from waves' 756 END SELECT 757 ENDIF 668 758 WRITE(numout,*) ' test param. to add tke induced by wind nn_etau = ', nn_etau 669 759 WRITE(numout,*) ' type of tke penetration profile nn_htau = ', nn_htau … … 721 811 CALL tke_rst( nit000, 'READ' ) ! (en, avt_k, avm_k, dissl) 722 812 ! 723 IF( lwxios ) THEN724 CALL iom_set_rstw_var_active('en')725 CALL iom_set_rstw_var_active('avt_k')726 CALL iom_set_rstw_var_active('avm_k')727 CALL iom_set_rstw_var_active('dissl')728 ENDIF729 813 END SUBROUTINE zdf_tke_init 730 814 … … 758 842 ! 759 843 IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN ! fields exist 760 CALL iom_get( numror, jpdom_auto, 'en' , en , ldxios = lrxios)761 CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k , ldxios = lrxios)762 CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k , ldxios = lrxios)763 CALL iom_get( numror, jpdom_auto, 'dissl', dissl , ldxios = lrxios)844 CALL iom_get( numror, jpdom_auto, 'en' , en ) 845 CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k ) 846 CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k ) 847 CALL iom_get( numror, jpdom_auto, 'dissl', dissl ) 764 848 ELSE ! start TKE from rest 765 849 IF(lwp) WRITE(numout,*) … … 780 864 ! ! ------------------- 781 865 IF(lwp) WRITE(numout,*) '---- tke_rst ----' 782 IF( lwxios ) CALL iom_swap( cwxios_context ) 783 CALL iom_rstput( kt, nitrst, numrow, 'en' , en , ldxios = lwxios ) 784 CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k, ldxios = lwxios ) 785 CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k, ldxios = lwxios ) 786 CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl, ldxios = lwxios ) 787 IF( lwxios ) CALL iom_swap( cxios_context ) 866 CALL iom_rstput( kt, nitrst, numrow, 'en' , en ) 867 CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k ) 868 CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k ) 869 CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl ) 788 870 ! 789 871 ENDIF -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/do_loop_substitute.h90
r13296 r14046 59 59 #endif 60 60 61 #define DO_2D(B, T, L, R) DO jj = Njs0-(B), Nje0+(T) ; DO ji = Nis0-(L), Nie0+(R) 61 #define DO_2D(B, T, L, R) DO jj = ntsj-(B), ntej+(T) ; DO ji = ntsi-(L), ntei+(R) 62 #define A1Di(H) ntsi-H:ntei+H 63 #define A1Dj(H) ntsj-H:ntej+H 64 #define A2D(H) A1Di(H),A1Dj(H) 65 #define A1Di_T(T) (ntsi-nn_hls-1)*T+1: 66 #define A1Dj_T(T) (ntsj-nn_hls-1)*T+1: 67 #define A2D_T(T) A1Di_T(T),A1Dj_T(T) 68 #define JPK : 69 #define JPTS : 70 #define KJPT : 62 71 63 72 #define DO_3D(B, T, L, R, ks, ke) DO jk = ks, ke ; DO_2D(B, T, L, R) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/nemogcm.F90
r13558 r14046 437 437 CALL Agrif_Declare_Var_ini ! " " " " " DOM 438 438 #endif 439 CALL dom_init( Nbb, Nnn, Naa , "OPA") ! Domain439 CALL dom_init( Nbb, Nnn, Naa ) ! Domain 440 440 IF( ln_crs ) CALL crs_init( Nnn ) ! coarsened grid: domain initialization 441 441 IF( sn_cfctl%l_prtctl ) & -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/par_oce.F90
r13286 r14046 65 65 INTEGER, PUBLIC :: jpjmax! = ( Nj0glo + jpnj-1 ) / jpnj + 2*nn_hls !: maximum jpj 66 66 67 ! Domain tiling 68 INTEGER, PUBLIC :: nijtile !: number of tiles in total 69 INTEGER, PUBLIC :: ntile !: current tile number 70 INTEGER, PUBLIC :: ntsi !: start of internal part of tile domain 71 INTEGER, PUBLIC :: ntsj ! 72 INTEGER, PUBLIC :: ntei !: end of internal part of tile domain 73 INTEGER, PUBLIC :: ntej ! 74 67 75 !!--------------------------------------------------------------------- 68 76 !! Active tracer parameters -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/step.F90
r13237 r14046 55 55 INTEGER, PUBLIC :: Nbb, Nnn, Naa, Nrhs !! used by nemo_init 56 56 57 !! * Substitutions 58 # include "do_loop_substitute.h90" 57 59 !!---------------------------------------------------------------------- 58 60 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 85 87 !! -8- Outputs and diagnostics 86 88 !!---------------------------------------------------------------------- 87 INTEGER :: ji, jj, jk ! dummy loop indice89 INTEGER :: ji, jj, jk, jtile ! dummy loop indice 88 90 !!gm kcall can be removed, I guess 89 91 INTEGER :: kcall ! optional integer argument (dom_vvl_sf_nxt) … … 124 126 IF( ln_crs ) CALL iom_init( TRIM(cxios_context)//"_crs" ) ! for coarse grid 125 127 ENDIF 128 IF((kstp == nitrst) .AND. lwxios) THEN 129 CALL iom_swap( cw_ocerst_cxt ) 130 CALL iom_init_closedef(cw_ocerst_cxt) 131 CALL iom_setkt( kstp - nit000 + 1, cw_ocerst_cxt ) 132 #if defined key_top 133 CALL iom_swap( cw_toprst_cxt ) 134 CALL iom_init_closedef(cw_toprst_cxt) 135 CALL iom_setkt( kstp - nit000 + 1, cw_toprst_cxt ) 136 #endif 137 ENDIF 138 #if defined key_si3 139 IF(((kstp + nn_fsbc - 1) == nitrst) .AND. lwxios) THEN 140 CALL iom_swap( cw_icerst_cxt ) 141 CALL iom_init_closedef(cw_icerst_cxt) 142 CALL iom_setkt( kstp - nit000 + 1, cw_icerst_cxt ) 143 ENDIF 144 #endif 126 145 IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init) 127 146 CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell IOM we are at time step kstp … … 246 265 ! Active tracers 247 266 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 248 ts(:,:,:,:,Nrhs) = 0._wp ! set tracer trends to zero 249 250 IF( lk_asminc .AND. ln_asmiau .AND. & 251 & ln_trainc ) CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs ) ! apply tracer assimilation increment 252 CALL tra_sbc ( kstp, Nnn, ts, Nrhs ) ! surface boundary condition 253 IF( ln_traqsr ) CALL tra_qsr ( kstp, Nnn, ts, Nrhs ) ! penetrative solar radiation qsr 254 IF( ln_isf ) CALL tra_isf ( kstp, Nnn, ts, Nrhs ) ! ice shelf heat flux 255 IF( ln_trabbc ) CALL tra_bbc ( kstp, Nnn, ts, Nrhs ) ! bottom heat flux 256 IF( ln_trabbl ) CALL tra_bbl ( kstp, Nbb, Nnn, ts, Nrhs ) ! advective (and/or diffusive) bottom boundary layer scheme 257 IF( ln_tradmp ) CALL tra_dmp ( kstp, Nbb, Nnn, ts, Nrhs ) ! internal damping trends 258 IF( ln_bdy ) CALL bdy_tra_dmp( kstp, Nbb, ts, Nrhs ) ! bdy damping trends 259 #if defined key_agrif 260 IF(.NOT. Agrif_Root()) & 261 & CALL Agrif_Sponge_tra ! tracers sponge 262 #endif 263 CALL tra_adv ( kstp, Nbb, Nnn, ts, Nrhs ) ! hor. + vert. advection ==> RHS 264 IF( ln_zdfosm ) CALL tra_osm ( kstp, Nnn, ts, Nrhs ) ! OSMOSIS non-local tracer fluxes ==> RHS 265 IF( lrst_oce .AND. ln_zdfosm ) & 266 & CALL osm_rst ( kstp, Nnn, 'WRITE' ) ! write OSMOSIS outputs + ww (so must do here) to restarts 267 CALL tra_ldf ( kstp, Nbb, Nnn, ts, Nrhs ) ! lateral mixing 268 269 CALL tra_zdf ( kstp, Nbb, Nnn, Nrhs, ts, Naa ) ! vertical mixing and after tracer fields 270 IF( ln_zdfnpc ) CALL tra_npc ( kstp, Nnn, Nrhs, ts, Naa ) ! update after fields by non-penetrative convection 271 267 ! Loop over tile domains 268 DO jtile = 1, nijtile 269 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) 270 271 DO_3D( 0, 0, 0, 0, 1, jpk ) 272 ts(ji,jj,jk,:,Nrhs) = 0._wp ! set tracer trends to zero 273 END_3D 274 275 IF( lk_asminc .AND. ln_asmiau .AND. & 276 & ln_trainc ) CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs ) ! apply tracer assimilation increment 277 CALL tra_sbc ( kstp, Nnn, ts, Nrhs ) ! surface boundary condition 278 IF( ln_traqsr ) CALL tra_qsr ( kstp, Nnn, ts, Nrhs ) ! penetrative solar radiation qsr 279 IF( ln_isf ) CALL tra_isf ( kstp, Nnn, ts, Nrhs ) ! ice shelf heat flux 280 IF( ln_trabbc ) CALL tra_bbc ( kstp, Nnn, ts, Nrhs ) ! bottom heat flux 281 IF( ln_trabbl ) CALL tra_bbl ( kstp, Nbb, Nnn, ts, Nrhs ) ! advective (and/or diffusive) bottom boundary layer scheme 282 IF( ln_tradmp ) CALL tra_dmp ( kstp, Nbb, Nnn, ts, Nrhs ) ! internal damping trends 283 IF( ln_bdy ) CALL bdy_tra_dmp( kstp, Nbb, ts, Nrhs ) ! bdy damping trends 284 END DO 285 286 #if defined key_agrif 287 IF(.NOT. Agrif_Root()) THEN 288 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 289 CALL Agrif_Sponge_tra ! tracers sponge 290 ENDIF 291 #endif 292 293 ! TEMP: [tiling] Separate loop over tile domains (due to tra_adv workarounds for tiling) 294 DO jtile = 1, nijtile 295 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) 296 297 CALL tra_adv ( kstp, Nbb, Nnn, ts, Nrhs ) ! hor. + vert. advection ==> RHS 298 IF( ln_zdfmfc ) CALL tra_mfc ( kstp, Nbb, ts, Nrhs ) ! Mass Flux Convection 299 IF( ln_zdfosm ) CALL tra_osm ( kstp, Nnn, ts, Nrhs ) ! OSMOSIS non-local tracer fluxes ==> RHS 300 IF( lrst_oce .AND. ln_zdfosm ) & 301 & CALL osm_rst ( kstp, Nnn, 'WRITE' ) ! write OSMOSIS outputs + ww (so must do here) to restarts 302 CALL tra_ldf ( kstp, Nbb, Nnn, ts, Nrhs ) ! lateral mixing 303 304 CALL tra_zdf ( kstp, Nbb, Nnn, Nrhs, ts, Naa ) ! vertical mixing and after tracer fields 305 IF( ln_zdfnpc ) CALL tra_npc ( kstp, Nnn, Nrhs, ts, Naa ) ! update after fields by non-penetrative convection 306 END DO 307 308 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Revert to tile over full domain 272 309 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 273 310 ! Set boundary conditions, time filter and swap time levels … … 338 375 IF( kstp == nit000 ) THEN ! 1st time step only 339 376 CALL iom_close( numror ) ! close input ocean restart file 377 IF( lrxios ) CALL iom_context_finalize( cr_ocerst_cxt ) 340 378 IF(lwm) CALL FLUSH ( numond ) ! flush output namelist oce 341 379 IF(lwm .AND. numoni /= -1 ) CALL FLUSH ( numoni ) ! flush output namelist ice (if exist) … … 353 391 IF( kstp == nitend .OR. nstop > 0 ) THEN 354 392 CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 355 IF( lrxios ) CALL iom_context_finalize( crxios_context )356 393 IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! 357 394 ENDIF -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/step_oce.F90
r12377 r14046 9 9 USE oce ! ocean dynamics and tracers variables 10 10 USE dom_oce ! ocean space and time domain variables 11 USE domain, ONLY : dom_tile 11 12 USE zdf_oce ! ocean vertical physics variables 12 13 USE zdfdrg , ONLY : ln_drgimp ! implicit top/bottom friction … … 69 70 USE zdfphy ! vertical physics manager (zdf_phy_init routine) 70 71 USE zdfosm , ONLY : osm_rst, dyn_osm, tra_osm ! OSMOSIS routines used in step.F90 72 USE zdfmfc ! Mass FLux Convection routine used in step.F90 71 73 72 74 USE diu_layers ! diurnal SST bulk and coolskin routines -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/stpMLF.F90
r13237 r14046 364 364 IF( kstp == nitend .OR. indic < 0 ) THEN 365 365 CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 366 IF(lrxios) CALL iom_context_finalize( cr xios_context )366 IF(lrxios) CALL iom_context_finalize( cr_ocerst_cxt ) 367 367 IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! 368 368 ENDIF -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OCE/timing.F90
r13558 r14046 109 109 110 110 s_timer%l_tdone = .FALSE. 111 s_timer%niter = s_timer%niter + 1111 IF( ntile == 0 .OR. ntile == 1 ) s_timer%niter = s_timer%niter + 1 ! All tiles count as one iteration 112 112 s_timer%t_cpu = 0. 113 113 s_timer%t_clock = 0. -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OFF/dtadyn.F90
r13497 r14046 46 46 USE fldread ! read input fields 47 47 USE timing ! Timing 48 USE trc, ONLY : ln_rsttr, numrtr, numrtw,lrst_trc48 USE trc, ONLY : ln_rsttr, lrst_trc 49 49 50 50 IMPLICIT NONE … … 795 795 !!--------------------------------------------------------------------- 796 796 INTEGER , INTENT(in ) :: kt ! time step 797 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in 797 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) :: pts ! temperature/salinity 798 798 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(out) :: puslp ! zonal isopycnal slopes 799 799 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(out) :: pvslp ! meridional isopycnal slopes -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/OFF/nemogcm.F90
r13558 r14046 126 126 ENDIF 127 127 ! 128 IF((istp == nitrst) .AND. lwxios) THEN 129 CALL iom_swap( cw_toprst_cxt ) 130 CALL iom_init_closedef(cw_toprst_cxt) 131 CALL iom_setkt( istp - nit000 + 1, cw_toprst_cxt ) 132 ENDIF 133 128 134 IF( istp /= nit000 ) CALL day ( istp ) ! Calendar (day was already called at nit000 in day_init) 129 135 CALL iom_setkt ( istp - nit000 + 1, cxios_context ) ! say to iom that we are at time step kstp … … 340 346 CALL eos_init ! Equation of state 341 347 IF( lk_c1d ) CALL c1d_init ! 1D column configuration 342 CALL dom_init( Nbb, Nnn, Naa , "OPA") ! Domain348 CALL dom_init( Nbb, Nnn, Naa ) ! Domain 343 349 IF( sn_cfctl%l_prtctl ) & 344 350 & CALL prt_ctl_init ! Print control -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/SAO/nemogcm.F90
r13286 r14046 235 235 CALL phy_cst ! Physical constants 236 236 CALL eos_init ! Equation of state 237 CALL dom_init( Nbb, Nnn, Naa , 'SAO') ! Domain237 CALL dom_init( Nbb, Nnn, Naa ) ! Domain 238 238 239 239 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/SAS/nemogcm.F90
r13558 r14046 374 374 CALL Agrif_Declare_Var_ini ! " " " " " DOM 375 375 #endif 376 CALL dom_init( Nbb, Nnn, Naa , 'SAS') ! Domain376 CALL dom_init( Nbb, Nnn, Naa ) ! Domain 377 377 IF( sn_cfctl%l_prtctl ) & 378 378 & CALL prt_ctl_init ! Print control -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/SAS/step.F90
r12933 r14046 89 89 #endif 90 90 IF( kstp == nit000 ) CALL iom_init( cxios_context ) ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 91 CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell iom we are at time step kstp 92 IF((kstp == nitrst) .AND. lwxios) THEN 93 CALL iom_swap( cw_ocerst_cxt ) 94 CALL iom_init_closedef(cw_ocerst_cxt) 95 CALL iom_setkt( kstp - nit000 + 1, cw_ocerst_cxt ) 96 #if defined key_top 97 CALL iom_swap( cw_toprst_cxt ) 98 CALL iom_init_closedef(cw_toprst_cxt) 99 CALL iom_setkt( kstp - nit000 + 1, cw_toprst_cxt ) 100 #endif 101 ENDIF 91 102 IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init) 92 CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell iom we are at time step kstp 103 104 #if defined key_si3 105 IF(((kstp + nn_fsbc - 1) == nitrst) .AND. lwxios) THEN 106 CALL iom_swap( cw_icerst_cxt ) 107 CALL iom_init_closedef(cw_icerst_cxt) 108 CALL iom_setkt( kstp - nit000 + 1, cw_icerst_cxt ) 109 ENDIF 110 #endif 93 111 94 112 ! ==> clem: open boundaries is mandatory for sea-ice because ice BDY is not decoupled from … … 128 146 ! File manipulation at the end of the first time step 129 147 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 130 IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file 148 IF( kstp == nit000 ) THEN 149 CALL iom_close( numror ) ! close input ocean restart file 150 IF( lrxios ) CALL iom_context_finalize( cr_ocerst_cxt ) 151 ENDIF 131 152 132 153 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 140 161 CALL iom_close( numrow ) 141 162 ELSE 142 CALL iom_context_finalize( cwxios_context ) 163 CALL iom_context_finalize( cw_ocerst_cxt ) 164 iom_file(numrow)%nfid = 0 165 numrow = 0 143 166 ENDIF 144 167 lrst_oce = .FALSE. -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/SWE/domain.F90
r13458 r14046 66 66 CONTAINS 67 67 68 SUBROUTINE dom_init( Kbb, Kmm, Kaa , cdstr)68 SUBROUTINE dom_init( Kbb, Kmm, Kaa ) 69 69 !!---------------------------------------------------------------------- 70 70 !! *** ROUTINE dom_init *** … … 82 82 !!---------------------------------------------------------------------- 83 83 INTEGER , INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices 84 CHARACTER (len=*), INTENT(in) :: cdstr ! model: NEMO or SAS. Determines core restart variables85 84 ! 86 85 !!st6 … … 135 134 CALL dom_nam ! read namelist ( namrun, namdom ) 136 135 ! 137 IF( lwxios ) THEN138 !define names for restart write and set core output (restart.F90)139 CALL iom_set_rst_vars(rst_wfields)140 CALL iom_set_rstw_core(cdstr)141 ENDIF142 !reset namelist for SAS143 IF(cdstr == 'SAS') THEN144 IF(lrxios) THEN145 IF(lwp) write(numout,*) 'Disable reading restart file using XIOS for SAS'146 lrxios = .FALSE.147 ENDIF148 ENDIF149 !150 136 CALL dom_hgr ! Horizontal mesh 151 137 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/SWE/domvvl.F90
r13472 r14046 1105 1105 IF( ln_rstart ) THEN !* Read the restart file 1106 1106 CALL rst_read_open ! open the restart file if necessary 1107 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) , ldxios = lrxios)1107 CALL iom_get( numror, jpdom_auto, 'sshn' , ssh(:,:,Kmm) ) 1108 1108 ! 1109 1109 id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) … … 1118 1118 ! 1119 1119 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 1120 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lrxios)1121 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lrxios)1120 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 1121 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 1122 1122 ! needed to restart if land processor not computed 1123 1123 IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' … … 1133 1133 IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 1134 1134 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 1135 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lrxios)1135 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 1136 1136 e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 1137 1137 l_1st_euler = .true. … … 1140 1140 IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 1141 1141 IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 1142 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lrxios)1142 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 1143 1143 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 1144 1144 l_1st_euler = .true. … … 1165 1165 ! ! ----------------------- ! 1166 1166 IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist 1167 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) , ldxios = lrxios)1168 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) , ldxios = lrxios)1167 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 1168 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 1169 1169 ELSE ! one at least array is missing 1170 1170 tilde_e3t_b(:,:,:) = 0.0_wp … … 1175 1175 ! ! ------------ ! 1176 1176 IF( id5 > 0 ) THEN ! required array exists 1177 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) , ldxios = lrxios)1177 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) 1178 1178 ELSE ! array is missing 1179 1179 hdiv_lf(:,:,:) = 0.0_wp … … 1251 1251 ! ! =================== 1252 1252 IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 1253 IF( lwxios ) CALL iom_swap( cwxios_context )1254 1253 ! ! --------- ! 1255 1254 ! ! all cases ! 1256 1255 ! ! --------- ! 1257 CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) , ldxios = lwxios)1258 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) , ldxios = lwxios)1256 CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) ) 1257 CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) ) 1259 1258 ! ! ----------------------- ! 1260 1259 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases ! 1261 1260 ! ! ----------------------- ! 1262 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:) , ldxios = lwxios)1263 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:) , ldxios = lwxios)1261 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:)) 1262 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:)) 1264 1263 END IF 1265 1264 ! ! -------------! 1266 1265 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 1267 1266 ! ! ------------ ! 1268 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:) , ldxios = lwxios)1267 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:)) 1269 1268 ENDIF 1270 1269 ! 1271 IF( lwxios ) CALL iom_swap( cxios_context )1272 1270 ENDIF 1273 1271 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/SWE/nemogcm.F90
r12983 r14046 383 383 CALL phy_cst ! Physical constants 384 384 385 CALL dom_init( Nbb, Nnn, Naa , "OPA") ! Domain385 CALL dom_init( Nbb, Nnn, Naa ) ! Domain 386 386 387 387 IF( sn_cfctl%l_prtctl ) & -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/SWE/step.F90
r13458 r14046 304 304 IF( kstp == nitend .OR. indic < 0 ) THEN 305 305 CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 306 IF(lrxios) CALL iom_context_finalize( cr xios_context )306 IF(lrxios) CALL iom_context_finalize( cr_ocerst_cxt ) 307 307 ENDIF 308 308 #endif -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/SWE/stepLF.F90
r13295 r14046 318 318 IF( kstp == nitend .OR. indic < 0 ) THEN 319 319 CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 320 IF(lrxios) CALL iom_context_finalize( cr xios_context )320 IF(lrxios) CALL iom_context_finalize( cr_ocerst_cxt ) 321 321 ENDIF 322 322 #endif -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/SWE/stpRK3.F90
r13295 r14046 361 361 IF( kstp == nitend .OR. indic < 0 ) THEN 362 362 CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF 363 IF(lrxios) CALL iom_context_finalize( cr xios_context )363 IF(lrxios) CALL iom_context_finalize( cr_ocerst_cxt ) 364 364 ENDIF 365 365 #endif -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/TOP/C14/trcsms_c14.F90
r13295 r14046 144 144 IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' 145 145 ! 146 CALL iom_rstput( kt, nitrst, numrtw, 'co2sbc', co2sbc ) 147 CALL iom_rstput( kt, nitrst, numrtw, 'c14sbc', c14sbc ) 146 CALL iom_rstput( kt, nitrst, numrtw, 'co2sbc', co2sbc ) ! These five need & 147 CALL iom_rstput( kt, nitrst, numrtw, 'c14sbc', c14sbc ) ! & to be written & 148 148 CALL iom_rstput( kt, nitrst, numrtw, 'exch_co2', exch_co2 ) ! & for temporal & 149 149 CALL iom_rstput( kt, nitrst, numrtw, 'exch_c14', exch_c14 ) ! & averages & 150 CALL iom_rstput( kt, nitrst, numrtw, 'qtr_c14', qtr_c14 )! & to be coherent.150 CALL iom_rstput( kt, nitrst, numrtw, 'qtr_c14', qtr_c14 ) ! & to be coherent. 151 151 CALL iom_rstput( kt, nitrst, numrtw, 'qint_c14', qint_c14 ) ! Cumulative 152 152 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/TOP/PISCES/P4Z/p4zsms.F90
r13472 r14046 369 369 IF(lwp) WRITE(numout,*) '~~~~~~~' 370 370 ENDIF 371 CALL iom_rstput( kt, nitrst, numrtw, 'PH', hi(:,:,:) )372 CALL iom_rstput( kt, nitrst, numrtw, 'Silicalim', xksi(:,:) )371 CALL iom_rstput( kt, nitrst, numrtw, 'PH', hi(:,:,:) ) 372 CALL iom_rstput( kt, nitrst, numrtw, 'Silicalim', xksi(:,:) ) 373 373 CALL iom_rstput( kt, nitrst, numrtw, 'Silicamax', xksimax(:,:) ) 374 374 CALL iom_rstput( kt, nitrst, numrtw, 'tcflxcum', t_oce_co2_flx_cum ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/TOP/PISCES/SED/sed.F90
r10425 r14046 44 44 REAL , PUBLIC :: sedmask 45 45 REAL(wp), PUBLIC :: denssol !: density of solid material 46 INTEGER , PUBLIC :: numrsr, numrsw !: logical unit for sed restart (read and write)47 46 LOGICAL , PUBLIC :: lrst_sed !: logical to control the trc restart write 48 47 LOGICAL , PUBLIC :: ln_rst_sed = .TRUE. !: initialisation from a restart file or not -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/TOP/PISCES/SED/sedrst.F90
r13286 r14046 42 42 CHARACTER(LEN=50) :: clname ! trc output restart file name 43 43 CHARACTER(LEN=256) :: clpath ! full path to ocean output restart file 44 CHARACTER(LEN=52) :: clpname ! trc output restart file name including AGRIF 44 45 !!---------------------------------------------------------------------- 45 46 ! … … 80 81 IF(lwp) WRITE(numsed,*) & 81 82 ' open sed restart.output NetCDF file: ',TRIM(clpath)//clname 82 CALL iom_open( TRIM(clpath)//TRIM(clname), numrsw, ldwrt = .TRUE., kdlev = jpksed, cdcomp = 'SED' ) 83 IF(.NOT.lwxios) THEN 84 CALL iom_open( TRIM(clpath)//TRIM(clname), numrsw, ldwrt = .TRUE., kdlev = jpksed, cdcomp = 'SED' ) 85 ELSE 86 #if defined key_iomput 87 cw_sedrst_cxt = "rstws_"//TRIM(ADJUSTL(clkt)) 88 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 89 clpname = clname 90 ELSE 91 clpname = TRIM(Agrif_CFixed())//"_"//clname 92 ENDIF 93 numrsw = iom_xios_setid(TRIM(clpath)//TRIM(clpname)) 94 CALL iom_init( cw_sedrst_cxt, kdid = numrsw, ld_closedef = .FALSE. ) 95 #else 96 clinfo = 'Can not use XIOS in trc_rst_opn' 97 CALL ctl_stop(TRIM(clinfo)) 98 #endif 99 ENDIF 100 83 101 lrst_sed = .TRUE. 84 102 ENDIF … … 196 214 CALL pack_arr( jpoce, sedligand(1:jpoce,1:jpksed), & 197 215 & zdta2(1:jpi,1:jpj,1:jpksed), iarroce(1:jpoce) ) 198 199 216 IF( ln_timing ) CALL timing_stop('sed_rst_read') 200 217 … … 240 257 !! 1. WRITE in nutwrs 241 258 !! ------------------ 242 243 zinfo(1) = REAL( kt) 244 CALL iom_rstput( kt, nitrst, numrsw, 'kt', zinfo ) 259 ! zinfo(1) = REAL( kt) 260 CALL iom_rstput( kt, nitrst, numrsw, 'kt', REAL( kt , wp) ) 245 261 246 262 ! Back to 2D geometry … … 299 315 300 316 IF( kt == nitrst ) THEN 301 CALL iom_close( numrsw ) ! close the restart file (only at last time step) 317 IF(.NOT.lwxios) THEN 318 CALL iom_close( numrsw ) ! close the restart file (only at last time step) 319 ELSE 320 CALL iom_context_finalize( cw_sedrst_cxt ) 321 iom_file(numrsw)%nfid = 0 322 numrsw = 0 323 ENDIF 302 324 IF( l_offline .AND. ln_rst_list ) THEN 303 325 nrst_lst = nrst_lst + 1 … … 342 364 REAL(wp) :: zkt, zrdttrc1 343 365 REAL(wp) :: zndastp 366 CHARACTER(len = 82) :: clpname 344 367 345 368 ! Time domain : restart … … 353 376 354 377 IF( ln_rst_sed ) THEN 378 lxios_sini = .FALSE. 355 379 CALL iom_open( TRIM(cn_sedrst_indir)//'/'//cn_sedrst_in, numrsr ) 380 381 IF( lrxios) THEN 382 cr_sedrst_cxt = 'sed_rst' 383 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS for SED' 384 ! IF( TRIM(Agrif_CFixed()) == '0' ) THEN 385 ! clpname = cn_sedrst_in 386 ! ELSE 387 ! clpname = TRIM(Agrif_CFixed())//"_"//cn_sedrst_in 388 ! ENDIF 389 CALL iom_init( cr_sedrst_cxt, kdid = numrsr, ld_closedef = .TRUE. ) 390 ENDIF 356 391 CALL iom_get ( numrsr, 'kt', zkt ) ! last time-step of previous run 357 358 392 IF(lwp) THEN 359 393 WRITE(numsed,*) ' *** Info read in restart : ' … … 402 436 IF(lwp) WRITE(numsed,*) 'trc_wri : write the TOP restart file (NetCDF) at it= ', kt, ' date= ', ndastp 403 437 IF(lwp) WRITE(numsed,*) '~~~~~~~' 438 IF( lwxios ) CALL iom_init_closedef(cw_sedrst_cxt) 404 439 ENDIF 405 440 CALL iom_rstput( kt, nitrst, numrsw, 'kt' , REAL( kt , wp) ) ! time-step 406 441 CALL iom_rstput( kt, nitrst, numrsw, 'ndastp' , REAL( ndastp, wp) ) ! date 407 CALL iom_rstput( kt, nitrst, numrsw, 'adatrj' , adatrj 408 ! ! the begining of the run [s]442 CALL iom_rstput( kt, nitrst, numrsw, 'adatrj' , adatrj ) ! number of elapsed days since 443 ! ! the begining of the run [s] 409 444 ENDIF 410 445 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/TOP/PISCES/SED/sedstp.F90
r12489 r14046 86 86 IF( kt == nitsed000 ) THEN 87 87 CALL iom_close( numrsr ) ! close input tracer restart file 88 ! IF(lwm) CALL FLUSH( numont ) ! flush namelist output 88 IF(lrxios) CALL iom_context_finalize( cr_sedrst_cxt ) 89 ! IF(lwm) CALL FLUSH( numont ) ! flush namelist output 89 90 ENDIF 90 91 IF( lrst_sed ) CALL sed_rst_wri( kt ) ! restart file output -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/TOP/TRP/trcadv.F90
r13286 r14046 22 22 USE traadv_cen ! centered scheme (tra_adv_cen routine) 23 23 USE traadv_fct ! FCT scheme (tra_adv_fct routine) 24 USE traadv_fct_lf ! FCT scheme (tra_adv_fct routine - loop fusion version) 24 25 USE traadv_mus ! MUSCL scheme (tra_adv_mus routine) 26 USE traadv_mus_lf ! MUSCL scheme (tra_adv_mus routine - loop fusion version) 25 27 USE traadv_ubs ! UBS scheme (tra_adv_ubs routine) 26 28 USE traadv_qck ! QUICKEST scheme (tra_adv_qck routine) … … 124 126 ! 125 127 CASE ( np_CEN ) ! Centered : 2nd / 4th order 128 IF (nn_hls.EQ.2) CALL lbc_lnk( 'trcadv', ptr(:,:,:,:,Kmm), 'T', 1.) 126 129 CALL tra_adv_cen( kt, nittrc000,'TRC', zuu, zvv, zww, Kmm, ptr, jptra, Krhs, nn_cen_h, nn_cen_v ) 127 130 CASE ( np_FCT ) ! FCT : 2nd / 4th order 128 CALL tra_adv_fct( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_fct_h, nn_fct_v ) 131 IF (nn_hls.EQ.2) THEN 132 CALL lbc_lnk_multi( 'trcadv', ptr(:,:,:,:,Kbb), 'T', 1., ptr(:,:,:,:,Kmm), 'T', 1.) 133 CALL lbc_lnk_multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1., zww(:,:,:), 'W', 1.) 134 #if defined key_loop_fusion 135 CALL tra_adv_fct_lf( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_fct_h, nn_fct_v ) 136 #else 137 CALL tra_adv_fct( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_fct_h, nn_fct_v ) 138 #endif 139 ELSE 140 CALL tra_adv_fct( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_fct_h, nn_fct_v ) 141 END IF 129 142 CASE ( np_MUS ) ! MUSCL 130 CALL tra_adv_mus( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups ) 143 IF (nn_hls.EQ.2) THEN 144 IF (nn_hls.EQ.2) CALL lbc_lnk( 'trcadv', ptr(:,:,:,:,Kbb), 'T', 1.) 145 #if defined key_loop_fusion 146 CALL tra_adv_mus_lf( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups ) 147 #else 148 CALL tra_adv_mus( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups ) 149 #endif 150 ELSE 151 CALL tra_adv_mus( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups ) 152 END IF 131 153 CASE ( np_UBS ) ! UBS 154 IF (nn_hls.EQ.2) CALL lbc_lnk( 'trcadv', ptr(:,:,:,:,Kbb), 'T', 1.) 132 155 CALL tra_adv_ubs( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_ubs_v ) 133 156 CASE ( np_QCK ) ! QUICKEST 157 IF (nn_hls.EQ.2) THEN 158 CALL lbc_lnk_multi( 'trcadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1.) 159 CALL lbc_lnk( 'traadv', ptr(:,:,:,:,Kbb), 'T', 1.) 160 END IF 134 161 CALL tra_adv_qck( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs ) 135 162 ! -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/TOP/TRP/trcldf.F90
r13295 r14046 101 101 & ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Krhs), jptra, 1 ) 102 102 CASE ( np_blp , np_blp_i , np_blp_it ) ! bilaplacian: all operator (iso-level, -neutral) 103 IF(nn_hls.EQ.2) CALL lbc_lnk( 'trc_ldf', ptr(:,:,:,:,Kbb), 'T',1.) 103 104 CALL tra_ldf_blp ( kt, Kmm, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi, & 104 105 & ptr(:,:,:,:,Kbb) , ptr(:,:,:,:,Krhs), jptra, nldf_trc ) -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/TOP/trc.F90
r13558 r14046 21 21 INTEGER, PUBLIC :: numonr = -1 !: reference passive tracer namelist output output.namelist.top 22 22 INTEGER, PUBLIC :: numstr !: tracer statistics 23 INTEGER, PUBLIC :: numrtr = -1 !: trc restart (read )24 INTEGER, PUBLIC :: numrtw !: trc restart ( write )25 23 CHARACTER(:), ALLOCATABLE, PUBLIC :: numnat_ref !: character buffer for reference passive tracer namelist_top_ref 26 24 CHARACTER(:), ALLOCATABLE, PUBLIC :: numnat_cfg !: character buffer for configuration specific passive tracer namelist_top_cfg -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/TOP/trcrst.F90
r13558 r14046 52 52 CHARACTER(LEN=50) :: clname ! trc output restart file name 53 53 CHARACTER(LEN=256) :: clpath ! full path to ocean output restart file 54 CHARACTER(LEN=50) :: clpname ! trc output restart file name including AGRIF 54 55 !!---------------------------------------------------------------------- 55 56 ! … … 91 92 IF(lwp) WRITE(numout,*) & 92 93 ' open trc restart.output NetCDF file: ',TRIM(clpath)//clname 93 CALL iom_open( TRIM(clpath)//TRIM(clname), numrtw, ldwrt = .TRUE. ) 94 IF(.NOT.lwxios) THEN 95 CALL iom_open( TRIM(clpath)//TRIM(clname), numrtw, ldwrt = .TRUE. ) 96 ELSE 97 #if defined key_iomput 98 cw_toprst_cxt = "rstwt_"//TRIM(ADJUSTL(clkt)) 99 IF( TRIM(Agrif_CFixed()) == '0' ) THEN 100 clpname = clname 101 ELSE 102 clpname = TRIM(Agrif_CFixed())//"_"//clname 103 ENDIF 104 numrtw = iom_xios_setid(TRIM(clpath)//TRIM(clpname)) 105 CALL iom_init( cw_toprst_cxt, kdid = numrtw, ld_closedef = .FALSE. ) 106 #else 107 clinfo = 'Can not use XIOS in trc_rst_opn' 108 CALL ctl_stop(TRIM(clinfo)) 109 #endif 110 ENDIF 94 111 lrst_trc = .TRUE. 95 112 ENDIF … … 121 138 END DO 122 139 ! 123 CALL iom_delay_rst( 'READ', 'TOP', numrtr ) ! read only TOP delayed global communication variables 124 140 IF(.NOT.lrxios) CALL iom_delay_rst( 'READ', 'TOP', numrtr ) ! read only TOP delayed global communication variables 125 141 END SUBROUTINE trc_rst_read 126 142 … … 147 163 CALL iom_rstput( kt, nitrst, numrtw, 'TRB'//ctrcnm(jn), tr(:,:,:,jn,Kbb) ) 148 164 END DO 149 ! 150 CALL iom_delay_rst( 'WRITE', 'TOP', numrtw ) ! save only TOP delayed global communication variables165 166 IF( .NOT. lwxios ) CALL iom_delay_rst( 'WRITE', 'TOP', numrtw ) ! save only TOP delayed global communication variables 151 167 152 168 IF( kt == nitrst ) THEN 153 169 CALL trc_rst_stat( Kmm, Krhs ) ! statistics 154 CALL iom_close( numrtw ) ! close the restart file (only at last time step) 170 IF(lwxios) THEN 171 CALL iom_context_finalize( cw_toprst_cxt ) 172 iom_file(numrtw)%nfid = 0 173 numrtw = 0 174 ELSE 175 CALL iom_close( numrtw ) ! close the restart file (only at last time step) 176 ENDIF 155 177 #if ! defined key_trdmxl_trc 156 178 lrst_trc = .FALSE. … … 196 218 REAL(wp) :: zrdttrc1, zkt, zndastp, zdayfrac, ksecs, ktime 197 219 INTEGER :: ihour, iminute 220 CHARACTER(len=82) :: clpname 198 221 199 222 ! Time domain : restart … … 207 230 208 231 IF( ln_rsttr ) THEN 232 lxios_sini = .FALSE. 209 233 CALL iom_open( TRIM(cn_trcrst_indir)//'/'//cn_trcrst_in, numrtr ) 234 IF( lrxios) THEN 235 cr_toprst_cxt = 'top_rst' 236 IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS for TOP' 237 ! IF( TRIM(Agrif_CFixed()) == '0' ) THEN 238 ! clpname = cn_trcrst_in 239 ! ELSE 240 ! clpname = TRIM(Agrif_CFixed())//"_"//cn_trcrst_in 241 ! ENDIF 242 CALL iom_init( cr_toprst_cxt, kdid = numrtr, ld_closedef = .TRUE. ) 243 ENDIF 244 210 245 CALL iom_get ( numrtr, 'kt', zkt ) ! last time-step of previous run 211 246 … … 293 328 IF(lwp) WRITE(numout,*) '~~~~~~~' 294 329 ENDIF 295 CALL iom_rstput( kt, nitrst, numrtw, 'kt' , REAL( kt , wp) ) ! time-step296 CALL iom_rstput( kt, nitrst, numrtw, 'ndastp' , REAL( ndastp, wp) ) ! date297 CALL iom_rstput( kt, nitrst, numrtw, 'adatrj' , adatrj ) ! number of elapsed days since330 CALL iom_rstput( kt, nitrst, numrtw, 'kt' , REAL( kt , wp) ) ! time-step 331 CALL iom_rstput( kt, nitrst, numrtw, 'ndastp' , REAL( ndastp, wp) ) ! date 332 CALL iom_rstput( kt, nitrst, numrtw, 'adatrj' , adatrj ) ! number of elapsed days since 298 333 ! ! the begining of the run [s] 299 CALL iom_rstput( kt, nitrst, numrtw, 'ntime' , REAL( nn_time0, wp) ) ! time334 CALL iom_rstput( kt, nitrst, numrtw, 'ntime' , REAL( nn_time0, wp) ) ! time 300 335 ENDIF 301 336 -
NEMO/branches/2020/dev_r13723_KERNEL-01_Amy_Mike_newHPGschemes/src/TOP/trcstp.F90
r13286 r14046 110 110 IF( kt == nittrc000 ) THEN 111 111 CALL iom_close( numrtr ) ! close input tracer restart file 112 IF(lrxios) CALL iom_context_finalize( cr_toprst_cxt ) 112 113 IF(lwm) CALL FLUSH( numont ) ! flush namelist output 113 114 ENDIF … … 196 197 & .AND. iom_varid( numrtr, 'ktdcy' , ldstop = .FALSE. ) > 0 & 197 198 & .AND. iom_varid( numrtr, 'nrdcy' , ldstop = .FALSE. ) > 0 ) THEN 198 199 199 CALL iom_get( numrtr, 'ktdcy', zkt ) 200 200 rsecfst = INT( zkt ) * rn_Dt
Note: See TracChangeset
for help on using the changeset viewer.