- Timestamp:
- 2019-07-31T15:56:02+02:00 (5 years ago)
- Location:
- NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization
- Files:
-
- 34 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/ICE/ice.F90
r11377 r11380 102 102 !! vt_i | - | Total ice vol. per unit area | m | 103 103 !! vt_s | - | Total snow vol. per unit ar. | m | 104 !! st_i | - | Total Sea ice salt content | pss.m |105 104 !! sm_i | - | Mean sea ice salinity | pss | 106 105 !! tm_i | - | Mean sea ice temperature | K | … … 136 135 REAL(wp), PUBLIC :: rn_ishlat !: lateral boundary condition for sea-ice 137 136 LOGICAL , PUBLIC :: ln_landfast_L16 !: landfast ice parameterizationfrom lemieux2016 137 LOGICAL , PUBLIC :: ln_landfast_home !: landfast ice parameterizationfrom home made 138 138 REAL(wp), PUBLIC :: rn_depfra !: fraction of ocean depth that ice must reach to initiate landfast ice 139 139 REAL(wp), PUBLIC :: rn_icebfr !: maximum bottom stress per unit area of contact (lemieux2016) or per unit volume (home) … … 252 252 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_err_sub !: mass flux error after sublimation [kg.m-2.s-1] 253 253 254 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_tot !: ice concentration tendency (total) [s-1] 255 254 256 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bog !: salt flux due to ice bottom growth [pss.kg.m-2.s-1 => g.m-2.s-1] 255 257 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bom !: salt flux due to ice bottom melt [pss.kg.m-2.s-1 => g.m-2.s-1] … … 307 309 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice !: components of the ice velocity (m/s) 308 310 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_i , vt_s !: ice and snow total volume per unit area (m) 309 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: st_i !: Total ice salinity content (pss.m)310 311 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_i !: ice total fractional area (ice concentration) 311 312 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ato_i !: =1-at_i ; total open water fractional area … … 408 409 & wfx_bog (jpi,jpj) , wfx_dyn (jpi,jpj) , wfx_bom(jpi,jpj) , wfx_sum(jpi,jpj) , & 409 410 & wfx_res (jpi,jpj) , wfx_sni (jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) , & 410 & rn_amax_2d (jpi,jpj) ,&411 & afx_tot (jpi,jpj) , rn_amax_2d(jpi,jpj), & 411 412 & qsb_ice_bot(jpi,jpj) , qlead (jpi,jpj) , & 412 413 & sfx_res (jpi,jpj) , sfx_bri (jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj) , sfx_lam(jpi,jpj) , & … … 428 429 ii = ii + 1 429 430 ALLOCATE( u_ice(jpi,jpj) , v_ice(jpi,jpj) , & 430 & vt_i (jpi,jpj) , vt_s (jpi,jpj) , st_i(jpi,jpj) ,at_i(jpi,jpj) , ato_i(jpi,jpj) , &431 & et_i (jpi,jpj) , et_s (jpi,jpj) , tm_i(jpi,jpj) , tm_s (jpi,jpj) , &432 & sm_i (jpi,jpj) , tm_su(jpi,jpj) , hm_i(jpi,jpj) , hm_s (jpi,jpj) , &431 & vt_i (jpi,jpj) , vt_s (jpi,jpj) , at_i(jpi,jpj) , ato_i(jpi,jpj) , & 432 & et_i (jpi,jpj) , et_s (jpi,jpj) , tm_i(jpi,jpj) , tm_s (jpi,jpj) , & 433 & sm_i (jpi,jpj) , tm_su(jpi,jpj) , hm_i(jpi,jpj) , hm_s (jpi,jpj) , & 433 434 & om_i (jpi,jpj) , bvm_i(jpi,jpj) , tau_icebfr(jpi,jpj) , STAT=ierr(ii) ) 434 435 -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/ICE/icecor.F90
r11371 r11380 84 84 ! !----------------------------------------------------- 85 85 IF ( nn_icesal == 2 ) THEN ! salinity must stay in bounds [Simin,Simax] ! 86 !!-----------------------------------------------------86 ! !----------------------------------------------------- 87 87 zzc = rhoi * r1_rdtice 88 88 DO jl = 1, jpl … … 117 117 END DO 118 118 END DO 119 CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1., v_ice, 'V', -1. ) 119 CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1., v_ice, 'V', -1. ) ! lateral boundary conditions 120 120 ENDIF 121 121 122 !!gm I guess the trends are only out on demand 123 !! So please, only do this is it exite an iom_use of on a these variables 124 !! furthermore, only allocate the diag_ arrays in this case 125 !! and do the iom_put here so that it is only a local allocation 126 !!gm 122 127 ! !----------------------------------------------------- 123 128 SELECT CASE( kn ) ! Diagnostics ! … … 138 143 END DO 139 144 ! ! concentration tendency (dynamics) 140 IF( iom_use('afxdyn') .OR. iom_use('afxthd') .OR. iom_use('afxtot') ) THEN 141 zafx(:,:) = SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_rdtice 142 CALL iom_put( 'afxdyn' , zafx ) 143 ENDIF 145 zafx (:,:) = SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_rdtice 146 afx_tot(:,:) = zafx(:,:) 147 IF( iom_use('afxdyn') ) CALL iom_put( 'afxdyn' , zafx(:,:) ) 144 148 ! 145 149 CASE( 2 ) !--- thermo trend diagnostics & ice aging … … 160 164 END DO 161 165 ! ! concentration tendency (total + thermo) 162 IF( iom_use('afxdyn') .OR. iom_use('afxthd') .OR. iom_use('afxtot') ) THEN 163 zafx(:,:) = zafx(:,:) + SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_rdtice 164 CALL iom_put( 'afxthd' , SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_rdtice ) 165 CALL iom_put( 'afxtot' , zafx ) 166 ENDIF 166 zafx (:,:) = SUM( a_i(:,:,:) - a_i_b(:,:,:), dim=3 ) * r1_rdtice 167 afx_tot(:,:) = afx_tot(:,:) + zafx(:,:) 168 IF( iom_use('afxthd') ) CALL iom_put( 'afxthd' , zafx(:,:) ) 169 IF( iom_use('afxtot') ) CALL iom_put( 'afxtot' , afx_tot(:,:) ) 167 170 ! 168 171 END SELECT … … 171 174 IF( ln_icediachk ) CALL ice_cons_hsm(1, 'icecor', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 172 175 IF( ln_ctl ) CALL ice_prt3D ('icecor') ! prints 173 IF( ln_icectl .AND. kn == 2 ) & 174 & CALL ice_prt ( kt, iiceprt, jiceprt, 2, ' - Final state - ' ) ! prints 176 IF( ln_icectl .AND. kn == 2 ) CALL ice_prt( kt, iiceprt, jiceprt, 2, ' - Final state - ' ) ! prints 175 177 IF( ln_timing ) CALL timing_stop ('icecor') ! timing 176 178 ! -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/ICE/icedia.F90
r11371 r11380 34 34 PUBLIC ice_dia_init ! called in icestp.F90 35 35 36 REAL(wp), SAVE :: z1_e1e2 ! inverse of the ocean area 37 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: vol_loc_ini, sal_loc_ini, tem_loc_ini ! initial volume, salt and heat contents 36 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: vol_loc_ini, sal_loc_ini, tem_loc_ini ! initial volume, salt and heat contents 38 37 REAL(wp) :: frc_sal, frc_voltop, frc_volbot, frc_temtop, frc_tembot ! global forcing trends 39 38 … … 81 80 ENDIF 82 81 83 IF( kt == nit000 ) THEN 84 z1_e1e2 = 1._wp / glob_sum( 'icedia', e1e2t(:,:) ) 85 ENDIF 82 !!gm glob_sum includes a " * tmask_i ", so remove " * tmask(:,:,1) " 83 84 ! ----------------------- ! 85 ! 1 - Contents ! 86 ! ----------------------- ! 87 zbg_ivol = glob_sum( 'icedia', vt_i(:,:) * e1e2t(:,:) ) * 1.e-9 ! ice volume (km3) 88 zbg_svol = glob_sum( 'icedia', vt_s(:,:) * e1e2t(:,:) ) * 1.e-9 ! snow volume (km3) 89 zbg_area = glob_sum( 'icedia', at_i(:,:) * e1e2t(:,:) ) * 1.e-6 ! area (km2) 90 zbg_isal = glob_sum( 'icedia', SUM( sv_i(:,:,:), dim=3 ) * e1e2t(:,:) ) * 1.e-9 ! salt content (pss*km3) 91 zbg_item = glob_sum( 'icedia', et_i * e1e2t(:,:) ) * 1.e-20 ! heat content (1.e20 J) 92 zbg_stem = glob_sum( 'icedia', et_s * e1e2t(:,:) ) * 1.e-20 ! heat content (1.e20 J) 86 93 87 ! ----------------------- !88 ! 1 - Contents !89 ! ----------------------- !90 IF( iom_use('ibgvol_tot' ) .OR. iom_use('sbgvol_tot' ) .OR. iom_use('ibgarea_tot') .OR. &91 & iom_use('ibgsalt_tot') .OR. iom_use('ibgheat_tot') .OR. iom_use('sbgheat_tot') ) THEN92 93 zbg_ivol = glob_sum( 'icedia', vt_i(:,:) * e1e2t(:,:) ) * 1.e-9 ! ice volume (km3)94 zbg_svol = glob_sum( 'icedia', vt_s(:,:) * e1e2t(:,:) ) * 1.e-9 ! snow volume (km3)95 zbg_area = glob_sum( 'icedia', at_i(:,:) * e1e2t(:,:) ) * 1.e-6 ! area (km2)96 zbg_isal = glob_sum( 'icedia', st_i(:,:) * e1e2t(:,:) ) * 1.e-9 ! salt content (pss*km3)97 zbg_item = glob_sum( 'icedia', et_i(:,:) * e1e2t(:,:) ) * 1.e-20 ! heat content (1.e20 J)98 zbg_stem = glob_sum( 'icedia', et_s(:,:) * e1e2t(:,:) ) * 1.e-20 ! heat content (1.e20 J)99 100 CALL iom_put( 'ibgvol_tot' , zbg_ivol )101 CALL iom_put( 'sbgvol_tot' , zbg_svol )102 CALL iom_put( 'ibgarea_tot' , zbg_area )103 CALL iom_put( 'ibgsalt_tot' , zbg_isal )104 CALL iom_put( 'ibgheat_tot' , zbg_item )105 CALL iom_put( 'sbgheat_tot' , zbg_stem )106 107 ENDIF108 109 94 ! ---------------------------! 110 95 ! 2 - Trends due to forcing ! 111 96 ! ---------------------------! 112 ! they must be kept outside an IF(iom_use) because of the call to dia_rst below113 97 z_frc_volbot = r1_rau0 * glob_sum( 'icedia', -( wfx_ice(:,:) + wfx_snw(:,:) + wfx_err_sub(:,:) ) * e1e2t(:,:) ) * 1.e-9 ! freshwater flux ice/snow-ocean 114 98 z_frc_voltop = r1_rau0 * glob_sum( 'icedia', -( wfx_sub(:,:) + wfx_spr(:,:) ) * e1e2t(:,:) ) * 1.e-9 ! freshwater flux ice/snow-atm … … 122 106 frc_temtop = frc_temtop + z_frc_temtop * rdt_ice ! 1.e20 J 123 107 frc_tembot = frc_tembot + z_frc_tembot * rdt_ice ! 1.e20 J 124 125 CALL iom_put( 'ibgfrcvoltop' , frc_voltop ) ! vol forcing ice/snw-atm (km3 equivalent ocean water)126 CALL iom_put( 'ibgfrcvolbot' , frc_volbot ) ! vol forcing ice/snw-ocean (km3 equivalent ocean water)127 CALL iom_put( 'ibgfrcsal' , frc_sal ) ! sal - forcing (psu*km3 equivalent ocean water)128 CALL iom_put( 'ibgfrctemtop' , frc_temtop ) ! heat on top of ice/snw/ocean (1.e20 J)129 CALL iom_put( 'ibgfrctembot' , frc_tembot ) ! heat on top of ocean(below ice) (1.e20 J)130 131 IF( iom_use('ibgfrchfxtop') .OR. iom_use('ibgfrchfxbot') ) THEN132 CALL iom_put( 'ibgfrchfxtop' , frc_temtop * z1_e1e2 * 1.e-20 * kt*rdt ) ! heat on top of ice/snw/ocean (W/m2)133 CALL iom_put( 'ibgfrchfxbot' , frc_tembot * z1_e1e2 * 1.e-20 * kt*rdt ) ! heat on top of ocean(below ice) (W/m2)134 ENDIF135 136 ! ---------------------------------- !137 ! 3 - Content variations and drifts !138 ! ---------------------------------- !139 IF( iom_use('ibgvolume') .OR. iom_use('ibgsaltco') .OR. iom_use('ibgheatco') .OR. iom_use('ibgheatfx') ) THEN140 108 141 zdiff_vol = r1_rau0 * glob_sum( 'icedia', ( rhoi*vt_i(:,:) + rhos*vt_s(:,:) - vol_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-9 ! freshwater trend (km3) 142 zdiff_sal = r1_rau0 * glob_sum( 'icedia', ( rhoi*st_i(:,:) - sal_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-9 ! salt content trend (km3*pss) 143 zdiff_tem = glob_sum( 'icedia', ( et_i(:,:) + et_s(:,:) - tem_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-20 ! heat content trend (1.e20 J) 144 ! + SUM( qevap_ice * a_i_b, dim=3 ) !! clem: I think this term should not be there (but needs a check) 145 146 zdiff_vol = zdiff_vol - ( frc_voltop + frc_volbot ) 147 zdiff_sal = zdiff_sal - frc_sal 148 zdiff_tem = zdiff_tem - ( frc_tembot - frc_temtop ) 149 150 CALL iom_put( 'ibgvolume' , zdiff_vol ) ! ice/snow volume drift (km3 equivalent ocean water) 151 CALL iom_put( 'ibgsaltco' , zdiff_sal ) ! ice salt content drift (psu*km3 equivalent ocean water) 152 CALL iom_put( 'ibgheatco' , zdiff_tem ) ! ice/snow heat content drift (1.e20 J) 153 ! 154 ENDIF 155 109 ! ----------------------- ! 110 ! 3 - Content variations ! 111 ! ----------------------- ! 112 zdiff_vol = r1_rau0 * glob_sum( 'icedia', ( rhoi*vt_i(:,:) + rhos*vt_s(:,:) - vol_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-9 ! freshwater trend (km3) 113 zdiff_sal = r1_rau0 * glob_sum( 'icedia', ( rhoi* SUM( sv_i(:,:,:), dim=3 ) - sal_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-9 ! salt content trend (km3*pss) 114 zdiff_tem = glob_sum( 'icedia', ( et_i(:,:) + et_s(:,:) - tem_loc_ini(:,:) ) * e1e2t(:,:) ) * 1.e-20 ! heat content trend (1.e20 J) 115 ! + SUM( qevap_ice * a_i_b, dim=3 ) !! clem: I think this term should not be there (but needs a check) 116 117 ! ----------------------- ! 118 ! 4 - Drifts ! 119 ! ----------------------- ! 120 zdiff_vol = zdiff_vol - ( frc_voltop + frc_volbot ) 121 zdiff_sal = zdiff_sal - frc_sal 122 zdiff_tem = zdiff_tem - ( frc_tembot - frc_temtop ) 123 124 ! ----------------------- ! 125 ! 5 - Diagnostics writing ! 126 ! ----------------------- ! 127 !!gm I don't understand the division by the ocean surface (i.e. glob_sum( 'icedia', e1e2t(:,:) ) * 1.e-20 * kt*rdt ) 128 !! and its multiplication bu kt ! is it really what we want ? what is this quantity ? 129 !! IF it is really what we want, compute it at kt=nit000, not 3 time by time-step ! 130 !! kt*rdt : you mean rdtice ? 131 !!gm 132 ! 133 IF( iom_use('ibgvolume') ) CALL iom_put( 'ibgvolume' , zdiff_vol ) ! ice/snow volume drift (km3 equivalent ocean water) 134 IF( iom_use('ibgsaltco') ) CALL iom_put( 'ibgsaltco' , zdiff_sal ) ! ice salt content drift (psu*km3 equivalent ocean water) 135 IF( iom_use('ibgheatco') ) CALL iom_put( 'ibgheatco' , zdiff_tem ) ! ice/snow heat content drift (1.e20 J) 136 IF( iom_use('ibgheatfx') ) CALL iom_put( 'ibgheatfx' , & ! ice/snow heat flux drift (W/m2) 137 & zdiff_tem /glob_sum( 'icedia', e1e2t(:,:) * 1.e-20 * kt*rdt ) ) 138 139 IF( iom_use('ibgfrcvoltop') ) CALL iom_put( 'ibgfrcvoltop' , frc_voltop ) ! vol forcing ice/snw-atm (km3 equivalent ocean water) 140 IF( iom_use('ibgfrcvolbot') ) CALL iom_put( 'ibgfrcvolbot' , frc_volbot ) ! vol forcing ice/snw-ocean (km3 equivalent ocean water) 141 IF( iom_use('ibgfrcsal') ) CALL iom_put( 'ibgfrcsal' , frc_sal ) ! sal - forcing (psu*km3 equivalent ocean water) 142 IF( iom_use('ibgfrctemtop') ) CALL iom_put( 'ibgfrctemtop' , frc_temtop ) ! heat on top of ice/snw/ocean (1.e20 J) 143 IF( iom_use('ibgfrctembot') ) CALL iom_put( 'ibgfrctembot' , frc_tembot ) ! heat on top of ocean(below ice) (1.e20 J) 144 IF( iom_use('ibgfrchfxtop') ) CALL iom_put( 'ibgfrchfxtop' , & ! heat on top of ice/snw/ocean (W/m2) 145 & frc_temtop / glob_sum( 'icedia', e1e2t(:,:) ) * 1.e-20 * kt*rdt ) 146 IF( iom_use('ibgfrchfxbot') ) CALL iom_put( 'ibgfrchfxbot' , & ! heat on top of ocean(below ice) (W/m2) 147 & frc_tembot / glob_sum( 'icedia', e1e2t(:,:) ) * 1.e-20 * kt*rdt ) 148 149 IF( iom_use('ibgvol_tot' ) ) CALL iom_put( 'ibgvol_tot' , zbg_ivol ) ! ice volume (km3) 150 IF( iom_use('sbgvol_tot' ) ) CALL iom_put( 'sbgvol_tot' , zbg_svol ) ! snow volume (km3) 151 IF( iom_use('ibgarea_tot') ) CALL iom_put( 'ibgarea_tot' , zbg_area ) ! ice area (km2) 152 IF( iom_use('ibgsalt_tot') ) CALL iom_put( 'ibgsalt_tot' , zbg_isal ) ! ice salinity content (pss*km3) 153 IF( iom_use('ibgheat_tot') ) CALL iom_put( 'ibgheat_tot' , zbg_item ) ! ice heat content (1.e20 J) 154 IF( iom_use('sbgheat_tot') ) CALL iom_put( 'sbgheat_tot' , zbg_stem ) ! snow heat content (1.e20 J) 155 ! 156 156 IF( lrst_ice ) CALL ice_dia_rst( 'WRITE', kt_ice ) 157 157 ! … … 248 248 vol_loc_ini(:,:) = rhoi * vt_i(:,:) + rhos * vt_s(:,:) ! ice/snow volume (kg/m2) 249 249 tem_loc_ini(:,:) = et_i(:,:) + et_s(:,:) ! ice/snow heat content (J) 250 sal_loc_ini(:,:) = rhoi * st_i(:,:)! ice salt content (pss*kg/m2)250 sal_loc_ini(:,:) = rhoi * SUM( sv_i(:,:,:), dim=3 ) ! ice salt content (pss*kg/m2) 251 251 ENDIF 252 252 ! -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/ICE/icedyn.F90
r11377 r11380 163 163 END DO 164 164 CALL lbc_lnk( 'icedyn', zdivu_i, 'T', 1. ) 165 ! output 166 CALL iom_put( 'icediv' , zdivu_i ) 167 165 CALL iom_put( "icediv" , zdivu_i(:,:) ) 168 166 DEALLOCATE( zdivu_i ) 169 167 … … 221 219 NAMELIST/namdyn/ ln_dynALL, ln_dynRHGADV, ln_dynADV1D, ln_dynADV2D, rn_uice, rn_vice, & 222 220 & rn_ishlat , & 223 & ln_landfast_L16, rn_depfra, rn_icebfr, rn_lfrelax, rn_tensile221 & ln_landfast_L16, ln_landfast_home, rn_depfra, rn_icebfr, rn_lfrelax, rn_tensile 224 222 !!------------------------------------------------------------------- 225 223 ! … … 244 242 WRITE(numout,*) ' lateral boundary condition for sea ice dynamics rn_ishlat = ', rn_ishlat 245 243 WRITE(numout,*) ' Landfast: param from Lemieux 2016 ln_landfast_L16 = ', ln_landfast_L16 244 WRITE(numout,*) ' Landfast: param from home made ln_landfast_home= ', ln_landfast_home 246 245 WRITE(numout,*) ' fraction of ocean depth that ice must reach rn_depfra = ', rn_depfra 247 246 WRITE(numout,*) ' maximum bottom stress per unit area of contact rn_icebfr = ', rn_icebfr … … 270 269 ENDIF 271 270 ! !--- Landfast ice 272 IF( .NOT.ln_landfast_L16 ) tau_icebfr(:,:) = 0._wp 271 IF( .NOT.ln_landfast_L16 .AND. .NOT.ln_landfast_home ) tau_icebfr(:,:) = 0._wp 272 ! 273 IF ( ln_landfast_L16 .AND. ln_landfast_home ) THEN 274 CALL ctl_stop( 'ice_dyn_init: choose one and only one landfast parameterization (ln_landfast_L16 or ln_landfast_home)' ) 275 ENDIF 273 276 ! 274 277 CALL ice_dyn_rdgrft_init ! set ice ridging/rafting parameters -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/ICE/icedyn_adv.F90
r11371 r11380 100 100 diag_trp_vi(:,:) = SUM( v_i (:,:,:) - v_i_b (:,:,:) , dim=3 ) * r1_rdtice 101 101 diag_trp_vs(:,:) = SUM( v_s (:,:,:) - v_s_b (:,:,:) , dim=3 ) * r1_rdtice 102 IF( iom_use('icemtrp') ) CALL iom_put( 'icemtrp' ,diag_trp_vi * rhoi ) ! ice mass transport103 IF( iom_use('snwmtrp') ) CALL iom_put( 'snwmtrp' ,diag_trp_vs * rhos ) ! snw mass transport104 IF( iom_use('salmtrp') ) CALL iom_put( 'salmtrp' ,diag_trp_sv * rhoi * 1.e-03 ) ! salt mass transport (kg/m2/s)105 IF( iom_use('dihctrp') ) CALL iom_put( 'dihctrp' , -diag_trp_ei) ! advected ice heat content (W/m2)106 IF( iom_use('dshctrp') ) CALL iom_put( 'dshctrp' , -diag_trp_es) ! advected snw heat content (W/m2)102 IF( iom_use('icemtrp') ) CALL iom_put( "icemtrp" , diag_trp_vi * rhoi ) ! ice mass transport 103 IF( iom_use('snwmtrp') ) CALL iom_put( "snwmtrp" , diag_trp_vs * rhos ) ! snw mass transport 104 IF( iom_use('salmtrp') ) CALL iom_put( "salmtrp" , diag_trp_sv * rhoi * 1.e-03 ) ! salt mass transport (kg/m2/s) 105 IF( iom_use('dihctrp') ) CALL iom_put( "dihctrp" , -diag_trp_ei ) ! advected ice heat content (W/m2) 106 IF( iom_use('dshctrp') ) CALL iom_put( "dshctrp" , -diag_trp_es ) ! advected snw heat content (W/m2) 107 107 108 108 ! controls -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/ICE/icedyn_rhg.F90
r11377 r11380 69 69 WRITE(numout,*)'ice_dyn_rhg: sea-ice rheology' 70 70 WRITE(numout,*)'~~~~~~~~~~~' 71 ENDIF 72 ! 73 IF( ln_landfast_home ) THEN !-- Landfast ice parameterization 74 tau_icebfr(:,:) = 0._wp 75 DO jl = 1, jpl 76 WHERE( h_i(:,:,jl) > ht_n(:,:) * rn_depfra ) tau_icebfr(:,:) = tau_icebfr(:,:) + a_i(:,:,jl) * rn_icebfr 77 END DO 71 78 ENDIF 72 79 ! -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/ICE/icedyn_rhg_evp.F90
r11377 r11380 112 112 REAL(wp), DIMENSION(:,:), INTENT( out) :: pshear_i , pdivu_i , pdelta_i ! 113 113 !! 114 LOGICAL, PARAMETER :: ll_bdy_substep = .TRUE. ! temporary option to call bdy at each sub-time step (T) 115 ! or only at the main time step (F) 114 116 INTEGER :: ji, jj ! dummy loop indices 115 117 INTEGER :: jter ! local integers … … 135 137 ! 136 138 REAL(wp), DIMENSION(jpi,jpj) :: zdt_m ! (dt / ice-snow_mass) on T points 137 REAL(wp), DIMENSION(jpi,jpj) :: zaU , zaV! ice fraction on U/V points139 REAL(wp), DIMENSION(jpi,jpj) :: zaU , zaV ! ice fraction on U/V points 138 140 REAL(wp), DIMENSION(jpi,jpj) :: zmU_t, zmV_t ! (ice-snow_mass / dt) on U/V points 139 141 REAL(wp), DIMENSION(jpi,jpj) :: zmf ! coriolis parameter at T points 142 REAL(wp), DIMENSION(jpi,jpj) :: zTauU_ia , ztauV_ia ! ice-atm. stress at U-V points 143 REAL(wp), DIMENSION(jpi,jpj) :: zTauU_ib , ztauV_ib ! ice-bottom stress at U-V points (landfast param) 144 REAL(wp), DIMENSION(jpi,jpj) :: zspgU , zspgV ! surface pressure gradient at U/V points 140 145 REAL(wp), DIMENSION(jpi,jpj) :: v_oceU, u_oceV, v_iceU, u_iceV ! ocean/ice u/v component on V/U points 146 REAL(wp), DIMENSION(jpi,jpj) :: zfU , zfV ! internal stresses 141 147 ! 142 148 REAL(wp), DIMENSION(jpi,jpj) :: zds ! shear … … 146 152 ! ! ocean surface (ssh_m) if ice is not embedded 147 153 ! ! ice bottom surface if ice is embedded 148 REAL(wp), DIMENSION(jpi,jpj) :: zfU , zfV ! internal stresses 149 REAL(wp), DIMENSION(jpi,jpj) :: zspgU, zspgV ! surface pressure gradient at U/V points 150 REAL(wp), DIMENSION(jpi,jpj) :: zCorU, zCorV ! Coriolis stress array 151 REAL(wp), DIMENSION(jpi,jpj) :: ztaux_ai, ztauy_ai ! ice-atm. stress at U-V points 152 REAL(wp), DIMENSION(jpi,jpj) :: ztaux_oi, ztauy_oi ! ice-ocean stress at U-V points 153 REAL(wp), DIMENSION(jpi,jpj) :: ztaux_bi, ztauy_bi ! ice-OceanBottom stress at U-V points (landfast) 154 REAL(wp), DIMENSION(jpi,jpj) :: ztaux_base, ztauy_base ! ice-bottom stress at U-V points (landfast) 155 ! 156 REAL(wp), DIMENSION(jpi,jpj) :: zmsk01x, zmsk01y ! dummy arrays 157 REAL(wp), DIMENSION(jpi,jpj) :: zmsk00x, zmsk00y ! mask for ice presence 154 REAL(wp), DIMENSION(jpi,jpj) :: zCorx, zCory ! Coriolis stress array 155 REAL(wp), DIMENSION(jpi,jpj) :: ztaux_oi, ztauy_oi ! Ocean-to-ice stress array 156 ! 157 REAL(wp), DIMENSION(jpi,jpj) :: zswitchU, zswitchV ! dummy arrays 158 REAL(wp), DIMENSION(jpi,jpj) :: zmaskU, zmaskV ! mask for ice presence 158 159 REAL(wp), DIMENSION(jpi,jpj) :: zfmask, zwf ! mask at F points for the ice 159 160 … … 162 163 REAL(wp), PARAMETER :: zamin = 0.001_wp ! ice concentration below which ice velocity becomes very small 163 164 !! --- diags 164 REAL(wp), DIMENSION(jpi,jpj) :: z msk00165 REAL(wp), DIMENSION(jpi,jpj) :: zswi 165 166 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zsig1, zsig2, zsig3 166 167 !! --- SIMIP diags 168 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_sig1 ! Average normal stress in sea ice 169 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_sig2 ! Maximum shear stress in sea ice 170 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_dssh_dx ! X-direction sea-surface tilt term (N/m2) 171 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_dssh_dy ! X-direction sea-surface tilt term (N/m2) 172 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_corstrx ! X-direction coriolis stress (N/m2) 173 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_corstry ! Y-direction coriolis stress (N/m2) 174 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_intstrx ! X-direction internal stress (N/m2) 175 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_intstry ! Y-direction internal stress (N/m2) 176 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_utau_oi ! X-direction ocean-ice stress 177 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_vtau_oi ! Y-direction ocean-ice stress 167 178 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_xmtrp_ice ! X-component of ice mass transport (kg/s) 168 179 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdiag_ymtrp_ice ! Y-component of ice mass transport (kg/s) … … 253 264 254 265 ! landfast param from Lemieux(2016): add isotropic tensile strength (following Konig Beatty and Holland, 2010) 255 IF( ln_landfast_L16 ) THEN ; zkt = rn_tensile256 ELSE ; zkt = 0._wp266 IF( ln_landfast_L16 .OR. ln_landfast_home ) THEN ; zkt = rn_tensile 267 ELSE ; zkt = 0._wp 257 268 ENDIF 258 269 ! … … 297 308 298 309 ! Drag ice-atm. 299 z taux_ai(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj)300 z tauy_ai(ji,jj) = zaV(ji,jj) * vtau_ice(ji,jj)310 zTauU_ia(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj) 311 zTauV_ia(ji,jj) = zaV(ji,jj) * vtau_ice(ji,jj) 301 312 302 313 ! Surface pressure gradient (- m*g*GRAD(ssh)) at U-V points … … 305 316 306 317 ! masks 307 zm sk00x(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassU ) ) ! 0 if no ice308 zm sk00y(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassV ) ) ! 0 if no ice318 zmaskU(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassU ) ) ! 0 if no ice 319 zmaskV(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassV ) ) ! 0 if no ice 309 320 310 321 ! switches 311 IF( zmassU <= zmmin .AND. zaU(ji,jj) <= zamin ) THEN ; z msk01x(ji,jj) = 0._wp312 ELSE ; z msk01x(ji,jj) = 1._wp ; ENDIF313 IF( zmassV <= zmmin .AND. zaV(ji,jj) <= zamin ) THEN ; z msk01y(ji,jj) = 0._wp314 ELSE ; z msk01y(ji,jj) = 1._wp ; ENDIF322 IF( zmassU <= zmmin .AND. zaU(ji,jj) <= zamin ) THEN ; zswitchU(ji,jj) = 0._wp 323 ELSE ; zswitchU(ji,jj) = 1._wp ; ENDIF 324 IF( zmassV <= zmmin .AND. zaV(ji,jj) <= zamin ) THEN ; zswitchV(ji,jj) = 0._wp 325 ELSE ; zswitchV(ji,jj) = 1._wp ; ENDIF 315 326 316 327 END DO … … 328 339 ! ice-bottom stress at U points 329 340 zvCr = zaU(ji,jj) * rn_depfra * hu_n(ji,jj) 330 z taux_base(ji,jj) = -rn_icebfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) )341 zTauU_ib(ji,jj) = rn_icebfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 331 342 ! ice-bottom stress at V points 332 343 zvCr = zaV(ji,jj) * rn_depfra * hv_n(ji,jj) 333 z tauy_base(ji,jj) = -rn_icebfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) )344 zTauV_ib(ji,jj) = rn_icebfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 334 345 ! ice_bottom stress at T points 335 346 zvCr = at_i(ji,jj) * rn_depfra * ht_n(ji,jj) 336 tau_icebfr(ji,jj) = -rn_icebfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) )347 tau_icebfr(ji,jj) = rn_icebfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 337 348 END DO 338 349 END DO 339 350 CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1. ) 340 351 ! 341 ELSE !-- no landfast352 ELSEIF( ln_landfast_home ) THEN !-- Home made 342 353 DO jj = 2, jpjm1 343 354 DO ji = fs_2, fs_jpim1 344 ztaux_base(ji,jj) = 0._wp 345 ztauy_base(ji,jj) = 0._wp 355 zTauU_ib(ji,jj) = tau_icebfr(ji,jj) 356 zTauV_ib(ji,jj) = tau_icebfr(ji,jj) 357 END DO 358 END DO 359 ! 360 ELSE !-- no landfast 361 DO jj = 2, jpjm1 362 DO ji = fs_2, fs_jpim1 363 zTauU_ib(ji,jj) = 0._wp 364 zTauV_ib(ji,jj) = 0._wp 346 365 END DO 347 366 END DO 348 367 ENDIF 368 IF( iom_use('tau_icebfr') ) CALL iom_put( 'tau_icebfr', tau_icebfr(:,:) ) 349 369 350 370 !------------------------------------------------------------------------------! … … 484 504 ! !--- tau_bottom/v_ice 485 505 zvel = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) 486 zTauB = ztauy_base(ji,jj) / zvel 487 ! !--- OceanBottom-to-Ice stress 488 ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) 506 zTauB = - zTauV_ib(ji,jj) / zvel 489 507 ! 490 508 ! !--- Coriolis at V-points (energy conserving formulation) 491 zCor V(ji,jj) = - 0.25_wp * r1_e2v(ji,jj) * &509 zCory(ji,jj) = - 0.25_wp * r1_e2v(ji,jj) * & 492 510 & ( zmf(ji,jj ) * ( e2u(ji,jj ) * u_ice(ji,jj ) + e2u(ji-1,jj ) * u_ice(ji-1,jj ) ) & 493 511 & + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 494 512 ! 495 513 ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 496 zTauE = zfV(ji,jj) + z tauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj)514 zTauE = zfV(ji,jj) + zTauV_ia(ji,jj) + zCory(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) 497 515 ! 498 516 ! !--- landfast switch => 0 = static friction ; 1 = sliding friction 499 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, ztauE + ztauy_base(ji,jj) ) - SIGN( 1._wp, zTauE ) ) )517 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, ztauE - zTauV_ib(ji,jj) ) - SIGN( 1._wp, zTauE ) ) ) 500 518 ! 501 519 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 502 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * v_ice(ji,jj) + v_ice_b(ji,jj) )& ! previous velocity503 & + zTauE + zTauO * v_ice(ji,jj) )& ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)504 &/ MAX( zepsi, zmV_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast505 &+ ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! static friction => slow decrease to v=0506 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin507 & ) * zmsk00y(ji,jj)520 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity 521 & + zTauE + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 522 & ) / MAX( zepsi, zmV_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 523 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! static friction => slow decrease to v=0 524 & ) * zswitchV(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zswitchV(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 525 & ) * zmaskV(ji,jj) 508 526 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 509 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) &! previous velocity510 & + zTauE + zTauO * v_ice(ji,jj) ) &! F + tau_ia + Coriolis + spg + tau_io(only ocean part)511 & / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) &! m/dt + tau_io(only ice part) + landfast512 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) &! static friction => slow decrease to v=0513 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) &! v_ice = v_oce/100 if mass < zmmin & conc < zamin514 & ) * zmsk00y(ji,jj)527 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity 528 & + zTauE + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 529 & ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 530 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! static friction => slow decrease to v=0 531 & ) * zswitchV(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zswitchV(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 532 & ) * zmaskV(ji,jj) 515 533 ENDIF 516 534 END DO … … 522 540 CALL agrif_interp_ice( 'V' ) 523 541 #endif 524 IF( ln_bdy )CALL bdy_ice_dyn( 'V' )542 IF( ln_bdy .AND. ll_bdy_substep ) CALL bdy_ice_dyn( 'V' ) 525 543 ! 526 544 DO jj = 2, jpjm1 … … 534 552 ! !--- tau_bottom/u_ice 535 553 zvel = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) 536 zTauB = ztaux_base(ji,jj) / zvel 537 ! !--- OceanBottom-to-Ice stress 538 ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) 554 zTauB = - zTauU_ib(ji,jj) / zvel 539 555 ! 540 556 ! !--- Coriolis at U-points (energy conserving formulation) 541 zCor U(ji,jj) = 0.25_wp * r1_e1u(ji,jj) * &557 zCorx(ji,jj) = 0.25_wp * r1_e1u(ji,jj) * & 542 558 & ( zmf(ji ,jj) * ( e1v(ji ,jj) * v_ice(ji ,jj) + e1v(ji ,jj-1) * v_ice(ji ,jj-1) ) & 543 559 & + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 544 560 ! 545 561 ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 546 zTauE = zfU(ji,jj) + z taux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj)562 zTauE = zfU(ji,jj) + zTauU_ia(ji,jj) + zCorx(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) 547 563 ! 548 564 ! !--- landfast switch => 0 = static friction ; 1 = sliding friction 549 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, ztauE + ztaux_base(ji,jj) ) - SIGN( 1._wp, zTauE ) ) )565 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, ztauE - zTauU_ib(ji,jj) ) - SIGN( 1._wp, zTauE ) ) ) 550 566 ! 551 567 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 552 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * u_ice(ji,jj) + u_ice_b(ji,jj) )& ! previous velocity553 & + zTauE + zTauO * u_ice(ji,jj) )& ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)554 &/ MAX( zepsi, zmU_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast555 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )& ! static friction => slow decrease to v=0556 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin557 & ) * zmsk00x(ji,jj)568 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity 569 & + zTauE + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 570 & ) / MAX( zepsi, zmU_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 571 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! static friction => slow decrease to v=0 572 & ) * zswitchU(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zswitchU(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 573 & ) * zmaskU(ji,jj) 558 574 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 559 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) &! previous velocity560 & + zTauE + zTauO * u_ice(ji,jj) ) &! F + tau_ia + Coriolis + spg + tau_io(only ocean part)561 & / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) &! m/dt + tau_io(only ice part) + landfast562 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) &! static friction => slow decrease to v=0563 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) &! v_ice = v_oce/100 if mass < zmmin & conc < zamin564 & ) * zmsk00x(ji,jj)575 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity 576 & + zTauE + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 577 & ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 578 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! static friction => slow decrease to v=0 579 & ) * zswitchU(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zswitchU(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 580 & ) * zmaskU(ji,jj) 565 581 ENDIF 566 582 END DO … … 572 588 CALL agrif_interp_ice( 'U' ) 573 589 #endif 574 IF( ln_bdy )CALL bdy_ice_dyn( 'U' )590 IF( ln_bdy .AND. ll_bdy_substep ) CALL bdy_ice_dyn( 'U' ) 575 591 ! 576 592 ELSE ! odd iterations … … 586 602 ! !--- tau_bottom/u_ice 587 603 zvel = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) 588 zTauB = ztaux_base(ji,jj) / zvel 589 ! !--- OceanBottom-to-Ice stress 590 ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) 604 zTauB = - zTauU_ib(ji,jj) / zvel 591 605 ! 592 606 ! !--- Coriolis at U-points (energy conserving formulation) 593 zCor U(ji,jj) = 0.25_wp * r1_e1u(ji,jj) * &607 zCorx(ji,jj) = 0.25_wp * r1_e1u(ji,jj) * & 594 608 & ( zmf(ji ,jj) * ( e1v(ji ,jj) * v_ice(ji ,jj) + e1v(ji ,jj-1) * v_ice(ji ,jj-1) ) & 595 609 & + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 596 610 ! 597 611 ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 598 zTauE = zfU(ji,jj) + z taux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj)612 zTauE = zfU(ji,jj) + zTauU_ia(ji,jj) + zCorx(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) 599 613 ! 600 614 ! !--- landfast switch => 0 = static friction ; 1 = sliding friction 601 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, ztauE + ztaux_base(ji,jj) ) - SIGN( 1._wp, zTauE ) ) )615 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, ztauE - zTauU_ib(ji,jj) ) - SIGN( 1._wp, zTauE ) ) ) 602 616 ! 603 617 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 604 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * u_ice(ji,jj) + u_ice_b(ji,jj) )& ! previous velocity605 & + zTauE + zTauO * u_ice(ji,jj) )& ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)606 &/ MAX( zepsi, zmU_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast607 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )& ! static friction => slow decrease to v=0608 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin609 & ) * zmsk00x(ji,jj)618 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * u_ice(ji,jj) + u_ice_b(ji,jj) ) & ! previous velocity 619 & + zTauE + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 620 & ) / MAX( zepsi, zmU_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 621 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! static friction => slow decrease to v=0 622 & ) * zswitchU(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zswitchU(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 623 & ) * zmaskU(ji,jj) 610 624 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 611 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) &! previous velocity612 & + zTauE + zTauO * u_ice(ji,jj) ) &! F + tau_ia + Coriolis + spg + tau_io(only ocean part)613 & / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) &! m/dt + tau_io(only ice part) + landfast614 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) &! static friction => slow decrease to v=0615 & ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) ) &! v_ice = v_oce/100 if mass < zmmin & conc < zamin616 & ) * zmsk00x(ji,jj)625 u_ice(ji,jj) = ( ( rswitch * ( zmU_t(ji,jj) * u_ice(ji,jj) & ! previous velocity 626 & + zTauE + zTauO * u_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 627 & ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 628 & + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! static friction => slow decrease to v=0 629 & ) * zswitchU(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zswitchU(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 630 & ) * zmaskU(ji,jj) 617 631 ENDIF 618 632 END DO … … 624 638 CALL agrif_interp_ice( 'U' ) 625 639 #endif 626 IF( ln_bdy )CALL bdy_ice_dyn( 'U' )640 IF( ln_bdy .AND. ll_bdy_substep ) CALL bdy_ice_dyn( 'U' ) 627 641 ! 628 642 DO jj = 2, jpjm1 … … 636 650 ! !--- tau_bottom/v_ice 637 651 zvel = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) 638 zTauB = ztauy_base(ji,jj) / zvel 639 ! !--- OceanBottom-to-Ice stress 640 ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) 652 zTauB = - zTauV_ib(ji,jj) / zvel 641 653 ! 642 654 ! !--- Coriolis at v-points (energy conserving formulation) 643 zCor V(ji,jj) = - 0.25_wp * r1_e2v(ji,jj) * &655 zCory(ji,jj) = - 0.25_wp * r1_e2v(ji,jj) * & 644 656 & ( zmf(ji,jj ) * ( e2u(ji,jj ) * u_ice(ji,jj ) + e2u(ji-1,jj ) * u_ice(ji-1,jj ) ) & 645 657 & + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 646 658 ! 647 659 ! !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 648 zTauE = zfV(ji,jj) + z tauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj)660 zTauE = zfV(ji,jj) + zTauV_ia(ji,jj) + zCory(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) 649 661 ! 650 662 ! !--- landfast switch => 0 = static friction ; 1 = sliding friction 651 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zTauE + ztauy_base(ji,jj) ) - SIGN( 1._wp, zTauE ) ) )663 rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zTauE - zTauV_ib(ji,jj) ) - SIGN( 1._wp, zTauE ) ) ) 652 664 ! 653 665 IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 654 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * v_ice(ji,jj) + v_ice_b(ji,jj) )& ! previous velocity655 & + zTauE + zTauO * v_ice(ji,jj) )& ! F + tau_ia + Coriolis + spg + tau_io(only ocean part)656 &/ MAX( zepsi, zmV_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast657 &+ ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! static friction => slow decrease to v=0658 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin659 & ) * zmsk00y(ji,jj)666 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * v_ice(ji,jj) + v_ice_b(ji,jj) ) & ! previous velocity 667 & + zTauE + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 668 & ) / MAX( zepsi, zmV_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 669 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! static friction => slow decrease to v=0 670 & ) * zswitchV(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zswitchV(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 671 & ) * zmaskV(ji,jj) 660 672 ELSE !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 661 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) &! previous velocity662 & + zTauE + zTauO * v_ice(ji,jj) ) &! F + tau_ia + Coriolis + spg + tau_io(only ocean part)663 & / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) &! m/dt + tau_io(only ice part) + landfast664 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) &! static friction => slow decrease to v=0665 & ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) ) &! v_ice = v_oce/100 if mass < zmmin & conc < zamin666 & ) * zmsk00y(ji,jj)673 v_ice(ji,jj) = ( ( rswitch * ( zmV_t(ji,jj) * v_ice(ji,jj) & ! previous velocity 674 & + zTauE + zTauO * v_ice(ji,jj) & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 675 & ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 676 & + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax ) & ! static friction => slow decrease to v=0 677 & ) * zswitchV(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zswitchV(ji,jj) ) & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 678 & ) * zmaskV(ji,jj) 667 679 ENDIF 668 680 END DO … … 674 686 CALL agrif_interp_ice( 'V' ) 675 687 #endif 676 IF( ln_bdy )CALL bdy_ice_dyn( 'V' )688 IF( ln_bdy .AND. ll_bdy_substep ) CALL bdy_ice_dyn( 'V' ) 677 689 ! 678 690 ENDIF … … 689 701 END DO ! end loop over jter ! 690 702 ! ! ==================== ! 703 ! 704 IF( ln_bdy .AND. .NOT.ll_bdy_substep ) THEN 705 CALL bdy_ice_dyn( 'U' ) 706 CALL bdy_ice_dyn( 'V' ) 707 ENDIF 691 708 ! 692 709 !------------------------------------------------------------------------------! … … 747 764 DO jj = 1, jpj 748 765 DO ji = 1, jpi 749 z msk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice, 0 if no ice766 zswi(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice, 0 if no ice 750 767 END DO 751 768 END DO 752 769 753 ! --- ice-ocean, ice-atm. & ice-oceanbottom(landfast) stresses --- !754 IF( iom_use('utau_oi') .OR. iom_use('vtau_oi') .OR. iom_use('utau_ai') .OR. iom_use('vtau_ai') .OR. &755 & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN756 !757 CALL lbc_lnk_multi( 'icedyn_rhg_evp', ztaux_oi, 'U', -1., ztauy_oi, 'V', -1., ztaux_ai, 'U', -1., ztauy_ai, 'V', -1., &758 & ztaux_bi, 'U', -1., ztauy_bi, 'V', -1. )759 !760 CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 )761 CALL iom_put( 'vtau_oi' , ztauy_oi * zmsk00 )762 CALL iom_put( 'utau_ai' , ztaux_ai * zmsk00 )763 CALL iom_put( 'vtau_ai' , ztauy_ai * zmsk00 )764 CALL iom_put( 'utau_bi' , ztaux_bi * zmsk00 )765 CALL iom_put( 'vtau_bi' , ztauy_bi * zmsk00 )766 ENDIF767 768 770 ! --- divergence, shear and strength --- ! 769 IF( iom_use('icediv') ) CALL iom_put( 'icediv' , pdivu_i * zmsk00) ! divergence770 IF( iom_use('iceshe') ) CALL iom_put( 'iceshe' , pshear_i * zmsk00) ! shear771 IF( iom_use('icestr') ) CALL iom_put( 'icestr' , strength * zmsk00 ) !strength772 773 ! --- stress tensor--- !774 IF( iom_use('isig1') .OR. iom_use('isig2') .OR. iom_use('isig3') .OR. iom_use('normstr') .OR. iom_use('sheastr')) THEN771 IF( iom_use('icediv') ) CALL iom_put( "icediv" , pdivu_i (:,:) * zswi(:,:) ) ! divergence 772 IF( iom_use('iceshe') ) CALL iom_put( "iceshe" , pshear_i(:,:) * zswi(:,:) ) ! shear 773 IF( iom_use('icestr') ) CALL iom_put( "icestr" , strength(:,:) * zswi(:,:) ) ! Ice strength 774 775 ! --- charge ellipse --- ! 776 IF( iom_use('isig1') .OR. iom_use('isig2') .OR. iom_use('isig3') ) THEN 775 777 ! 776 778 ALLOCATE( zsig1(jpi,jpj) , zsig2(jpi,jpj) , zsig3(jpi,jpj) ) … … 778 780 DO jj = 2, jpjm1 779 781 DO ji = 2, jpim1 780 zdum1 = ( z msk00(ji-1,jj) * pstress12_i(ji-1,jj) + zmsk00(ji ,jj-1) * pstress12_i(ji ,jj-1) + & ! stress12_i at T-point781 & z msk00(ji ,jj) * pstress12_i(ji ,jj) + zmsk00(ji-1,jj-1) * pstress12_i(ji-1,jj-1) ) &782 & / MAX( 1._wp, z msk00(ji-1,jj) + zmsk00(ji,jj-1) + zmsk00(ji,jj) + zmsk00(ji-1,jj-1) )782 zdum1 = ( zswi(ji-1,jj) * pstress12_i(ji-1,jj) + zswi(ji ,jj-1) * pstress12_i(ji ,jj-1) + & ! stress12_i at T-point 783 & zswi(ji ,jj) * pstress12_i(ji ,jj) + zswi(ji-1,jj-1) * pstress12_i(ji-1,jj-1) ) & 784 & / MAX( 1._wp, zswi(ji-1,jj) + zswi(ji,jj-1) + zswi(ji,jj) + zswi(ji-1,jj-1) ) 783 785 784 786 zshear = SQRT( pstress2_i(ji,jj) * pstress2_i(ji,jj) + 4._wp * zdum1 * zdum1 ) ! shear stress 785 787 786 zdum2 = z msk00(ji,jj) / MAX( 1._wp, strength(ji,jj) )788 zdum2 = zswi(ji,jj) / MAX( 1._wp, strength(ji,jj) ) 787 789 788 790 !! zsig1(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) + zshear ) ! principal stress (y-direction, see Hunke & Dukowicz 2002) … … 797 799 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zsig1, 'T', 1., zsig2, 'T', 1., zsig3, 'T', 1. ) 798 800 ! 799 CALL iom_put( 'isig1' , zsig1 ) 800 CALL iom_put( 'isig2' , zsig2 ) 801 CALL iom_put( 'isig3' , zsig3 ) 802 ! 803 ! Stress tensor invariants (normal and shear stress N/m) 804 IF( iom_use('normstr') ) CALL iom_put( 'normstr' , ( zs1(:,:) + zs2(:,:) ) * zmsk00(:,:) ) ! Normal stress 805 IF( iom_use('sheastr') ) CALL iom_put( 'sheastr' , SQRT( ( zs1(:,:) - zs2(:,:) )**2 + 4*zs12(:,:)**2 ) * zmsk00(:,:) ) ! Shear stress 806 801 IF( iom_use('isig1') ) CALL iom_put( "isig1" , zsig1 ) 802 IF( iom_use('isig2') ) CALL iom_put( "isig2" , zsig2 ) 803 IF( iom_use('isig3') ) CALL iom_put( "isig3" , zsig3 ) 804 ! 807 805 DEALLOCATE( zsig1 , zsig2 , zsig3 ) 808 806 ENDIF 809 807 810 808 ! --- SIMIP --- ! 811 IF( iom_use('dssh_dx') .OR. iom_use('dssh_dy') .OR. & 812 & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN 813 ! 814 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zspgU, 'U', -1., zspgV, 'V', -1., & 815 & zCorU, 'U', -1., zCorV, 'V', -1., zfU, 'U', -1., zfV, 'V', -1. ) 816 817 CALL iom_put( 'dssh_dx' , zspgU * zmsk00 ) ! Sea-surface tilt term in force balance (x) 818 CALL iom_put( 'dssh_dy' , zspgV * zmsk00 ) ! Sea-surface tilt term in force balance (y) 819 CALL iom_put( 'corstrx' , zCorU * zmsk00 ) ! Coriolis force term in force balance (x) 820 CALL iom_put( 'corstry' , zCorV * zmsk00 ) ! Coriolis force term in force balance (y) 821 CALL iom_put( 'intstrx' , zfU * zmsk00 ) ! Internal force term in force balance (x) 822 CALL iom_put( 'intstry' , zfV * zmsk00 ) ! Internal force term in force balance (y) 823 ENDIF 824 825 IF( iom_use('xmtrpice') .OR. iom_use('ymtrpice') .OR. & 826 & iom_use('xmtrpsnw') .OR. iom_use('ymtrpsnw') .OR. iom_use('xatrp') .OR. iom_use('yatrp') ) THEN 827 ! 828 ALLOCATE( zdiag_xmtrp_ice(jpi,jpj) , zdiag_ymtrp_ice(jpi,jpj) , & 829 & zdiag_xmtrp_snw(jpi,jpj) , zdiag_ymtrp_snw(jpi,jpj) , zdiag_xatrp(jpi,jpj) , zdiag_yatrp(jpi,jpj) ) 830 ! 809 IF ( iom_use( 'normstr' ) .OR. iom_use( 'sheastr' ) .OR. iom_use( 'dssh_dx' ) .OR. iom_use( 'dssh_dy' ) .OR. & 810 & iom_use( 'corstrx' ) .OR. iom_use( 'corstry' ) .OR. iom_use( 'intstrx' ) .OR. iom_use( 'intstry' ) .OR. & 811 & iom_use( 'utau_oi' ) .OR. iom_use( 'vtau_oi' ) .OR. iom_use( 'xmtrpice' ) .OR. iom_use( 'ymtrpice' ) .OR. & 812 & iom_use( 'xmtrpsnw' ) .OR. iom_use( 'ymtrpsnw' ) .OR. iom_use( 'xatrp' ) .OR. iom_use( 'yatrp' ) ) THEN 813 814 ALLOCATE( zdiag_sig1 (jpi,jpj) , zdiag_sig2 (jpi,jpj) , zdiag_dssh_dx (jpi,jpj) , zdiag_dssh_dy (jpi,jpj) , & 815 & zdiag_corstrx (jpi,jpj) , zdiag_corstry (jpi,jpj) , zdiag_intstrx (jpi,jpj) , zdiag_intstry (jpi,jpj) , & 816 & zdiag_utau_oi (jpi,jpj) , zdiag_vtau_oi (jpi,jpj) , zdiag_xmtrp_ice(jpi,jpj) , zdiag_ymtrp_ice(jpi,jpj) , & 817 & zdiag_xmtrp_snw(jpi,jpj) , zdiag_ymtrp_snw(jpi,jpj) , zdiag_xatrp (jpi,jpj) , zdiag_yatrp (jpi,jpj) ) 818 831 819 DO jj = 2, jpjm1 832 820 DO ji = 2, jpim1 821 rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice, 0 if no ice 822 823 ! Stress tensor invariants (normal and shear stress N/m) 824 zdiag_sig1(ji,jj) = ( zs1(ji,jj) + zs2(ji,jj) ) * rswitch ! normal stress 825 zdiag_sig2(ji,jj) = SQRT( ( zs1(ji,jj) - zs2(ji,jj) )**2 + 4*zs12(ji,jj)**2 ) * rswitch ! shear stress 826 827 ! Stress terms of the momentum equation (N/m2) 828 zdiag_dssh_dx(ji,jj) = zspgU(ji,jj) * rswitch ! sea surface slope stress term 829 zdiag_dssh_dy(ji,jj) = zspgV(ji,jj) * rswitch 830 831 zdiag_corstrx(ji,jj) = zCorx(ji,jj) * rswitch ! Coriolis stress term 832 zdiag_corstry(ji,jj) = zCory(ji,jj) * rswitch 833 834 zdiag_intstrx(ji,jj) = zfU(ji,jj) * rswitch ! internal stress term 835 zdiag_intstry(ji,jj) = zfV(ji,jj) * rswitch 836 837 zdiag_utau_oi(ji,jj) = ztaux_oi(ji,jj) * rswitch ! oceanic stress 838 zdiag_vtau_oi(ji,jj) = ztauy_oi(ji,jj) * rswitch 839 833 840 ! 2D ice mass, snow mass, area transport arrays (X, Y) 834 zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * zmsk00(ji,jj)835 zfac_y = 0.5 * v_ice(ji,jj) * e1v(ji,jj) * zmsk00(ji,jj)836 841 zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * rswitch 842 zfac_y = 0.5 * v_ice(ji,jj) * e1v(ji,jj) * rswitch 843 837 844 zdiag_xmtrp_ice(ji,jj) = rhoi * zfac_x * ( vt_i(ji+1,jj) + vt_i(ji,jj) ) ! ice mass transport, X-component 838 845 zdiag_ymtrp_ice(ji,jj) = rhoi * zfac_y * ( vt_i(ji,jj+1) + vt_i(ji,jj) ) ! '' Y- '' 839 846 840 847 zdiag_xmtrp_snw(ji,jj) = rhos * zfac_x * ( vt_s(ji+1,jj) + vt_s(ji,jj) ) ! snow mass transport, X-component 841 848 zdiag_ymtrp_snw(ji,jj) = rhos * zfac_y * ( vt_s(ji,jj+1) + vt_s(ji,jj) ) ! '' Y- '' 842 849 843 850 zdiag_xatrp(ji,jj) = zfac_x * ( at_i(ji+1,jj) + at_i(ji,jj) ) ! area transport, X-component 844 851 zdiag_yatrp(ji,jj) = zfac_y * ( at_i(ji,jj+1) + at_i(ji,jj) ) ! '' Y- '' 845 846 END DO 847 END DO 848 849 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1., zdiag_ymtrp_ice, 'V', -1., & 850 & zdiag_xmtrp_snw, 'U', -1., zdiag_ymtrp_snw, 'V', -1., & 851 & zdiag_xatrp , 'U', -1., zdiag_yatrp , 'V', -1. ) 852 853 CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice ) ! X-component of sea-ice mass transport (kg/s) 854 CALL iom_put( 'ymtrpice' , zdiag_ymtrp_ice ) ! Y-component of sea-ice mass transport 855 CALL iom_put( 'xmtrpsnw' , zdiag_xmtrp_snw ) ! X-component of snow mass transport (kg/s) 856 CALL iom_put( 'ymtrpsnw' , zdiag_ymtrp_snw ) ! Y-component of snow mass transport 857 CALL iom_put( 'xatrp' , zdiag_xatrp ) ! X-component of ice area transport 858 CALL iom_put( 'yatrp' , zdiag_yatrp ) ! Y-component of ice area transport 859 860 DEALLOCATE( zdiag_xmtrp_ice , zdiag_ymtrp_ice , & 861 & zdiag_xmtrp_snw , zdiag_ymtrp_snw , zdiag_xatrp , zdiag_yatrp ) 852 853 END DO 854 END DO 855 856 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_sig1 , 'T', 1., zdiag_sig2 , 'T', 1., & 857 & zdiag_dssh_dx, 'U', -1., zdiag_dssh_dy, 'V', -1., & 858 & zdiag_corstrx, 'U', -1., zdiag_corstry, 'V', -1., & 859 & zdiag_intstrx, 'U', -1., zdiag_intstry, 'V', -1. ) 860 861 CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_utau_oi , 'U', -1., zdiag_vtau_oi , 'V', -1., & 862 & zdiag_xmtrp_ice, 'U', -1., zdiag_xmtrp_snw, 'U', -1., & 863 & zdiag_xatrp , 'U', -1., zdiag_ymtrp_ice, 'V', -1., & 864 & zdiag_ymtrp_snw, 'V', -1., zdiag_yatrp , 'V', -1. ) 865 866 IF( iom_use('normstr' ) ) CALL iom_put( 'normstr' , zdiag_sig1(:,:) ) ! Normal stress 867 IF( iom_use('sheastr' ) ) CALL iom_put( 'sheastr' , zdiag_sig2(:,:) ) ! Shear stress 868 IF( iom_use('dssh_dx' ) ) CALL iom_put( 'dssh_dx' , zdiag_dssh_dx(:,:) ) ! Sea-surface tilt term in force balance (x) 869 IF( iom_use('dssh_dy' ) ) CALL iom_put( 'dssh_dy' , zdiag_dssh_dy(:,:) ) ! Sea-surface tilt term in force balance (y) 870 IF( iom_use('corstrx' ) ) CALL iom_put( 'corstrx' , zdiag_corstrx(:,:) ) ! Coriolis force term in force balance (x) 871 IF( iom_use('corstry' ) ) CALL iom_put( 'corstry' , zdiag_corstry(:,:) ) ! Coriolis force term in force balance (y) 872 IF( iom_use('intstrx' ) ) CALL iom_put( 'intstrx' , zdiag_intstrx(:,:) ) ! Internal force term in force balance (x) 873 IF( iom_use('intstry' ) ) CALL iom_put( 'intstry' , zdiag_intstry(:,:) ) ! Internal force term in force balance (y) 874 IF( iom_use('utau_oi' ) ) CALL iom_put( 'utau_oi' , zdiag_utau_oi(:,:) ) ! Ocean stress term in force balance (x) 875 IF( iom_use('vtau_oi' ) ) CALL iom_put( 'vtau_oi' , zdiag_vtau_oi(:,:) ) ! Ocean stress term in force balance (y) 876 IF( iom_use('xmtrpice') ) CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice(:,:) ) ! X-component of sea-ice mass transport (kg/s) 877 IF( iom_use('ymtrpice') ) CALL iom_put( 'ymtrpice' , zdiag_ymtrp_ice(:,:) ) ! Y-component of sea-ice mass transport 878 IF( iom_use('xmtrpsnw') ) CALL iom_put( 'xmtrpsnw' , zdiag_xmtrp_snw(:,:) ) ! X-component of snow mass transport (kg/s) 879 IF( iom_use('ymtrpsnw') ) CALL iom_put( 'ymtrpsnw' , zdiag_ymtrp_snw(:,:) ) ! Y-component of snow mass transport 880 IF( iom_use('xatrp' ) ) CALL iom_put( 'xatrp' , zdiag_xatrp(:,:) ) ! X-component of ice area transport 881 IF( iom_use('yatrp' ) ) CALL iom_put( 'yatrp' , zdiag_yatrp(:,:) ) ! Y-component of ice area transport 882 883 DEALLOCATE( zdiag_sig1 , zdiag_sig2 , zdiag_dssh_dx , zdiag_dssh_dy , & 884 & zdiag_corstrx , zdiag_corstry , zdiag_intstrx , zdiag_intstry , & 885 & zdiag_utau_oi , zdiag_vtau_oi , zdiag_xmtrp_ice , zdiag_ymtrp_ice , & 886 & zdiag_xmtrp_snw , zdiag_ymtrp_snw , zdiag_xatrp , zdiag_yatrp ) 862 887 863 888 ENDIF -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/ICE/icesbc.F90
r11371 r11380 114 114 INTEGER, INTENT(in) :: ksbc ! flux formulation (user defined, bulk or Pure Coupled) 115 115 ! 116 INTEGER :: ji, jj, jl ! dummy loop index 117 REAL(wp) :: zmiss_val ! missing value retrieved from xios 118 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zalb_os, zalb_cs ! ice albedo under overcast/clear sky 119 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zalb, zmsk00 ! 2D workspace 116 INTEGER :: ji, jj, jl ! dummy loop index 117 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zalb_os, zalb_cs ! ice albedo under overcast/clear sky 118 REAL(wp), DIMENSION(jpi,jpj) :: zalb ! 2D workspace 120 119 !!-------------------------------------------------------------------- 121 120 ! … … 127 126 WRITE(numout,*)'~~~~~~~~~~~~~~~' 128 127 ENDIF 129 130 ! get missing value from xml131 CALL iom_miss_val( "icetemp", zmiss_val )132 128 133 129 ! --- cloud-sky and overcast-sky ice albedos --- ! … … 156 152 157 153 !--- output ice albedo and surface albedo ---! 158 IF( iom_use('icealb') .OR. iom_use('albedo') ) THEN 159 160 ALLOCATE( zalb(jpi,jpj), zmsk00(jpi,jpj) ) 161 162 WHERE( at_i_b <= epsi06 ) 163 zmsk00(:,:) = 0._wp 164 zalb (:,:) = rn_alb_oce 165 ELSEWHERE 166 zmsk00(:,:) = 1._wp 167 zalb (:,:) = SUM( alb_ice * a_i_b, dim=3 ) / at_i_b 154 IF( iom_use('icealb') ) THEN 155 WHERE( at_i_b <= epsi06 ) ; zalb(:,:) = rn_alb_oce 156 ELSEWHERE ; zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) / at_i_b 168 157 END WHERE 169 ! ice albedo170 CALL iom_put( 'icealb' , zalb * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) )171 ! ice+ocean albedo158 CALL iom_put( "icealb" , zalb(:,:) ) 159 ENDIF 160 IF( iom_use('albedo') ) THEN 172 161 zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) + rn_alb_oce * ( 1._wp - at_i_b ) 173 CALL iom_put( 'albedo' , zalb ) 174 175 DEALLOCATE( zalb, zmsk00 ) 176 162 CALL iom_put( "albedo" , zalb(:,:) ) 177 163 ENDIF 178 164 ! -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/ICE/icestp.F90
r11371 r11380 425 425 wfx_err_sub(:,:) = 0._wp 426 426 ! 427 afx_tot(:,:) = 0._wp ; 428 ! 427 429 diag_heat(:,:) = 0._wp ; diag_sice(:,:) = 0._wp 428 430 diag_vice(:,:) = 0._wp ; diag_vsnw(:,:) = 0._wp -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/ICE/iceupdate.F90
r11371 r11380 198 198 ! --- salt fluxes [kg/m2/s] --- ! 199 199 ! ! sfxice = sfxbog + sfxbom + sfxsum + sfxsni + sfxopw + sfxres + sfxdyn + sfxbri + sfxsub + sfxlam 200 IF( iom_use('sfxice' ) ) CALL iom_put( 'sfxice', sfx * 1.e-03 ) ! salt flux from total ice growth/melt201 IF( iom_use('sfxbog' ) ) CALL iom_put( 'sfxbog', sfx_bog * 1.e-03 ) ! salt flux from bottom growth202 IF( iom_use('sfxbom' ) ) CALL iom_put( 'sfxbom', sfx_bom * 1.e-03 ) ! salt flux from bottom melting203 IF( iom_use('sfxsum' ) ) CALL iom_put( 'sfxsum', sfx_sum * 1.e-03 ) ! salt flux from surface melting204 IF( iom_use('sfxlam' ) ) CALL iom_put( 'sfxlam', sfx_lam * 1.e-03 ) ! salt flux from lateral melting205 IF( iom_use('sfxsni' ) ) CALL iom_put( 'sfxsni', sfx_sni * 1.e-03 ) ! salt flux from snow ice formation206 IF( iom_use('sfxopw' ) ) CALL iom_put( 'sfxopw', sfx_opw * 1.e-03 ) ! salt flux from open water formation207 IF( iom_use('sfxdyn' ) ) CALL iom_put( 'sfxdyn', sfx_dyn * 1.e-03 ) ! salt flux from ridging rafting208 IF( iom_use('sfxbri' ) ) CALL iom_put( 'sfxbri', sfx_bri * 1.e-03 ) ! salt flux from brines209 IF( iom_use('sfxres' ) ) CALL iom_put( 'sfxres', sfx_res * 1.e-03 ) ! salt flux from undiagnosed processes210 IF( iom_use('sfxsub' ) ) CALL iom_put( 'sfxsub', sfx_sub * 1.e-03 ) ! salt flux from sublimation200 IF( iom_use('sfxice' ) ) CALL iom_put( "sfxice", sfx * 1.e-03 ) ! salt flux from total ice growth/melt 201 IF( iom_use('sfxbog' ) ) CALL iom_put( "sfxbog", sfx_bog * 1.e-03 ) ! salt flux from bottom growth 202 IF( iom_use('sfxbom' ) ) CALL iom_put( "sfxbom", sfx_bom * 1.e-03 ) ! salt flux from bottom melting 203 IF( iom_use('sfxsum' ) ) CALL iom_put( "sfxsum", sfx_sum * 1.e-03 ) ! salt flux from surface melting 204 IF( iom_use('sfxlam' ) ) CALL iom_put( "sfxlam", sfx_lam * 1.e-03 ) ! salt flux from lateral melting 205 IF( iom_use('sfxsni' ) ) CALL iom_put( "sfxsni", sfx_sni * 1.e-03 ) ! salt flux from snow ice formation 206 IF( iom_use('sfxopw' ) ) CALL iom_put( "sfxopw", sfx_opw * 1.e-03 ) ! salt flux from open water formation 207 IF( iom_use('sfxdyn' ) ) CALL iom_put( "sfxdyn", sfx_dyn * 1.e-03 ) ! salt flux from ridging rafting 208 IF( iom_use('sfxbri' ) ) CALL iom_put( "sfxbri", sfx_bri * 1.e-03 ) ! salt flux from brines 209 IF( iom_use('sfxres' ) ) CALL iom_put( "sfxres", sfx_res * 1.e-03 ) ! salt flux from undiagnosed processes 210 IF( iom_use('sfxsub' ) ) CALL iom_put( "sfxsub", sfx_sub * 1.e-03 ) ! salt flux from sublimation 211 211 212 212 ! --- mass fluxes [kg/m2/s] --- ! 213 CALL iom_put( 'emp_oce', emp_oce ) ! emp over ocean (taking into account the snow blown away from the ice)214 CALL iom_put( 'emp_ice', emp_ice ) ! emp over ice (taking into account the snow blown away from the ice)213 IF( iom_use('emp_oce' ) ) CALL iom_put( "emp_oce", emp_oce ) ! emp over ocean (taking into account the snow blown away from the ice) 214 IF( iom_use('emp_ice' ) ) CALL iom_put( "emp_ice", emp_ice ) ! emp over ice (taking into account the snow blown away from the ice) 215 215 216 216 ! ! vfxice = vfxbog + vfxbom + vfxsum + vfxsni + vfxopw + vfxdyn + vfxres + vfxlam + vfxpnd 217 CALL iom_put( 'vfxice' , wfx_ice) ! mass flux from total ice growth/melt218 CALL iom_put( 'vfxbog' , wfx_bog) ! mass flux from bottom growth219 CALL iom_put( 'vfxbom' , wfx_bom) ! mass flux from bottom melt220 CALL iom_put( 'vfxsum' , wfx_sum) ! mass flux from surface melt221 CALL iom_put( 'vfxlam' , wfx_lam) ! mass flux from lateral melt222 CALL iom_put( 'vfxsni' , wfx_sni) ! mass flux from snow-ice formation223 CALL iom_put( 'vfxopw' , wfx_opw) ! mass flux from growth in open water224 CALL iom_put( 'vfxdyn' , wfx_dyn) ! mass flux from dynamics (ridging)225 CALL iom_put( 'vfxres' , wfx_res) ! mass flux from undiagnosed processes226 CALL iom_put( 'vfxpnd' , wfx_pnd) ! mass flux from melt ponds227 CALL iom_put( 'vfxsub', wfx_ice_sub ) ! mass flux from ice sublimation (ice-atm.)228 CALL iom_put( 'vfxsub_err', wfx_err_sub ) ! "excess" of sublimation sent to ocean229 230 IF ( iom_use( 'vfxthin') ) THEN ! mass flux from ice growth in open water + thin ice (<20cm) => comparable to observations217 IF( iom_use('vfxice' ) ) CALL iom_put( "vfxice" , wfx_ice ) ! mass flux from total ice growth/melt 218 IF( iom_use('vfxbog' ) ) CALL iom_put( "vfxbog" , wfx_bog ) ! mass flux from bottom growth 219 IF( iom_use('vfxbom' ) ) CALL iom_put( "vfxbom" , wfx_bom ) ! mass flux from bottom melt 220 IF( iom_use('vfxsum' ) ) CALL iom_put( "vfxsum" , wfx_sum ) ! mass flux from surface melt 221 IF( iom_use('vfxlam' ) ) CALL iom_put( "vfxlam" , wfx_lam ) ! mass flux from lateral melt 222 IF( iom_use('vfxsni' ) ) CALL iom_put( "vfxsni" , wfx_sni ) ! mass flux from snow-ice formation 223 IF( iom_use('vfxopw' ) ) CALL iom_put( "vfxopw" , wfx_opw ) ! mass flux from growth in open water 224 IF( iom_use('vfxdyn' ) ) CALL iom_put( "vfxdyn" , wfx_dyn ) ! mass flux from dynamics (ridging) 225 IF( iom_use('vfxres' ) ) CALL iom_put( "vfxres" , wfx_res ) ! mass flux from undiagnosed processes 226 IF( iom_use('vfxpnd' ) ) CALL iom_put( "vfxpnd" , wfx_pnd ) ! mass flux from melt ponds 227 IF( iom_use('vfxsub' ) ) CALL iom_put( "vfxsub" , wfx_ice_sub ) ! mass flux from ice sublimation (ice-atm.) 228 IF( iom_use('vfxsub_err') ) CALL iom_put( "vfxsub_err", wfx_err_sub ) ! "excess" of sublimation sent to ocean 229 230 IF ( iom_use( "vfxthin" ) ) THEN ! mass flux from ice growth in open water + thin ice (<20cm) => comparable to observations 231 231 WHERE( hm_i(:,:) < 0.2 .AND. hm_i(:,:) > 0. ) ; z2d = wfx_bog 232 232 ELSEWHERE ; z2d = 0._wp 233 233 END WHERE 234 CALL iom_put( 'vfxthin', wfx_opw + z2d )235 ENDIF 236 237 ! ! vfxsnw = vfxsnw_sni + vfxsnw_dyn + vfxsnw_sum238 CALL iom_put( 'vfxsnw', wfx_snw ) ! mass flux from total snow growth/melt239 CALL iom_put( 'vfxsnw_sum', wfx_snw_sum ) ! mass flux from snow melt at the surface240 CALL iom_put( 'vfxsnw_sni', wfx_snw_sni ) ! mass flux from snow melt during snow-ice formation241 CALL iom_put( 'vfxsnw_dyn', wfx_snw_dyn ) ! mass flux from dynamics (ridging)242 CALL iom_put( 'vfxsnw_sub', wfx_snw_sub ) ! mass flux from snow sublimation (ice-atm.)243 CALL iom_put( 'vfxsnw_pre', wfx_spr ) ! snow precip234 CALL iom_put( "vfxthin", wfx_opw + z2d ) 235 ENDIF 236 237 ! ! vfxsnw = vfxsnw_sni + vfxsnw_dyn + vfxsnw_sum 238 IF( iom_use('vfxsnw' ) ) CALL iom_put( "vfxsnw" , wfx_snw ) ! mass flux from total snow growth/melt 239 IF( iom_use('vfxsnw_sum' ) ) CALL iom_put( "vfxsnw_sum" , wfx_snw_sum ) ! mass flux from snow melt at the surface 240 IF( iom_use('vfxsnw_sni' ) ) CALL iom_put( "vfxsnw_sni" , wfx_snw_sni ) ! mass flux from snow melt during snow-ice formation 241 IF( iom_use('vfxsnw_dyn' ) ) CALL iom_put( "vfxsnw_dyn" , wfx_snw_dyn ) ! mass flux from dynamics (ridging) 242 IF( iom_use('vfxsnw_sub' ) ) CALL iom_put( "vfxsnw_sub" , wfx_snw_sub ) ! mass flux from snow sublimation (ice-atm.) 243 IF( iom_use('vfxsnw_pre' ) ) CALL iom_put( "vfxsnw_pre" , wfx_spr ) ! snow precip 244 244 245 245 ! --- heat fluxes [W/m2] --- ! 246 246 ! ! qt_atm_oi - qt_oce_ai = hfxdhc - ( dihctrp + dshctrp ) 247 IF( iom_use('qsr_oce' ) ) CALL iom_put( 'qsr_oce', qsr_oce * ( 1._wp - at_i_b ) ) ! solar flux at ocean surface248 IF( iom_use('qns_oce' ) ) CALL iom_put( 'qns_oce', qns_oce * ( 1._wp - at_i_b ) + qemp_oce ) ! non-solar flux at ocean surface249 IF( iom_use('qsr_ice' ) ) CALL iom_put( 'qsr_ice', SUM( qsr_ice * a_i_b, dim=3 ) ) ! solar flux at ice surface250 IF( iom_use('qns_ice' ) ) CALL iom_put( 'qns_ice', SUM( qns_ice * a_i_b, dim=3 ) + qemp_ice ) ! non-solar flux at ice surface251 IF( iom_use('qtr_ice_bot') ) CALL iom_put( 'qtr_ice_bot', SUM( qtr_ice_bot * a_i_b, dim=3 ) ) ! solar flux transmitted thru ice252 IF( iom_use('qtr_ice_top') ) CALL iom_put( 'qtr_ice_top', SUM( qtr_ice_top * a_i_b, dim=3 ) ) ! solar flux transmitted thru ice surface253 IF( iom_use('qt_oce' ) ) CALL iom_put( 'qt_oce', ( qsr_oce + qns_oce ) * ( 1._wp - at_i_b ) + qemp_oce )254 IF( iom_use('qt_ice' ) ) CALL iom_put( 'qt_ice', SUM( ( qns_ice + qsr_ice ) * a_i_b, dim=3 ) + qemp_ice )255 IF( iom_use('qt_oce_ai' ) ) CALL iom_put( 'qt_oce_ai', qt_oce_ai * tmask(:,:,1) ) ! total heat flux at the ocean surface: interface oce-(ice+atm)256 IF( iom_use('qt_atm_oi' ) ) CALL iom_put( 'qt_atm_oi', qt_atm_oi * tmask(:,:,1) ) ! total heat flux at the oce-ice surface: interface atm-(ice+oce)257 IF( iom_use('qemp_oce' ) ) CALL iom_put( 'qemp_oce', qemp_oce ) ! Downward Heat Flux from E-P over ocean258 IF( iom_use('qemp_ice' ) ) CALL iom_put( 'qemp_ice', qemp_ice ) ! Downward Heat Flux from E-P over ice247 IF( iom_use('qsr_oce' ) ) CALL iom_put( "qsr_oce" , qsr_oce * ( 1._wp - at_i_b ) ) ! solar flux at ocean surface 248 IF( iom_use('qns_oce' ) ) CALL iom_put( "qns_oce" , qns_oce * ( 1._wp - at_i_b ) + qemp_oce ) ! non-solar flux at ocean surface 249 IF( iom_use('qsr_ice' ) ) CALL iom_put( "qsr_ice" , SUM( qsr_ice * a_i_b, dim=3 ) ) ! solar flux at ice surface 250 IF( iom_use('qns_ice' ) ) CALL iom_put( "qns_ice" , SUM( qns_ice * a_i_b, dim=3 ) + qemp_ice ) ! non-solar flux at ice surface 251 IF( iom_use('qtr_ice_bot') ) CALL iom_put( "qtr_ice_bot", SUM( qtr_ice_bot * a_i_b, dim=3 ) ) ! solar flux transmitted thru ice 252 IF( iom_use('qtr_ice_top') ) CALL iom_put( "qtr_ice_top", SUM( qtr_ice_top * a_i_b, dim=3 ) ) ! solar flux transmitted thru ice surface 253 IF( iom_use('qt_oce' ) ) CALL iom_put( "qt_oce" , ( qsr_oce + qns_oce ) * ( 1._wp - at_i_b ) + qemp_oce ) 254 IF( iom_use('qt_ice' ) ) CALL iom_put( "qt_ice" , SUM( ( qns_ice + qsr_ice ) * a_i_b, dim=3 ) + qemp_ice ) 255 IF( iom_use('qt_oce_ai' ) ) CALL iom_put( "qt_oce_ai" , qt_oce_ai * tmask(:,:,1) ) ! total heat flux at the ocean surface: interface oce-(ice+atm) 256 IF( iom_use('qt_atm_oi' ) ) CALL iom_put( "qt_atm_oi" , qt_atm_oi * tmask(:,:,1) ) ! total heat flux at the oce-ice surface: interface atm-(ice+oce) 257 IF( iom_use('qemp_oce' ) ) CALL iom_put( "qemp_oce" , qemp_oce ) ! Downward Heat Flux from E-P over ocean 258 IF( iom_use('qemp_ice' ) ) CALL iom_put( "qemp_ice" , qemp_ice ) ! Downward Heat Flux from E-P over ice 259 259 260 260 ! heat fluxes from ice transformations 261 ! ! hfxdhc = hfxbog + hfxbom + hfxsum + hfxopw + hfxdif + hfxsnw - ( hfxthd + hfxdyn + hfxres + hfxsub + hfxspr )262 CALL iom_put ('hfxbog' , hfx_bog) ! heat flux used for ice bottom growth263 CALL iom_put ('hfxbom' , hfx_bom) ! heat flux used for ice bottom melt264 CALL iom_put ('hfxsum' , hfx_sum) ! heat flux used for ice surface melt265 CALL iom_put ('hfxopw' , hfx_opw) ! heat flux used for ice formation in open water266 CALL iom_put ('hfxdif' , hfx_dif) ! heat flux used for ice temperature change267 CALL iom_put ('hfxsnw' , hfx_snw) ! heat flux used for snow melt268 CALL iom_put ('hfxerr' , hfx_err_dif) ! heat flux error after heat diffusion (included in qt_oce_ai)261 ! ! hfxdhc = hfxbog + hfxbom + hfxsum + hfxopw + hfxdif + hfxsnw - ( hfxthd + hfxdyn + hfxres + hfxsub + hfxspr ) 262 IF( iom_use('hfxbog' ) ) CALL iom_put ("hfxbog" , hfx_bog ) ! heat flux used for ice bottom growth 263 IF( iom_use('hfxbom' ) ) CALL iom_put ("hfxbom" , hfx_bom ) ! heat flux used for ice bottom melt 264 IF( iom_use('hfxsum' ) ) CALL iom_put ("hfxsum" , hfx_sum ) ! heat flux used for ice surface melt 265 IF( iom_use('hfxopw' ) ) CALL iom_put ("hfxopw" , hfx_opw ) ! heat flux used for ice formation in open water 266 IF( iom_use('hfxdif' ) ) CALL iom_put ("hfxdif" , hfx_dif ) ! heat flux used for ice temperature change 267 IF( iom_use('hfxsnw' ) ) CALL iom_put ("hfxsnw" , hfx_snw ) ! heat flux used for snow melt 268 IF( iom_use('hfxerr' ) ) CALL iom_put ("hfxerr" , hfx_err_dif ) ! heat flux error after heat diffusion (included in qt_oce_ai) 269 269 270 270 ! heat fluxes associated with mass exchange (freeze/melt/precip...) 271 CALL iom_put ('hfxthd' , hfx_thd) !272 CALL iom_put ('hfxdyn' , hfx_dyn) !273 CALL iom_put ('hfxres' , hfx_res) !274 CALL iom_put ('hfxsub' , hfx_sub) !275 CALL iom_put ('hfxspr' , hfx_spr) ! Heat flux from snow precip heat content271 IF( iom_use('hfxthd' ) ) CALL iom_put ("hfxthd" , hfx_thd ) ! 272 IF( iom_use('hfxdyn' ) ) CALL iom_put ("hfxdyn" , hfx_dyn ) ! 273 IF( iom_use('hfxres' ) ) CALL iom_put ("hfxres" , hfx_res ) ! 274 IF( iom_use('hfxsub' ) ) CALL iom_put ("hfxsub" , hfx_sub ) ! 275 IF( iom_use('hfxspr' ) ) CALL iom_put ("hfxspr" , hfx_spr ) ! Heat flux from snow precip heat content 276 276 277 277 ! other heat fluxes 278 IF( iom_use('hfxsensib' ) ) CALL iom_put( 'hfxsensib', -qsb_ice_bot * at_i_b ) ! Sensible oceanic heat flux279 IF( iom_use('hfxcndbot' ) ) CALL iom_put( 'hfxcndbot', SUM( qcn_ice_bot * a_i_b, dim=3 ) ) ! Bottom conduction flux280 IF( iom_use('hfxcndtop' ) ) CALL iom_put( 'hfxcndtop', SUM( qcn_ice_top * a_i_b, dim=3 ) ) ! Surface conduction flux278 IF( iom_use('hfxsensib' ) ) CALL iom_put( "hfxsensib" , -qsb_ice_bot * at_i_b ) ! Sensible oceanic heat flux 279 IF( iom_use('hfxcndbot' ) ) CALL iom_put( "hfxcndbot" , SUM( qcn_ice_bot * a_i_b, dim=3 ) ) ! Bottom conduction flux 280 IF( iom_use('hfxcndtop' ) ) CALL iom_put( "hfxcndtop" , SUM( qcn_ice_top * a_i_b, dim=3 ) ) ! Surface conduction flux 281 281 282 282 ! diags 283 CALL iom_put ('hfxdhc' , diag_heat) ! Heat content variation in snow and ice283 IF( iom_use('hfxdhc' ) ) CALL iom_put ("hfxdhc" , diag_heat ) ! Heat content variation in snow and ice 284 284 ! 285 285 ! controls … … 413 413 !! ** Method : use of IOM library 414 414 !!---------------------------------------------------------------------- 415 CHARACTER(len=*) , INTENT(in) :: cdrw ! 'READ'/'WRITE'flag415 CHARACTER(len=*) , INTENT(in) :: cdrw ! "READ"/"WRITE" flag 416 416 INTEGER, OPTIONAL, INTENT(in) :: kt ! ice time-step 417 417 ! -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/ICE/icevar.F90
r11362 r11380 32 32 !! - vt_s(jpi,jpj) 33 33 !! - at_i(jpi,jpj) 34 !! - st_i(jpi,jpj)35 34 !! - et_s(jpi,jpj) total snow heat content 36 35 !! - et_i(jpi,jpj) total ice thermal content … … 105 104 ! 106 105 ! ! integrated values 107 vt_i(:,:) = SUM( v_i (:,:,:) , dim=3 ) 108 vt_s(:,:) = SUM( v_s (:,:,:) , dim=3 ) 109 st_i(:,:) = SUM( sv_i(:,:,:) , dim=3 ) 110 at_i(:,:) = SUM( a_i (:,:,:) , dim=3 ) 111 et_s(:,:) = SUM( SUM( e_s (:,:,:,:), dim=4 ), dim=3 ) 112 et_i(:,:) = SUM( SUM( e_i (:,:,:,:), dim=4 ), dim=3 ) 106 vt_i(:,:) = SUM( v_i(:,:,:) , dim=3 ) 107 vt_s(:,:) = SUM( v_s(:,:,:) , dim=3 ) 108 at_i(:,:) = SUM( a_i(:,:,:) , dim=3 ) 109 et_s(:,:) = SUM( SUM( e_s(:,:,:,:), dim=4 ), dim=3 ) 110 et_i(:,:) = SUM( SUM( e_i(:,:,:,:), dim=4 ), dim=3 ) 113 111 ! 114 112 at_ip(:,:) = SUM( a_ip(:,:,:), dim=3 ) ! melt ponds … … 140 138 tm_si(:,:) = SUM( t_si(:,:,:) * a_i(:,:,:) , dim=3 ) * z1_at_i(:,:) 141 139 om_i (:,:) = SUM( oa_i(:,:,:) , dim=3 ) * z1_at_i(:,:) 142 sm_i (:,:) = st_i(:,:)* z1_vt_i(:,:)140 sm_i (:,:) = SUM( sv_i(:,:,:) , dim=3 ) * z1_vt_i(:,:) 143 141 ! 144 142 tm_i(:,:) = 0._wp … … 265 263 ! 266 264 ! integrated values 267 vt_i (:,:) = SUM( v_i 268 vt_s (:,:) = SUM( v_s 269 at_i (:,:) = SUM( a_i 265 vt_i (:,:) = SUM( v_i, dim=3 ) 266 vt_s (:,:) = SUM( v_s, dim=3 ) 267 at_i (:,:) = SUM( a_i, dim=3 ) 270 268 ! 271 269 END SUBROUTINE ice_var_glo2eqv … … 535 533 536 534 ! to be sure that at_i is the sum of a_i(jl) 537 at_i (:,:) = SUM( a_i (:,:,:), dim=3 ) 538 vt_i (:,:) = SUM( v_i (:,:,:), dim=3 ) 539 !!clem add? 540 ! vt_s (:,:) = SUM( v_s (:,:,:), dim=3 ) 541 ! st_i (:,:) = SUM( sv_i(:,:,:), dim=3 ) 542 ! et_s(:,:) = SUM( SUM( e_s (:,:,:,:), dim=4 ), dim=3 ) 543 ! et_i(:,:) = SUM( SUM( e_i (:,:,:,:), dim=4 ), dim=3 ) 544 !!clem 535 at_i (:,:) = SUM( a_i(:,:,:), dim=3 ) 536 vt_i (:,:) = SUM( v_i(:,:,:), dim=3 ) 545 537 546 538 ! open water = 1 if at_i=0 … … 1093 1085 ! ! ---------------------- ! 1094 1086 CALL ice_var_itd_1cMc( phti(:,1), phts(:,1), pati (:,1), ph_i(:,:), ph_s(:,:), pa_i (:,:) ) 1095 !! CALL ice_var_itd_1cMc( phti(:,1), phts(:,1), pati (:,1), ph_i(:,:), ph_s(:,:), pa_i (:,:), &1096 !! & ptmi(:,1), ptms(:,1), ptmsu(:,1), psmi(:,1), pt_i(:,:), pt_s(:,:), pt_su(:,:), ps_i(:,:) )1087 !!$ CALL ice_var_itd_1cMc( phti(:,1), phts(:,1), pati (:,1), ph_i(:,:), ph_s(:,:), pa_i (:,:), & 1088 !!$ & ptmi(:,1), ptms(:,1), ptmsu(:,1), psmi(:,1), pt_i(:,:), pt_s(:,:), pt_su(:,:), ps_i(:,:) ) 1097 1089 ! ! ---------------------- ! 1098 1090 ELSEIF( jpl == 1 ) THEN ! output cat = 1 ! 1099 1091 ! ! ---------------------- ! 1100 CALL ice_var_itd_Nc1c( phti(:,:), phts(:,:), pati (:,:), ph_i(:,1), ph_s(:,1), pa_i (:,1) ) 1101 !! CALL ice_var_itd_Nc1c( phti(:,:), phts(:,:), pati (:,:), ph_i(:,1), ph_s(:,1), pa_i (:,1), &1102 !! & ptmi(:,:), ptms(:,:), ptmsu(:,:), psmi(:,:), pt_i(:,1), pt_s(:,1), pt_su(:,1), ps_i(:,1) )1092 CALL ice_var_itd_Nc1c( phti(:,:), phts(:,:), pati (:,:), ph_i(:,1), ph_s(:,1), pa_i (:,1) ) 1093 !!$ CALL ice_var_itd_Nc1c( phti(:,:), phts(:,:), pati (:,:), ph_i(:,1), ph_s(:,1), pa_i (:,1), & 1094 !!$ & ptmi(:,:), ptms(:,:), ptmsu(:,:), psmi(:,:), pt_i(:,1), pt_s(:,1), pt_su(:,1), ps_i(:,1) ) 1103 1095 ! ! ----------------------- ! 1104 1096 ELSE ! input cat /= output cat ! -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/ICE/icewri.F90
r11371 r11380 50 50 INTEGER :: ji, jj, jk, jl ! dummy loop indices 51 51 REAL(wp) :: z2da, z2db, zrho1, zrho2 52 REAL(wp) :: zmiss_val ! missing value retrieved from xios 53 REAL(wp), DIMENSION(jpi,jpj) :: z2d, zfast ! 2D workspace 52 REAL(wp), DIMENSION(jpi,jpj) :: z2d, zfast ! 2D workspace 54 53 REAL(wp), DIMENSION(jpi,jpj) :: zmsk00, zmsk05, zmsk15, zmsksn ! O%, 5% and 15% concentration mask and snow mask 55 54 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zmsk00l, zmsksnl ! cat masks … … 59 58 REAL(wp) :: zdiag_area_sh, zdiag_extt_sh, zdiag_volu_sh 60 59 !!------------------------------------------------------------------- 61 ! 60 62 61 IF( ln_timing ) CALL timing_start('icewri') 63 64 ! get missing value from xml65 CALL iom_miss_val( 'icetemp', zmiss_val )66 62 67 63 ! brine volume … … 89 85 ! Standard outputs 90 86 !----------------- 91 zrho1 = ( rau0 - rhoi ) * r1_rau0 87 zrho1 = ( rau0 - rhoi ) * r1_rau0; zrho2 = rhos * r1_rau0 92 88 ! masks 93 CALL iom_put( 'icemask' , zmsk00 ) ! ice mask 0% 94 CALL iom_put( 'icemask05', zmsk05 ) ! ice mask 5% 95 CALL iom_put( 'icemask15', zmsk15 ) ! ice mask 15% 96 CALL iom_put( 'icepres' , zmsk00 ) ! Ice presence (1 or 0) 89 IF( iom_use('icemask' ) ) CALL iom_put( "icemask" , zmsk00 ) ! ice mask 0% 90 IF( iom_use('icemask05') ) CALL iom_put( "icemask05", zmsk05 ) ! ice mask 5% 91 IF( iom_use('icemask15') ) CALL iom_put( "icemask15", zmsk15 ) ! ice mask 15% 97 92 ! 98 93 ! general fields 99 IF( iom_use('icemass' ) ) CALL iom_put( 'icemass', vt_i * rhoi * zmsk00 ) ! Ice mass per cell area 100 IF( iom_use('snwmass' ) ) CALL iom_put( 'snwmass', vt_s * rhos * zmsksn ) ! Snow mass per cell area 101 IF( iom_use('iceconc' ) ) CALL iom_put( 'iceconc', at_i * zmsk00 ) ! ice concentration 102 IF( iom_use('icevolu' ) ) CALL iom_put( 'icevolu', vt_i * zmsk00 ) ! ice volume = mean ice thickness over the cell 103 IF( iom_use('icethic' ) ) CALL iom_put( 'icethic', hm_i * zmsk00 ) ! ice thickness 104 IF( iom_use('snwthic' ) ) CALL iom_put( 'snwthic', hm_s * zmsk00 ) ! snw thickness 105 IF( iom_use('icebrv' ) ) CALL iom_put( 'icebrv' , bvm_i* 100. * zmsk00 ) ! brine volume 106 IF( iom_use('iceage' ) ) CALL iom_put( 'iceage' , om_i / rday * zmsk15 + zmiss_val * ( 1._wp - zmsk15 ) ) ! ice age 107 IF( iom_use('icehnew' ) ) CALL iom_put( 'icehnew', ht_i_new ) ! new ice thickness formed in the leads 108 IF( iom_use('snwvolu' ) ) CALL iom_put( 'snwvolu', vt_s * zmsksn ) ! snow volume 109 IF( iom_use('icefrb' ) ) THEN ! Ice freeboard 94 IF( iom_use('icemass' ) ) CALL iom_put( "icemass", rhoi * vt_i * zmsk00 ) ! Ice mass per cell area 95 IF( iom_use('snwmass' ) ) CALL iom_put( "snwmass", rhos * vt_s * zmsksn ) ! Snow mass per cell area 96 IF( iom_use('icepres' ) ) CALL iom_put( "icepres", zmsk00 ) ! Ice presence (1 or 0) 97 IF( iom_use('iceconc' ) ) CALL iom_put( "iceconc", at_i * zmsk00 ) ! ice concentration 98 IF( iom_use('icevolu' ) ) CALL iom_put( "icevolu", vt_i * zmsk00 ) ! ice volume = mean ice thickness over the cell 99 IF( iom_use('icethic' ) ) CALL iom_put( "icethic", hm_i * zmsk00 ) ! ice thickness 100 IF( iom_use('snwthic' ) ) CALL iom_put( "snwthic", hm_s * zmsk00 ) ! snw thickness 101 IF( iom_use('icebrv' ) ) CALL iom_put( "icebrv" , bvm_i * zmsk00 * 100. ) ! brine volume 102 IF( iom_use('iceage' ) ) CALL iom_put( "iceage" , om_i * zmsk15 / rday ) ! ice age 103 IF( iom_use('icehnew' ) ) CALL iom_put( "icehnew", ht_i_new ) ! new ice thickness formed in the leads 104 IF( iom_use('snwvolu' ) ) CALL iom_put( "snwvolu", vt_s * zmsksn ) ! snow volume 105 IF( iom_use('icefrb') ) THEN 110 106 z2d(:,:) = ( zrho1 * hm_i(:,:) - zrho2 * hm_s(:,:) ) 111 107 WHERE( z2d < 0._wp ) z2d = 0._wp 112 CALL iom_put( 'icefrb' , z2d * zmsk00 )108 CALL iom_put( "icefrb" , z2d * zmsk00 ) ! Ice freeboard 113 109 ENDIF 110 ! 114 111 ! melt ponds 115 IF( iom_use('iceapnd' ) ) CALL iom_put( 'iceapnd', at_ip * zmsk00 ) ! melt pond total fraction 116 IF( iom_use('icevpnd' ) ) CALL iom_put( 'icevpnd', vt_ip * zmsk00 ) ! melt pond total volume per unit area 112 IF( iom_use('iceapnd' ) ) CALL iom_put( "iceapnd", at_ip * zmsk00 ) ! melt pond total fraction 113 IF( iom_use('icevpnd' ) ) CALL iom_put( "icevpnd", vt_ip * zmsk00 ) ! melt pond total volume per unit area 114 ! 117 115 ! salt 118 IF( iom_use('icesalt' ) ) CALL iom_put( 'icesalt', sm_i * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! mean ice salinity 119 IF( iom_use('icesalm' ) ) CALL iom_put( 'icesalm', st_i * rhoi * 1.0e-3 * zmsk00 ) ! Mass of salt in sea ice per cell area 116 IF( iom_use('icesalt' ) ) CALL iom_put( "icesalt", sm_i * zmsk00 ) ! mean ice salinity 117 IF( iom_use('icesalm' ) ) CALL iom_put( "icesalm", SUM( sv_i, DIM = 3 ) * rhoi * 1.0e-3 * zmsk00 ) ! Mass of salt in sea ice per cell area 118 120 119 ! heat 121 IF( iom_use('icetemp' ) ) CALL iom_put( 'icetemp', ( tm_i - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! ice mean temperature 122 IF( iom_use('snwtemp' ) ) CALL iom_put( 'snwtemp', ( tm_s - rt0 ) * zmsksn + zmiss_val * ( 1._wp - zmsksn ) ) ! snw mean temperature 123 IF( iom_use('icettop' ) ) CALL iom_put( 'icettop', ( tm_su - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the ice surface 124 IF( iom_use('icetbot' ) ) CALL iom_put( 'icetbot', ( t_bo - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the ice bottom 125 IF( iom_use('icetsni' ) ) CALL iom_put( 'icetsni', ( tm_si - rt0 ) * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! temperature at the snow-ice interface 126 IF( iom_use('icehc' ) ) CALL iom_put( 'icehc' , -et_i * zmsk00 ) ! ice heat content 127 IF( iom_use('snwhc' ) ) CALL iom_put( 'snwhc' , -et_s * zmsksn ) ! snow heat content 120 IF( iom_use('icetemp' ) ) CALL iom_put( "icetemp", ( tm_i - rt0 ) * zmsk00 ) ! ice mean temperature 121 IF( iom_use('snwtemp' ) ) CALL iom_put( "snwtemp", ( tm_s - rt0 ) * zmsksn ) ! snw mean temperature 122 IF( iom_use('icettop' ) ) CALL iom_put( "icettop", ( tm_su - rt0 ) * zmsk00 ) ! temperature at the ice surface 123 IF( iom_use('icetbot' ) ) CALL iom_put( "icetbot", ( t_bo - rt0 ) * zmsk00 ) ! temperature at the ice bottom 124 IF( iom_use('icetsni' ) ) CALL iom_put( "icetsni", ( tm_si - rt0 ) * zmsk00 ) ! temperature at the snow-ice interface 125 IF( iom_use('icehc' ) ) CALL iom_put( "icehc" , -et_i * zmsk00 ) ! ice heat content 126 IF( iom_use('snwhc' ) ) CALL iom_put( "snwhc" , -et_s * zmsksn ) ! snow heat content 127 128 128 ! momentum 129 IF( iom_use('uice' ) ) CALL iom_put( 'uice' , u_ice ) ! ice velocity u 130 IF( iom_use('vice' ) ) CALL iom_put( 'vice' , v_ice ) ! ice velocity v 131 ! 132 IF( iom_use('icevel') .OR. iom_use('fasticepres') ) THEN ! module of ice velocity 129 IF( iom_use('uice' ) ) CALL iom_put( "uice" , u_ice ) ! ice velocity u component 130 IF( iom_use('vice' ) ) CALL iom_put( "vice" , v_ice ) ! ice velocity v component 131 IF( iom_use('utau_ai' ) ) CALL iom_put( "utau_ai", utau_ice * zmsk00 ) ! Wind stress term in force balance (x) 132 IF( iom_use('vtau_ai' ) ) CALL iom_put( "vtau_ai", vtau_ice * zmsk00 ) ! Wind stress term in force balance (y) 133 134 IF( iom_use('icevel') .OR. iom_use('fasticepres') ) THEN 135 ! module of ice velocity 133 136 DO jj = 2 , jpjm1 134 137 DO ji = 2 , jpim1 135 z2da = u_ice(ji,jj) + u_ice(ji-1,jj)136 z2db = v_ice(ji,jj) + v_ice(ji,jj-1)138 z2da = ( u_ice(ji,jj) + u_ice(ji-1,jj) ) 139 z2db = ( v_ice(ji,jj) + v_ice(ji,jj-1) ) 137 140 z2d(ji,jj) = 0.5_wp * SQRT( z2da * z2da + z2db * z2db ) 138 141 END DO 139 142 END DO 140 143 CALL lbc_lnk( 'icewri', z2d, 'T', 1. ) 141 CALL iom_put( 'icevel', z2d ) 142 143 WHERE( z2d(:,:) < 5.e-04_wp .AND. zmsk15(:,:) == 1._wp ) ; zfast(:,:) = 1._wp ! record presence of fast ice 144 IF( iom_use('icevel') ) CALL iom_put( "icevel" , z2d ) 145 146 ! record presence of fast ice 147 WHERE( z2d(:,:) < 5.e-04_wp .AND. zmsk15(:,:) == 1._wp ) ; zfast(:,:) = 1._wp 144 148 ELSEWHERE ; zfast(:,:) = 0._wp 145 149 END WHERE 146 CALL iom_put( 'fasticepres', zfast )150 IF( iom_use('fasticepres') ) CALL iom_put( "fasticepres" , zfast ) 147 151 ENDIF 148 152 149 153 ! --- category-dependent fields --- ! 150 IF( iom_use('icemask_cat' ) ) CALL iom_put( 'icemask_cat' , zmsk00l ) ! ice mask 0% 151 IF( iom_use('iceconc_cat' ) ) CALL iom_put( 'iceconc_cat' , a_i * zmsk00l ) ! area for categories 152 IF( iom_use('icethic_cat' ) ) CALL iom_put( 'icethic_cat' , h_i * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! thickness for categories 153 IF( iom_use('snwthic_cat' ) ) CALL iom_put( 'snwthic_cat' , h_s * zmsksnl + zmiss_val * ( 1._wp - zmsksnl ) ) ! snow depth for categories 154 IF( iom_use('icesalt_cat' ) ) CALL iom_put( 'icesalt_cat' , s_i * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! salinity for categories 155 IF( iom_use('iceage_cat' ) ) CALL iom_put( 'iceage_cat' , o_i / rday * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice age 156 IF( iom_use('icetemp_cat' ) ) CALL iom_put( 'icetemp_cat' , ( SUM( t_i, dim=3 ) * r1_nlay_i - rt0 ) & 157 & * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice temperature 158 IF( iom_use('snwtemp_cat' ) ) CALL iom_put( 'snwtemp_cat' , ( SUM( t_s, dim=3 ) * r1_nlay_s - rt0 ) & 159 & * zmsksnl + zmiss_val * ( 1._wp - zmsksnl ) ) ! snow temperature 160 IF( iom_use('icettop_cat' ) ) CALL iom_put( 'icettop_cat' , ( t_su - rt0 ) * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! surface temperature 161 IF( iom_use('icebrv_cat' ) ) CALL iom_put( 'icebrv_cat' , bv_i * 100. * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! brine volume 162 IF( iom_use('iceapnd_cat' ) ) CALL iom_put( 'iceapnd_cat' , a_ip * zmsk00l ) ! melt pond frac for categories 163 IF( iom_use('icehpnd_cat' ) ) CALL iom_put( 'icehpnd_cat' , h_ip * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond frac for categories 164 IF( iom_use('iceafpnd_cat') ) CALL iom_put( 'iceafpnd_cat', a_ip_frac * zmsk00l ) ! melt pond frac for categories 154 IF( iom_use('icemask_cat' ) ) CALL iom_put( "icemask_cat" , zmsk00l ) ! ice mask 0% 155 IF( iom_use('iceconc_cat' ) ) CALL iom_put( "iceconc_cat" , a_i * zmsk00l ) ! area for categories 156 IF( iom_use('icethic_cat' ) ) CALL iom_put( "icethic_cat" , h_i * zmsk00l ) ! thickness for categories 157 IF( iom_use('snwthic_cat' ) ) CALL iom_put( "snwthic_cat" , h_s * zmsksnl ) ! snow depth for categories 158 IF( iom_use('icesalt_cat' ) ) CALL iom_put( "icesalt_cat" , s_i * zmsk00l ) ! salinity for categories 159 IF( iom_use('iceage_cat' ) ) CALL iom_put( "iceage_cat" , o_i * zmsk00l / rday ) ! ice age 160 IF( iom_use('icetemp_cat' ) ) CALL iom_put( "icetemp_cat" , ( SUM( t_i(:,:,:,:), dim=3 ) * r1_nlay_i - rt0 ) * zmsk00l ) ! ice temperature 161 IF( iom_use('snwtemp_cat' ) ) CALL iom_put( "snwtemp_cat" , ( SUM( t_s(:,:,:,:), dim=3 ) * r1_nlay_s - rt0 ) * zmsksnl ) ! snow temperature 162 IF( iom_use('icettop_cat' ) ) CALL iom_put( "icettop_cat" , ( t_su - rt0 ) * zmsk00l ) ! surface temperature 163 IF( iom_use('icebrv_cat' ) ) CALL iom_put( "icebrv_cat" , bv_i * 100. * zmsk00l ) ! brine volume 164 IF( iom_use('iceapnd_cat' ) ) CALL iom_put( "iceapnd_cat" , a_ip * zmsk00l ) ! melt pond frac for categories 165 IF( iom_use('icehpnd_cat' ) ) CALL iom_put( "icehpnd_cat" , h_ip * zmsk00l ) ! melt pond frac for categories 166 IF( iom_use('iceafpnd_cat') ) CALL iom_put( "iceafpnd_cat", a_ip_frac * zmsk00l ) ! melt pond frac for categories 165 167 166 168 !------------------ … … 168 170 !------------------ 169 171 ! trends 170 IF( iom_use('dmithd') ) CALL iom_put( 'dmithd', - wfx_bog - wfx_bom - wfx_sum - wfx_sni - wfx_opw - wfx_lam - wfx_res ) ! Sea-ice mass change from thermodynamics171 IF( iom_use('dmidyn') ) CALL iom_put( 'dmidyn', - wfx_dyn + rhoi * diag_trp_vi )! Sea-ice mass change from dynamics(kg/m2/s)172 IF( iom_use('dmiopw') ) CALL iom_put( 'dmiopw', - wfx_opw )! Sea-ice mass change through growth in open water173 IF( iom_use('dmibog') ) CALL iom_put( 'dmibog', - wfx_bog )! Sea-ice mass change through basal growth174 IF( iom_use('dmisni') ) CALL iom_put( 'dmisni', - wfx_sni )! Sea-ice mass change through snow-to-ice conversion175 IF( iom_use('dmisum') ) CALL iom_put( 'dmisum', - wfx_sum )! Sea-ice mass change through surface melting176 IF( iom_use('dmibom') ) CALL iom_put( 'dmibom', - wfx_bom )! Sea-ice mass change through bottom melting177 IF( iom_use('dmtsub') ) CALL iom_put( 'dmtsub', - wfx_sub )! Sea-ice mass change through evaporation and sublimation178 IF( iom_use('dmssub') ) CALL iom_put( 'dmssub', - wfx_snw_sub )! Snow mass change through sublimation179 IF( iom_use('dmisub') ) CALL iom_put( 'dmisub', - wfx_ice_sub )! Sea-ice mass change through sublimation180 IF( iom_use('dmsspr') ) CALL iom_put( 'dmsspr', - wfx_spr )! Snow mass change through snow fall181 IF( iom_use('dmsssi') ) CALL iom_put( 'dmsssi', wfx_sni*rhos*r1_rhoi )! Snow mass change through snow-to-ice conversion182 IF( iom_use('dmsmel') ) CALL iom_put( 'dmsmel', - wfx_snw_sum )! Snow mass change through melt183 IF( iom_use('dmsdyn') ) CALL iom_put( 'dmsdyn', - wfx_snw_dyn + rhos * diag_trp_vs )! Snow mass change through dynamics(kg/m2/s)184 172 IF( iom_use('dmithd') ) CALL iom_put( "dmithd", - wfx_bog - wfx_bom - wfx_sum - wfx_sni - wfx_opw - wfx_lam - wfx_res ) ! Sea-ice mass change from thermodynamics 173 IF( iom_use('dmidyn') ) CALL iom_put( "dmidyn", - wfx_dyn + rhoi * diag_trp_vi ) ! Sea-ice mass change from dynamics(kg/m2/s) 174 IF( iom_use('dmiopw') ) CALL iom_put( "dmiopw", - wfx_opw ) ! Sea-ice mass change through growth in open water 175 IF( iom_use('dmibog') ) CALL iom_put( "dmibog", - wfx_bog ) ! Sea-ice mass change through basal growth 176 IF( iom_use('dmisni') ) CALL iom_put( "dmisni", - wfx_sni ) ! Sea-ice mass change through snow-to-ice conversion 177 IF( iom_use('dmisum') ) CALL iom_put( "dmisum", - wfx_sum ) ! Sea-ice mass change through surface melting 178 IF( iom_use('dmibom') ) CALL iom_put( "dmibom", - wfx_bom ) ! Sea-ice mass change through bottom melting 179 IF( iom_use('dmtsub') ) CALL iom_put( "dmtsub", - wfx_sub ) ! Sea-ice mass change through evaporation and sublimation 180 IF( iom_use('dmssub') ) CALL iom_put( "dmssub", - wfx_snw_sub ) ! Snow mass change through sublimation 181 IF( iom_use('dmisub') ) CALL iom_put( "dmisub", - wfx_ice_sub ) ! Sea-ice mass change through sublimation 182 IF( iom_use('dmsspr') ) CALL iom_put( "dmsspr", - wfx_spr ) ! Snow mass change through snow fall 183 IF( iom_use('dmsssi') ) CALL iom_put( "dmsssi", wfx_sni*rhos*r1_rhoi ) ! Snow mass change through snow-to-ice conversion 184 IF( iom_use('dmsmel') ) CALL iom_put( "dmsmel", - wfx_snw_sum ) ! Snow mass change through melt 185 IF( iom_use('dmsdyn') ) CALL iom_put( "dmsdyn", - wfx_snw_dyn + rhos * diag_trp_vs ) ! Snow mass change through dynamics(kg/m2/s) 186 185 187 ! Global ice diagnostics 186 IF( iom_use('NH_icearea') .OR. iom_use('NH_icevolu') .OR. iom_use('NH_iceextt') .OR. & 187 & iom_use('SH_icearea') .OR. iom_use('SH_icevolu') .OR. iom_use('SH_iceextt') ) THEN 188 ! 189 WHERE( ff_t(:,:) > 0._wp ) ; z2d(:,:) = 1._wp 190 ELSEWHERE ; z2d(:,:) = 0. 191 END WHERE 192 ! 193 IF( iom_use('NH_icearea') ) zdiag_area_nh = glob_sum( 'icewri', at_i * z2d * e1e2t * 1.e-12 ) 194 IF( iom_use('NH_icevolu') ) zdiag_volu_nh = glob_sum( 'icewri', vt_i * z2d * e1e2t * 1.e-12 ) 195 IF( iom_use('NH_iceextt') ) zdiag_extt_nh = glob_sum( 'icewri', z2d * e1e2t * 1.e-12 * zmsk15 ) 196 ! 197 IF( iom_use('SH_icearea') ) zdiag_area_sh = glob_sum( 'icewri', at_i * ( 1._wp - z2d ) * e1e2t * 1.e-12 ) 198 IF( iom_use('SH_icevolu') ) zdiag_volu_sh = glob_sum( 'icewri', vt_i * ( 1._wp - z2d ) * e1e2t * 1.e-12 ) 199 IF( iom_use('SH_iceextt') ) zdiag_extt_sh = glob_sum( 'icewri', ( 1._wp - z2d ) * e1e2t * 1.e-12 * zmsk15 ) 200 ! 201 CALL iom_put( 'NH_icearea' , zdiag_area_nh ) 202 CALL iom_put( 'NH_icevolu' , zdiag_volu_nh ) 203 CALL iom_put( 'NH_iceextt' , zdiag_extt_nh ) 204 CALL iom_put( 'SH_icearea' , zdiag_area_sh ) 205 CALL iom_put( 'SH_icevolu' , zdiag_volu_sh ) 206 CALL iom_put( 'SH_iceextt' , zdiag_extt_sh ) 188 IF( iom_use('NH_icearea') .OR. iom_use('NH_icevolu') .OR. iom_use('NH_iceextt') ) THEN ! NH diagnostics 189 ! 190 WHERE( ff_t > 0._wp ) ; zmsk00(:,:) = 1.0e-12 191 ELSEWHERE ; zmsk00(:,:) = 0. 192 END WHERE 193 zdiag_area_nh = glob_sum( 'icewri', at_i(:,:) * zmsk00(:,:) * e1e2t(:,:) ) 194 zdiag_volu_nh = glob_sum( 'icewri', vt_i(:,:) * zmsk00(:,:) * e1e2t(:,:) ) 195 ! 196 WHERE( ff_t > 0._wp .AND. at_i > 0.15 ) ; zmsk00(:,:) = 1.0e-12 197 ELSEWHERE ; zmsk00(:,:) = 0. 198 END WHERE 199 zdiag_extt_nh = glob_sum( 'icewri', zmsk00(:,:) * e1e2t(:,:) ) 200 ! 201 IF( iom_use('NH_icearea') ) CALL iom_put( "NH_icearea" , zdiag_area_nh ) 202 IF( iom_use('NH_icevolu') ) CALL iom_put( "NH_icevolu" , zdiag_volu_nh ) 203 IF( iom_use('NH_iceextt') ) CALL iom_put( "NH_iceextt" , zdiag_extt_nh ) 207 204 ! 208 205 ENDIF 206 ! 207 IF( iom_use('SH_icearea') .OR. iom_use('SH_icevolu') .OR. iom_use('SH_iceextt') ) THEN ! SH diagnostics 208 ! 209 WHERE( ff_t < 0._wp ); zmsk00(:,:) = 1.0e-12; 210 ELSEWHERE ; zmsk00(:,:) = 0. 211 END WHERE 212 zdiag_area_sh = glob_sum( 'icewri', at_i(:,:) * zmsk00(:,:) * e1e2t(:,:) ) 213 zdiag_volu_sh = glob_sum( 'icewri', vt_i(:,:) * zmsk00(:,:) * e1e2t(:,:) ) 214 ! 215 WHERE( ff_t < 0._wp .AND. at_i > 0.15 ); zmsk00(:,:) = 1.0e-12 216 ELSEWHERE ; zmsk00(:,:) = 0. 217 END WHERE 218 zdiag_extt_sh = glob_sum( 'icewri', zmsk00(:,:) * e1e2t(:,:) ) 219 ! 220 IF( iom_use('SH_icearea') ) CALL iom_put( "SH_icearea", zdiag_area_sh ) 221 IF( iom_use('SH_icevolu') ) CALL iom_put( "SH_icevolu", zdiag_volu_sh ) 222 IF( iom_use('SH_iceextt') ) CALL iom_put( "SH_iceextt", zdiag_extt_sh ) 223 ! 224 ENDIF 209 225 ! 210 226 !!CR ! ! Create an output files (output.lim.abort.nc) if S < 0 or u > 20 m/s 211 227 !!CR ! IF( kindic < 0 ) CALL ice_wri_state( 'output.abort' ) 212 228 !!CR ! not yet implemented 213 !!gm idem for the ocean... Ask Seb how to get r id of ioipsl....229 !!gm idem for the ocean... Ask Seb how to get read of ioipsl.... 214 230 ! 215 231 IF( ln_timing ) CALL timing_stop('icewri') -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/BDY/bdy_oce.F90
r11223 r11380 15 15 IMPLICIT NONE 16 16 PUBLIC 17 17 18 18 19 INTEGER, PUBLIC, PARAMETER :: jp_bdy = 10 !: Maximum number of bdy sets … … 122 123 !: =1 => some data to be read in from data files 123 124 !$AGRIF_DO_NOT_TREAT 124 TYPE(OBC_INDEX), DIMENSION(jp_bdy), TARGET :: idx_bdy !: bdy indices (local process) 125 TYPE(OBC_DATA) , DIMENSION(jp_bdy), TARGET :: dta_bdy !: bdy external data (local process) 125 ! regular : interior domain + global halo || extended : interior domain + global halo + halo extension for time-splitting 126 TYPE(OBC_INDEX), DIMENSION(jp_bdy), TARGET :: idx_bdy_reg, idx_bdy_xtd !: bdy indices (local process) 127 TYPE(OBC_DATA) , DIMENSION(jp_bdy), TARGET :: dta_bdy_reg, dta_bdy_xtd !: bdy external data (local process) 128 ! pointers to switch between regular and extended, _save for the OBC_INDEX not currently used 129 TYPE(OBC_INDEX), DIMENSION(:) , POINTER :: idx_bdy, idx_bdy_save !: bdy indices (local process) 130 TYPE(OBC_DATA) , DIMENSION(:) , POINTER :: dta_bdy, dta_bdy_save !: bdy external data (local process) 126 131 !$AGRIF_END_DO_NOT_TREAT 127 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdy !: mark needed communication for given boundary, grid and neighbour 128 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdy !: when searching in any direction 129 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdyint !: mark needed communication for given boundary, grid and neighbour 130 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdyint !: when searching towards the interior of the computational domain 131 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lsend_bdyext !: mark needed communication for given boundary, grid and neighbour 132 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdyext !: when searching towards the exterior of the computational domain 132 ! regular : interior domain + global halo 133 LOGICAL, ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: lsend_bdy_reg !: mark com for given boundary, grid, neighbour and rim 134 LOGICAL, ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: lrecv_bdy_reg !: when searching in any direction 135 LOGICAL, ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: lsend_bdyint_reg !: mark com for given boundary, grid, neighbour and rim 136 LOGICAL, ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: lrecv_bdyint_reg !: when searching towards the interior of the domain 137 LOGICAL, ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: lsend_bdyext_reg !: mark com for given boundary, grid, neighbour and rim 138 LOGICAL, ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: lrecv_bdyext_reg !: when searching towards the exterior of the domain 139 ! extended : interior domain + global halo + halo extension for time-splitting 140 LOGICAL, ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: lsend_bdy_xtd !: mark com for given boundary, grid, neighbour and rim 141 LOGICAL, ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: lrecv_bdy_xtd !: when searching in any direction 142 LOGICAL, ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: lsend_bdyint_xtd !: mark com for given boundary, grid, neighbour and rim 143 LOGICAL, ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: lrecv_bdyint_xtd !: when searching towards the interior of the domain 144 LOGICAL, ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: lsend_bdyext_xtd !: mark com for given boundary, grid, neighbour and rim 145 LOGICAL, ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: lrecv_bdyext_xtd !: when searching towards the exterior of the domain 146 ! pointers to switch between regular and extended, _save for the logical array not currently used 147 LOGICAL, POINTER, DIMENSION(:,:,:,:) :: lsend_bdy , lsend_bdy_save 148 LOGICAL, POINTER, DIMENSION(:,:,:,:) :: lrecv_bdy , lrecv_bdy_save 149 LOGICAL, POINTER, DIMENSION(:,:,:,:) :: lsend_bdyint, lsend_bdyint_save 150 LOGICAL, POINTER, DIMENSION(:,:,:,:) :: lrecv_bdyint, lrecv_bdyint_save 151 LOGICAL, POINTER, DIMENSION(:,:,:,:) :: lsend_bdyext, lsend_bdyext_save 152 LOGICAL, POINTER, DIMENSION(:,:,:,:) :: lrecv_bdyext, lrecv_bdyext_save 133 153 !!---------------------------------------------------------------------- 134 154 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 158 178 END FUNCTION bdy_oce_alloc 159 179 180 181 SUBROUTINE swap_bdyptr 182 !!---------------------------------------------------------------------- 183 !! *** ROUTINE swap_bdyptr *** 184 !! 185 !! ** Purpose : swap all pointers for bdy treatment 186 !!---------------------------------------------------------------------- 187 CALL swap_obciptr(idx_bdy , idx_bdy_save ) 188 CALL swap_obcdptr(dta_bdy , dta_bdy_save ) 189 CALL swap_lptr (lsend_bdy , lsend_bdy_save ) 190 CALL swap_lptr (lrecv_bdy , lrecv_bdy_save ) 191 CALL swap_lptr (lsend_bdyint, lsend_bdyint_save) 192 CALL swap_lptr (lrecv_bdyint, lrecv_bdyint_save) 193 CALL swap_lptr (lsend_bdyext, lsend_bdyext_save) 194 CALL swap_lptr (lrecv_bdyext, lrecv_bdyext_save) 195 ! 196 END SUBROUTINE swap_bdyptr 197 198 199 SUBROUTINE swap_lptr( ptr1, ptr2 ) 200 !!---------------------------------------------------------------------- 201 !! *** ROUTINE swap_lptr *** 202 !! 203 !! ** Purpose : swap logical pointers 204 !! ** Method : use temporary pointer to save the target 205 !!---------------------------------------------------------------------- 206 LOGICAL, DIMENSION(:,:,:,:), POINTER, INTENT(inout) :: ptr1, ptr2 207 LOGICAL, DIMENSION(:,:,:,:), POINTER :: ptrtmp 208 !!---------------------------------------------------------------------- 209 ptrtmp => ptr1 210 ptr1 => ptr2 211 ptr2 => ptrtmp 212 END SUBROUTINE swap_lptr 213 214 215 SUBROUTINE swap_obciptr( ptr1, ptr2 ) 216 !!---------------------------------------------------------------------- 217 !! *** ROUTINE swap_obciptr *** 218 !! 219 !! ** Purpose : swap pointers on OBC_INDEX types 220 !! ** Method : use temporary pointer to save the target 221 !!---------------------------------------------------------------------- 222 TYPE(OBC_INDEX), DIMENSION(:), POINTER, INTENT(inout) :: ptr1, ptr2 223 TYPE(OBC_INDEX), DIMENSION(:), POINTER :: ptrtmp 224 !!---------------------------------------------------------------------- 225 ptrtmp => ptr1 226 ptr1 => ptr2 227 ptr2 => ptrtmp 228 END SUBROUTINE swap_obciptr 229 230 231 SUBROUTINE swap_obcdptr( ptr1, ptr2 ) 232 !!---------------------------------------------------------------------- 233 !! *** ROUTINE swap_obcdptr *** 234 !! 235 !! ** Purpose : swap pointers on OBC_DATA types 236 !! ** Method : use temporary pointer to save the target 237 !!---------------------------------------------------------------------- 238 TYPE(OBC_DATA), DIMENSION(:), POINTER, INTENT(inout) :: ptr1, ptr2 239 TYPE(OBC_DATA), DIMENSION(:), POINTER :: ptrtmp 240 !!---------------------------------------------------------------------- 241 ptrtmp => ptr1 242 ptr1 => ptr2 243 ptr2 => ptrtmp 244 END SUBROUTINE swap_obcdptr 245 160 246 !!====================================================================== 161 247 END MODULE bdy_oce -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/BDY/bdydyn.F90
r10068 r11380 97 97 !------------------------------------------------------- 98 98 99 IF( ll_dyn2d ) CALL bdy_dyn2d( kt, pua2d, pva2d, ub_b, vb_b, r1_hu_a(:,:), r1_hv_a(:,:), ssha )99 IF( ll_dyn2d ) CALL bdy_dyn2d( kt, pua2d, pva2d, ub_b, vb_b, r1_hu_a(:,:), r1_hv_a(:,:), ssha, 1, jpi, 1, jpj ) 100 100 101 101 IF( ll_dyn3d ) CALL bdy_dyn3d( kt ) -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/BDY/bdydyn2d.F90
r11258 r11380 36 36 CONTAINS 37 37 38 SUBROUTINE bdy_dyn2d( kt, pua2d, pva2d, pub2d, pvb2d, phur, phvr, pssh ) 38 SUBROUTINE bdy_dyn2d( kt, pua2d, pva2d, pub2d, pvb2d, phur, phvr, pssh & 39 & , kdbi, kdei, kdbj, kdej, ldcomall, pumask, pvmask, khlcom ) 39 40 !!---------------------------------------------------------------------- 40 41 !! *** SUBROUTINE bdy_dyn2d *** … … 43 44 !! 44 45 !!---------------------------------------------------------------------- 45 INTEGER, INTENT(in) :: kt ! Main time step counter 46 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 47 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pub2d, pvb2d 48 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: phur, phvr 49 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pssh 46 INTEGER, INTENT(in ) :: kt ! Main time step counter 47 REAL(wp), DIMENSION(kdbi:kdei,kdbj:kdej), INTENT(inout) :: pua2d, pva2d 48 REAL(wp), DIMENSION(kdbi:kdei,kdbj:kdej), INTENT(in ) :: pub2d, pvb2d 49 REAL(wp), DIMENSION(kdbi:kdei,kdbj:kdej), INTENT(in ) :: phur, phvr 50 REAL(wp), DIMENSION(kdbi:kdei,kdbj:kdej), INTENT(in ) :: pssh 51 INTEGER , INTENT(in ) :: kdbi, kdei, kdbj, kdej ! size of array 52 LOGICAL , OPTIONAL, INTENT(in ) :: ldcomall ! communicate with all neighbours 53 REAL(wp), OPTIONAL, DIMENSION(kdbi:kdei,kdbj:kdej), INTENT(in ) :: pumask ! optional mask for extended domain 54 REAL(wp), OPTIONAL, DIMENSION(kdbi:kdei,kdbj:kdej), INTENT(in ) :: pvmask ! - - 55 INTEGER , OPTIONAL, INTENT(in ) :: khlcom ! number of halos to communicate 50 56 !! 51 57 INTEGER :: ib_bdy, ir ! BDY set index, rim index … … 64 70 CYCLE 65 71 CASE('frs') ! treat the whole boundary at once 66 IF( llrim0 ) CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d ) 72 IF( llrim0 ) CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d, & 73 & kdbi, kdei, kdbj, kdej, pumask=pumask, pvmask=pvmask ) 67 74 CASE('flather') 68 CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d, pssh, phur, phvr, llrim0 ) 75 CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d, pssh, phur, phvr, llrim0, & 76 & kdbi, kdei, kdbj, kdej ) 69 77 CASE('orlanski') 70 78 CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & 71 & pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo=.false.)79 & pua2d, pva2d, pub2d, pvb2d, .false., llrim0, kdbi, kdei, kdbj, kdej ) 72 80 CASE('orlanski_npo') 73 81 CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & 74 & pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo=.true.)82 & pua2d, pva2d, pub2d, pvb2d, .true. , llrim0, kdbi, kdei, kdbj, kdej ) 75 83 CASE DEFAULT 76 84 CALL ctl_stop( 'bdy_dyn2d : unrecognised option for open boundaries for barotropic variables' ) 77 85 END SELECT 78 END DO86 END DO 79 87 ! 80 88 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 … … 101 109 END SELECT 102 110 END DO 111 IF( PRESENT(ldcomall) ) THEN 112 IF( ldcomall ) THEN ! if ldcomall is present and true then communicate with all neighbours 113 CALL lbc_lnk_multi( 'bdydyn2d', pua2d, 'U', 1., pva2d, 'V', 1., kfillmode=jpfillnothing, khlcom=khlcom ) 114 CYCLE 115 END IF 116 END IF 103 117 IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction 104 CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1., kfillmode=jpfillnothing ,l send=llsend2, lrecv=llrecv2)118 CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1., kfillmode=jpfillnothing ,ldsend=llsend2, ldrecv=llrecv2, khlcom=khlcom ) 105 119 END IF 106 120 IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction 107 CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1., kfillmode=jpfillnothing ,l send=llsend3, lrecv=llrecv3)121 CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1., kfillmode=jpfillnothing ,ldsend=llsend3, ldrecv=llrecv3, khlcom=khlcom ) 108 122 END IF 109 123 ! … … 112 126 END SUBROUTINE bdy_dyn2d 113 127 114 SUBROUTINE bdy_dyn2d_frs( idx, dta, ib_bdy, pua2d, pva2d )128 SUBROUTINE bdy_dyn2d_frs( idx, dta, ib_bdy, pua2d, pva2d, kdbi, kdei, kdbj, kdej, pumask, pvmask ) 115 129 !!---------------------------------------------------------------------- 116 130 !! *** SUBROUTINE bdy_dyn2d_frs *** … … 123 137 !! topography. Tellus, 365-382. 124 138 !!---------------------------------------------------------------------- 125 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 126 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 127 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 128 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 139 TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices 140 TYPE(OBC_DATA), INTENT(in ) :: dta ! OBC external data 141 INTEGER, INTENT(in ) :: ib_bdy ! BDY set index 142 REAL(wp), DIMENSION(kdbi:kdei,kdbj:kdej), INTENT(inout) :: pua2d, pva2d 143 INTEGER , INTENT(in ) :: kdbi, kdei, kdbj, kdej ! size of array 144 REAL(wp), OPTIONAL, TARGET, DIMENSION(kdbi:kdei,kdbj:kdej,1), INTENT(in ) :: pumask ! optional mask for extended domain 145 REAL(wp), OPTIONAL, TARGET, DIMENSION(kdbi:kdei,kdbj:kdej,1), INTENT(in ) :: pvmask ! - - 129 146 !! 130 147 INTEGER :: jb ! dummy loop indices 131 148 INTEGER :: ii, ij, igrd ! local integers 132 149 REAL(wp) :: zwgt ! boundary weight 150 REAL(wp), POINTER, DIMENSION(:,:,:) :: pmask ! land/sea mask for field 133 151 !!---------------------------------------------------------------------- 134 152 ! 135 153 igrd = 2 ! Relaxation of zonal velocity 154 IF( PRESENT(pumask) ) THEN ; pmask => pumask 155 ELSE ; pmask => umask 156 END IF 136 157 DO jb = 1, idx%nblen(igrd) 137 158 ii = idx%nbi(jb,igrd) 138 159 ij = idx%nbj(jb,igrd) 139 160 zwgt = idx%nbw(jb,igrd) 140 pua2d(ii,ij) = ( pua2d(ii,ij) + zwgt * ( dta%u2d(jb) - pua2d(ii,ij) ) ) * umask(ii,ij,1)161 pua2d(ii,ij) = ( pua2d(ii,ij) + zwgt * ( dta%u2d(jb) - pua2d(ii,ij) ) ) * pmask(ii,ij,1) 141 162 END DO 142 163 ! 143 164 igrd = 3 ! Relaxation of meridional velocity 165 IF( PRESENT(pvmask) ) THEN ; pmask => pvmask 166 ELSE ; pmask => vmask 167 END IF 144 168 DO jb = 1, idx%nblen(igrd) 145 169 ii = idx%nbi(jb,igrd) 146 170 ij = idx%nbj(jb,igrd) 147 171 zwgt = idx%nbw(jb,igrd) 148 pva2d(ii,ij) = ( pva2d(ii,ij) + zwgt * ( dta%v2d(jb) - pva2d(ii,ij) ) ) * vmask(ii,ij,1)172 pva2d(ii,ij) = ( pva2d(ii,ij) + zwgt * ( dta%v2d(jb) - pva2d(ii,ij) ) ) * pmask(ii,ij,1) 149 173 END DO 150 174 ! … … 152 176 153 177 154 SUBROUTINE bdy_dyn2d_fla( idx, dta, ib_bdy, pua2d, pva2d, pssh, phur, phvr, llrim0 ) 178 SUBROUTINE bdy_dyn2d_fla( idx, dta, ib_bdy, pua2d, pva2d, pssh, phur, phvr, ldrim0 & 179 & , kdbi, kdei, kdbj, kdej ) 155 180 !!---------------------------------------------------------------------- 156 181 !! *** SUBROUTINE bdy_dyn2d_fla *** … … 171 196 !! continental shelf. Mem. Soc. R. Sci. Liege, Ser. 6,10, 141-164. 172 197 !!---------------------------------------------------------------------- 173 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 174 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 175 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 176 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 177 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pssh, phur, phvr 178 LOGICAL , INTENT(in) :: llrim0 ! indicate if rim 0 is treated 198 TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices 199 TYPE(OBC_DATA), INTENT(in ) :: dta ! OBC external data 200 INTEGER, INTENT(in ) :: ib_bdy ! BDY set index 201 REAL(wp), DIMENSION(kdbi:kdei,kdbj:kdej), INTENT(inout) :: pua2d, pva2d 202 REAL(wp), DIMENSION(kdbi:kdei,kdbj:kdej), INTENT(in ) :: pssh, phur, phvr 203 LOGICAL , INTENT(in ) :: ldrim0 ! indicate if rim 0 is treated 204 INTEGER , INTENT(in ) :: kdbi, kdei, kdbj, kdej ! size of array 205 !! 179 206 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) 180 207 INTEGER :: jb, igrd ! dummy loop indices … … 185 212 REAL(wp) :: zfla ! Flather correction 186 213 REAL(wp) :: z1_2 ! 187 REAL(wp), DIMENSION( jpi,jpj) :: sshdta ! 2D version of dta%ssh214 REAL(wp), DIMENSION(kdbi:kdei,kdbj:kdej) :: sshdta ! 2D version of dta%ssh 188 215 !!---------------------------------------------------------------------- 189 216 … … 196 223 ! Fill temporary array with ssh data (here we use spgu with the alias sshdta): 197 224 igrd = 1 198 IF( l lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd)225 IF( ldrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) 199 226 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) 200 227 END IF … … 211 238 ! ! remember that flagu=-1 if normal velocity direction is outward 212 239 ! ! I think we should rather use after ssh ? 213 IF( l lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd)240 IF( ldrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) 214 241 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) 215 242 END IF … … 225 252 ! 226 253 ! Rare case : rim is parallel to the mpi subdomain border and on the halo : point will be received 227 IF( iiTrim > jpi .OR. iiToce > jpi .OR. iiUoce > jpi .OR. iiUoce < 1) CYCLE254 IF( iiTrim > kdei .OR. iiToce > kdei .OR. iiUoce > kdei .OR. iiUoce < kdbi ) CYCLE 228 255 ! 229 256 zfla = dta%u2d(jb) - flagu * SQRT( grav * phur(ii, ij) ) * ( pssh(iiToce,ij) - sshdta(iiTrim,ij) ) … … 237 264 igrd = 3 ! Flather bc on v-velocity 238 265 ! ! remember that flagv=-1 if normal velocity direction is outward 239 IF( l lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd)266 IF( ldrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) 240 267 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) 241 268 END IF … … 251 278 ! 252 279 ! Rare case : rim is parallel to the mpi subdomain border and on the halo : point will be received 253 IF( ijTrim > jpj .OR. ijToce > jpj .OR. ijVoce > jpj .OR. ijVoce < 1) CYCLE280 IF( ijTrim > kdej .OR. ijToce > kdej .OR. ijVoce > kdej .OR. ijVoce < kdbj ) CYCLE 254 281 ! 255 282 zfla = dta%v2d(jb) - flagv * SQRT( grav * phvr(ii, ij) ) * ( pssh(ii,ijToce) - sshdta(ii,ijTrim) ) … … 264 291 265 292 266 SUBROUTINE bdy_dyn2d_orlanski( idx, dta, ib_bdy, pua2d, pva2d, pub2d, pvb2d, l lrim0, ll_npo)293 SUBROUTINE bdy_dyn2d_orlanski( idx, dta, ib_bdy, pua2d, pva2d, pub2d, pvb2d, ld_npo, ldrim0, kdbi, kdei, kdbj, kdej ) 267 294 !!---------------------------------------------------------------------- 268 295 !! *** SUBROUTINE bdy_dyn2d_orlanski *** … … 275 302 !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) 276 303 !!---------------------------------------------------------------------- 277 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 278 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 279 INTEGER, INTENT(in) :: ib_bdy ! number of current open boundary set 280 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 281 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub2d, pvb2d 282 LOGICAL, INTENT(in) :: ll_npo ! flag for NPO version 283 LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated 284 INTEGER :: ib, igrd ! dummy loop indices 285 INTEGER :: ii, ij, iibm1, ijbm1 ! indices 304 TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices 305 TYPE(OBC_DATA), INTENT(in ) :: dta ! OBC external data 306 INTEGER, INTENT(in ) :: ib_bdy ! number of current open boundary set 307 REAL(wp), DIMENSION(kdbi:kdei,kdbj:kdej), INTENT(inout) :: pua2d, pva2d 308 REAL(wp), DIMENSION(kdbi:kdei,kdbj:kdej), INTENT(in ) :: pub2d, pvb2d 309 LOGICAL, INTENT(in ) :: ld_npo ! flag for NPO version 310 LOGICAL, INTENT(in ) :: ldrim0 ! indicate if rim 0 is treated 311 INTEGER , INTENT(in ) :: kdbi, kdei, kdbj, kdej ! size of array 312 INTEGER :: ib, igrd ! dummy loop indices 313 INTEGER :: ii, ij, iibm1, ijbm1 ! indices 286 314 !!---------------------------------------------------------------------- 287 315 ! 288 316 igrd = 2 ! Orlanski bc on u-velocity; 289 317 ! 290 CALL bdy_orlanski_2d( idx, igrd, pub2d, pua2d, dta%u2d, l lrim0, ll_npo )318 CALL bdy_orlanski_2d( idx, igrd, pub2d, pua2d, dta%u2d, ldrim0, ld_npo ) 291 319 292 320 igrd = 3 ! Orlanski bc on v-velocity 293 321 ! 294 CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, l lrim0, ll_npo )322 CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, ldrim0, ld_npo ) 295 323 ! 296 324 END SUBROUTINE bdy_dyn2d_orlanski 297 325 298 326 299 SUBROUTINE bdy_ssh( zssh )327 SUBROUTINE bdy_ssh( zssh, kdbi, kdei, kdbj, kdej, ldcomall, pmask, khlcom ) 300 328 !!---------------------------------------------------------------------- 301 329 !! *** SUBROUTINE bdy_ssh *** … … 304 332 !! 305 333 !!---------------------------------------------------------------------- 306 REAL(wp), DIMENSION(jpi,jpj,1), INTENT(inout) :: zssh ! Sea level, need 3 dimensions to be used by bdy_nmn 334 REAL(wp), DIMENSION(kdbi:kdei,kdbj:kdej,1), INTENT(inout) :: zssh ! Sea level, need 3 dimensions to be used by bdy_nmn 335 INTEGER , INTENT(in ) :: kdbi, kdei, kdbj, kdej ! size of ssh array 336 LOGICAL , OPTIONAL, INTENT(in ) :: ldcomall ! communicate with all neighbours 337 REAL(wp), OPTIONAL, DIMENSION(kdbi:kdei,kdbj:kdej,1), INTENT(in) :: pmask ! optional mask for extended domain 338 INTEGER , OPTIONAL, INTENT(in) :: khlcom ! number of halos to communicate 307 339 !! 308 340 INTEGER :: ib_bdy, ir ! bdy index, rim index 309 341 INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) 342 INTEGER :: ihl ! thickness of halo 310 343 LOGICAL :: llrim0 ! indicate if rim 0 is treated 311 344 LOGICAL, DIMENSION(4) :: llsend1, llrecv1 ! indicate how communications are to be carried out 312 345 !!---------------------------------------------------------------------- 313 346 llsend1(:) = .false. ; llrecv1(:) = .false. 347 ! 314 348 DO ir = 1, 0, -1 ! treat rim 1 before rim 0 315 349 IF( nn_hls == 1 ) THEN ; llsend1(:) = .false. ; llrecv1(:) = .false. ; END IF … … 318 352 END IF 319 353 DO ib_bdy = 1, nb_bdy 320 CALL bdy_nmn( idx_bdy(ib_bdy), 1, zssh, llrim0) ! zssh is masked354 CALL bdy_nmn( idx_bdy(ib_bdy), 1, kdbi, kdei, kdbj, kdej, 1, zssh, ldrim0=llrim0, pmask=pmask ) ! zssh is masked 321 355 llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points 322 356 llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(ib_bdy,1,:,ir) ! possibly every direction, T points 323 357 END DO 324 358 IF( nn_hls > 1 .AND. ir == 1 ) CYCLE ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 325 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 326 CALL lbc_lnk( 'bdydyn2d', zssh(:,:,1), 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 359 ! N.B. ihl>1 is not enough as values are usually wrong on extended domain 360 IF( PRESENT(ldcomall) ) THEN 361 IF( ldcomall ) THEN ! if ldcomall is present and true 362 CALL lbc_lnk( 'bdydyn2d', zssh(:,:,1), 'T', 1., kfillmode=jpfillnothing, khlcom=khlcom ) ! com with all neighbours 363 END IF 364 ELSEIF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 365 CALL lbc_lnk( 'bdydyn2d', zssh(:,:,1), 'T', 1., kfillmode=jpfillnothing, ldsend=llsend1, ldrecv=llrecv1, khlcom=khlcom ) 327 366 END IF 328 367 END DO -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/BDY/bdydyn3d.F90
r11234 r11380 97 97 ! 98 98 IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction 99 CALL lbc_lnk( 'bdydyn2d', ua, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 )99 CALL lbc_lnk( 'bdydyn2d', ua, 'U', -1., kfillmode=jpfillnothing, ldsend=llsend2, ldrecv=llrecv2 ) 100 100 END IF 101 101 IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction 102 CALL lbc_lnk( 'bdydyn2d', va, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 )102 CALL lbc_lnk( 'bdydyn2d', va, 'V', -1., kfillmode=jpfillnothing, ldsend=llsend3, ldrecv=llrecv3 ) 103 103 END IF 104 104 END DO ! ir … … 387 387 igrd = 2 ! Neumann bc on u-velocity; 388 388 ! 389 CALL bdy_nmn( idx, igrd, ua, llrim0 ) ! ua is masked389 CALL bdy_nmn( idx, igrd, 1, jpi, 1, jpj, 1, ua, llrim0 ) ! ua is masked 390 390 391 391 igrd = 3 ! Neumann bc on v-velocity 392 392 ! 393 CALL bdy_nmn( idx, igrd, va, llrim0 ) ! va is masked393 CALL bdy_nmn( idx, igrd, 1, jpi, 1, jpj, 1, va, llrim0 ) ! va is masked 394 394 ! 395 395 END SUBROUTINE bdy_dyn3d_nmn -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/BDY/bdyice.F90
r11210 r11380 96 96 & , a_ip, 'T', 1., v_ip, 'T', 1., s_i , 'T', 1., t_su, 'T', 1. & 97 97 & , v_i , 'T', 1., v_s , 'T', 1., sv_i, 'T', 1. & 98 & , kfillmode=jpfillnothing ,l send=llsend1, lrecv=llrecv1)98 & , kfillmode=jpfillnothing ,ldsend=llsend1, ldrecv=llrecv1 ) 99 99 ! exchange 4d arrays : third dimension = 1 and then third dimension = jpk 100 CALL lbc_lnk_multi( 'bdyice', t_s , 'T', 1., e_s , 'T', 1., kfillmode=jpfillnothing ,l send=llsend1, lrecv=llrecv1 )101 CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1., e_i , 'T', 1., kfillmode=jpfillnothing ,l send=llsend1, lrecv=llrecv1 )100 CALL lbc_lnk_multi( 'bdyice', t_s , 'T', 1., e_s , 'T', 1., kfillmode=jpfillnothing ,ldsend=llsend1, ldrecv=llrecv1 ) 101 CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1., e_i , 'T', 1., kfillmode=jpfillnothing ,ldsend=llsend1, ldrecv=llrecv1 ) 102 102 END IF 103 103 END DO ! ir … … 418 418 END DO 419 419 IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction 420 CALL lbc_lnk( 'bdyice', u_ice, 'U', -1., kfillmode=jpfillnothing ,l send=llsend2, lrecv=llrecv2 )420 CALL lbc_lnk( 'bdyice', u_ice, 'U', -1., kfillmode=jpfillnothing ,ldsend=llsend2, ldrecv=llrecv2 ) 421 421 END IF 422 422 CASE ( 'V' ) … … 432 432 END DO 433 433 IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction 434 CALL lbc_lnk( 'bdyice', v_ice, 'V', -1., kfillmode=jpfillnothing ,l send=llsend3, lrecv=llrecv3 )434 CALL lbc_lnk( 'bdyice', v_ice, 'V', -1., kfillmode=jpfillnothing ,ldsend=llsend3, ldrecv=llrecv3 ) 435 435 END IF 436 436 END SELECT -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/BDY/bdyini.F90
r11356 r11380 37 37 38 38 INTEGER, PARAMETER :: jp_nseg = 100 ! 39 INTEGER :: ihl ! number of halos to be communicated 39 40 ! Straight open boundary segment parameters: 40 41 INTEGER :: nbdysege, nbdysegw, nbdysegn, nbdysegs … … 70 71 & ln_vol, nn_volctl, nn_rimwidth 71 72 ! 72 INTEGER :: ios ! Local integer output status for namelist read 73 INTEGER :: ios ! Local integer output status for namelist read 74 INTEGER :: idbi, idbj, idei, idej ! start/end of the subdomain for extended and regular bdy treatment 73 75 !!---------------------------------------------------------------------- 74 76 … … 105 107 106 108 IF( nb_bdy == 0 ) ln_bdy = .FALSE. 107 109 110 IF( nn_hlts > 1 .AND. MOD(nn_hlts,2)==0 ) THEN 111 WRITE(ctmp1,*) 'Number of added halos for time splitting nn_hlts set to ',nn_hlts & 112 & ,' in namelist, is here set to ', nn_hlts-1 ,' must be odd' 113 CALL ctl_warn( ctmp1 ) 114 nn_hlts = nn_hlts - 1 115 END IF 116 ! 117 IF( nn_hlts > 1 .AND. ln_tide ) THEN 118 WRITE(ctmp1,*) 'Number of added halos for time splitting nn_hlts set to ',nn_hlts & 119 & ,' in namelist, is here set to 1 for compatibility with tide treatment' 120 CALL ctl_warn( ctmp1 ) 121 nn_hlts = 1 122 END IF 123 ! 124 IF( nn_hlts > 1 .AND. ln_bdy ) THEN 125 WRITE(ctmp1,*) 'Number of added halos for time splitting nn_hlts set to ',nn_hlts & 126 & ,' in namelist, is here set to 1 for compatibility with boundary treatment' 127 CALL ctl_warn( ctmp1 ) 128 nn_hlts = 1 129 END IF 108 130 ! ----------------------------------------- 109 131 ! unstructured open boundaries use control … … 115 137 ! 116 138 ! Open boundaries definition (arrays and masks) 117 CALL bdy_def 139 ! extended : interior domain + global halo + halo extension for time-splitting 140 idbi = 1 - nn_hlts ; idbj = 1 - nn_hlts 141 idei = jpi + nn_hlts ; idej = jpj + nn_hlts 142 idx_bdy => idx_bdy_xtd 143 dta_bdy => dta_bdy_xtd 144 lsend_bdy => lsend_bdy_xtd(:,:,:,:) 145 lrecv_bdy => lrecv_bdy_xtd(:,:,:,:) 146 lsend_bdyint => lsend_bdyint_xtd(:,:,:,:) 147 lrecv_bdyint => lrecv_bdyint_xtd(:,:,:,:) 148 lsend_bdyext => lsend_bdyext_xtd(:,:,:,:) 149 lrecv_bdyext => lrecv_bdyext_xtd(:,:,:,:) 150 CALL bdy_def( idbi, idbj, idei, idej, .true. ) 151 CALL swap_bdyptr 152 ! regular : interior domain + global halo 153 idbi = 1 ; idbj = 1 ; idei = jpi ; idej = jpj 154 idx_bdy => idx_bdy_reg 155 dta_bdy => dta_bdy_reg 156 lsend_bdy => lsend_bdy_reg(:,:,:,:) 157 lrecv_bdy => lrecv_bdy_reg(:,:,:,:) 158 lsend_bdyint => lsend_bdyint_reg(:,:,:,:) 159 lrecv_bdyint => lrecv_bdyint_reg(:,:,:,:) 160 lsend_bdyext => lsend_bdyext_reg(:,:,:,:) 161 lrecv_bdyext => lrecv_bdyext_reg(:,:,:,:) 162 CALL bdy_def( idbi, idbj, idei, idej ) 163 ! current bdy treated is regular 164 ! 118 165 IF( ln_meshmask ) CALL bdy_meshwri() 119 166 ! … … 134 181 135 182 136 SUBROUTINE bdy_def 183 SUBROUTINE bdy_def( idbi, idbj, idei, idej, ldxtd ) 137 184 !!---------------------------------------------------------------------- 138 185 !! *** ROUTINE bdy_init *** … … 144 191 !! 145 192 !! ** Input : bdy_init.nc, input file for unstructured open boundaries 146 !!---------------------------------------------------------------------- 193 !!---------------------------------------------------------------------- 194 INTEGER , INTENT(in) :: idbi, idbj, idei, idej ! start/end of the subdomain for extended and regular bdy treatment 195 LOGICAL, OPTIONAL, INTENT(in) :: ldxtd ! indicate if extended domain is treated (for time splitting) 147 196 INTEGER :: ib_bdy, ii, ij, igrd, ib, ir, iseg ! dummy loop indices 148 197 INTEGER :: icount, icountr, icountr0, ibr_max ! local integers 149 INTEGER :: ilen1 ! - -150 198 INTEGER :: iwe, ies, iso, ino, inum, id_dummy ! - - 151 INTEGER :: jpbdta 199 INTEGER :: jpbdta, ilen1 ! - - 152 200 INTEGER :: ib_bdy1, ib_bdy2, ib1, ib2 ! - - 153 201 INTEGER :: ii1, ii2, ii3, ij1, ij2, ij3 ! - - 154 202 INTEGER :: iibe, ijbe, iibi, ijbi ! - - 203 INTEGER :: iint1, iout1, iint2, iout2 ! - - 155 204 INTEGER :: flagu, flagv ! short cuts 156 205 INTEGER :: nbdyind, nbdybeg, nbdyend 206 INTEGER :: ihl ! total number of halos ( with added halos for time splitting) 157 207 INTEGER , DIMENSION(4) :: kdimsz 158 208 INTEGER , DIMENSION(jpbgrd,jp_bdy) :: nblendta ! Length of index arrays … … 162 212 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zz_read ! work space for 2D global boundary data 163 213 REAL(wp), POINTER , DIMENSION(:,:) :: zmask ! pointer to 2D mask fields 164 REAL(wp) , DIMENSION(jpi,jpj) :: zfmask ! temporary fmask array excluding coastal boundary condition (shlat) 165 REAL(wp) , DIMENSION(jpi,jpj) :: ztmask, zumask, zvmask ! temporary u/v mask array 214 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zfmask ! temporary fmask array excluding coastal boundary condition (shlat) 215 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztmask, zumask, zvmask ! temporary u/v mask array 216 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zbdytmask, zbdyumask, zbdyvmask ! temporary u/v mask array 166 217 !!---------------------------------------------------------------------- 167 218 ! 168 219 cgrid = (/'t','u','v'/) 169 220 221 ihl = nn_hls 222 IF( PRESENT(ldxtd) ) THEN ; IF( ldxtd ) ihl = nn_hls + nn_hlts ; ENDIF 223 224 ALLOCATE( zfmask(idbi:idei,idbj:idej), ztmask(idbi:idei,idbj:idej) & 225 & , zumask(idbi:idei,idbj:idej), zvmask(idbi:idei,idbj:idej) ) 226 227 ALLOCATE( zbdytmask(idbi:idei,idbj:idej), zbdyumask(idbi:idei,idbj:idej), zbdyvmask(idbi:idei,idbj:idej) ) 170 228 ! ----------------------------------------- 171 229 ! Check and write out namelist parameters … … 488 546 !------------------------------------------------------ 489 547 ! 490 iwe = mig(1)491 ies = mig(jpi)492 iso = mjg(1)493 ino = mjg(jpj)548 iwe = idbi + nimpp - 1 549 ies = idei + nimpp - 1 550 iso = idbj + njmpp - 1 551 ino = idej + njmpp - 1 494 552 ! 495 553 DO ib_bdy = 1, nb_bdy … … 551 609 ! 552 610 icount = icount + 1 553 idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy)- mig(1)+1 ! global to local indexes554 idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 ! global to local indexes611 idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy)- (1+nimpp-1)+1 ! global to local indexes 612 idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy)- (1+njmpp-1)+1 ! global to local indexes 555 613 idx_bdy(ib_bdy)%nbr(icount,igrd) = nbrdta(ib,igrd,ib_bdy) 556 614 idx_bdy(ib_bdy)%nbmap(icount,igrd) = ib … … 579 637 ! check if point has to be sent to a neighbour 580 638 ! W neighbour and on the inner left side 581 IF( ii == 2.and. (nbondi == 0 .or. nbondi == 1) ) lsend_bdy(ib_bdy,igrd,1,ir) = .true.639 IF( ii == idbi + 1 .and. (nbondi == 0 .or. nbondi == 1) ) lsend_bdy(ib_bdy,igrd,1,ir) = .true. 582 640 ! E neighbour and on the inner right side 583 IF( ii == jpi-1 .and. (nbondi == 0 .or. nbondi == -1) ) lsend_bdy(ib_bdy,igrd,2,ir) = .true.641 IF( ii == idei - 1 .and. (nbondi == 0 .or. nbondi == -1) ) lsend_bdy(ib_bdy,igrd,2,ir) = .true. 584 642 ! S neighbour and on the inner down side 585 IF( ij == 2.and. (nbondj == 0 .or. nbondj == 1) ) lsend_bdy(ib_bdy,igrd,3,ir) = .true.643 IF( ij == idbj + 1 .and. (nbondj == 0 .or. nbondj == 1) ) lsend_bdy(ib_bdy,igrd,3,ir) = .true. 586 644 ! N neighbour and on the inner up side 587 IF( ij == jpj-1 .and. (nbondj == 0 .or. nbondj == -1) ) lsend_bdy(ib_bdy,igrd,4,ir) = .true.645 IF( ij == idej - 1 .and. (nbondj == 0 .or. nbondj == -1) ) lsend_bdy(ib_bdy,igrd,4,ir) = .true. 588 646 ! 589 647 ! check if point has to be received from a neighbour 590 648 ! W neighbour and on the outter left side 591 IF( ii == 1.and. (nbondi == 0 .or. nbondi == 1) ) lrecv_bdy(ib_bdy,igrd,1,ir) = .true.649 IF( ii == idbi .and. (nbondi == 0 .or. nbondi == 1) ) lrecv_bdy(ib_bdy,igrd,1,ir) = .true. 592 650 ! E neighbour and on the outter right side 593 IF( ii == jpi.and. (nbondi == 0 .or. nbondi == -1) ) lrecv_bdy(ib_bdy,igrd,2,ir) = .true.651 IF( ii == idei .and. (nbondi == 0 .or. nbondi == -1) ) lrecv_bdy(ib_bdy,igrd,2,ir) = .true. 594 652 ! S neighbour and on the outter down side 595 IF( ij == 1.and. (nbondj == 0 .or. nbondj == 1) ) lrecv_bdy(ib_bdy,igrd,3,ir) = .true.653 IF( ij == idbj .and. (nbondj == 0 .or. nbondj == 1) ) lrecv_bdy(ib_bdy,igrd,3,ir) = .true. 596 654 ! N neighbour and on the outter up side 597 IF( ij == jpj.and. (nbondj == 0 .or. nbondj == -1) ) lrecv_bdy(ib_bdy,igrd,4,ir) = .true.655 IF( ij == idej .and. (nbondj == 0 .or. nbondj == -1) ) lrecv_bdy(ib_bdy,igrd,4,ir) = .true. 598 656 ! 599 657 END DO … … 633 691 ! ------------------------------------------ 634 692 635 ztmask(:,:) = tmask(:,:,1) ; zumask(:,:) = umask(:,:,1) ; zvmask(:,:) = vmask(:,:,1) 693 ztmask(1:jpi,1:jpj) = tmask(1:jpi,1:jpj,1) 694 zumask(1:jpi,1:jpj) = umask(1:jpi,1:jpj,1) 695 zvmask(1:jpi,1:jpj) = vmask(1:jpi,1:jpj,1) 636 696 ! For the flagu/flagv calculation below we require a version of fmask without 637 697 ! the land boundary condition (shlat) included: 638 DO ij = 1, jpjm1639 DO ii = 1, jpim1698 DO ij = 1, idej - 1 699 DO ii = 1, idei - 1 640 700 zfmask(ii,ij) = ztmask(ii,ij ) * ztmask(ii+1,ij ) & 641 701 & * ztmask(ii,ij+1) * ztmask(ii+1,ij+1) 642 702 END DO 643 703 END DO 644 CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. )704 CALL lbc_lnk( 'bdyini', zfmask, 'F', 1., khlcom = ihl ) 645 705 646 706 ! Read global 2D mask at T-points: bdytmask … … 648 708 ! bdytmask = 1 on the computational domain AND on open boundaries 649 709 ! = 0 elsewhere 650 651 bdytmask(:,:) = ssmask(:,:) 710 zbdytmask(1:jpi,1:jpj) = ssmask(1:jpi,1:jpj) 652 711 653 712 ! Derive mask on U and V grid from mask on T grid 654 DO ij = 1, jpjm1655 DO ii = 1, jpim1656 bdyumask(ii,ij) = bdytmask(ii,ij) *bdytmask(ii+1,ij )657 bdyvmask(ii,ij) = bdytmask(ii,ij) *bdytmask(ii ,ij+1)713 DO ij = 1, idej - 1 714 DO ii = 1, idei - 1 715 zbdyumask(ii,ij) = zbdytmask(ii,ij) * zbdytmask(ii+1,ij ) 716 zbdyvmask(ii,ij) = zbdytmask(ii,ij) * zbdytmask(ii ,ij+1) 658 717 END DO 659 718 END DO 660 CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1., bdyvmask, 'V', 1.) ! Lateral boundary cond.719 CALL lbc_lnk_multi( 'bdyini', zbdytmask, 'T', 1., zbdyumask, 'U', 1., zbdyvmask, 'V', 1., khlcom = ihl ) ! Lateral boundary cond. 661 720 662 721 ! bdy masks are now set to zero on rim 0 points: 663 722 DO ib_bdy = 1, nb_bdy 664 723 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1) ! extent of rim 0 665 bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp724 zbdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp 666 725 END DO 667 726 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2) ! extent of rim 0 668 bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp727 zbdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp 669 728 END DO 670 729 DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3) ! extent of rim 0 671 bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp730 zbdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp 672 731 END DO 673 732 END DO 674 675 CALL bdy_rim_treat( zumask, zvmask, zfmask, .true. ) ! compute flagu, flagv, ntreat on rim 0733 ! compute flagu, flagv, ntreat on rim 0 734 CALL bdy_rim_treat( zumask, zvmask, zfmask, zbdytmask, zbdyumask, zbdyvmask, .true., idbi, idei, idbj, idej, ldxtd ) 676 735 677 736 ! ------------------------------------ … … 699 758 END DO 700 759 END DO 701 CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. )760 CALL lbc_lnk( 'bdyini', zfmask, 'F', 1., khlcom = ihl ) 702 761 703 762 ! bdy masks are now set to zero on rim1 points: 704 763 DO ib_bdy = 1, nb_bdy 705 764 DO ib = idx_bdy(ib_bdy)%nblenrim0(1) + 1, idx_bdy(ib_bdy)%nblenrim(1) ! extent of rim 1 706 bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp765 zbdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp 707 766 END DO 708 767 DO ib = idx_bdy(ib_bdy)%nblenrim0(2) + 1, idx_bdy(ib_bdy)%nblenrim(2) ! extent of rim 1 709 bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp768 zbdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp 710 769 END DO 711 770 DO ib = idx_bdy(ib_bdy)%nblenrim0(3) + 1, idx_bdy(ib_bdy)%nblenrim(3) ! extent of rim 1 712 bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp771 zbdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp 713 772 END DO 714 773 END DO 715 716 CALL bdy_rim_treat( zumask, zvmask, zfmask, .false. ) ! compute flagu, flagv, ntreat on rim 1774 ! compute flagu, flagv, ntreat on rim 1 775 CALL bdy_rim_treat( zumask, zvmask, zfmask, zbdytmask, zbdyumask, zbdyvmask, .false., idbi, idei, idbj, idej, ldxtd ) 717 776 ! 718 777 ! Check which boundaries might need communication … … 743 802 ! <-- (o exterior) --> 744 803 ! (1) o|x OR (2) x|o 745 ! |___ ___| 746 IF( iibi == 0 .OR. ii1 == 0 .OR. ii2 == 0 .OR. ii3 == 0 ) lrecv_bdyint(ib_bdy,igrd,1,ir) = .true. 747 IF( iibi == jpi+1 .OR. ii1 == jpi+1 .OR. ii2 == jpi+1 .OR. ii3 == jpi+1 ) lrecv_bdyint(ib_bdy,igrd,2,ir) = .true. 748 IF( iibe == 0 ) lrecv_bdyext(ib_bdy,igrd,1,ir) = .true. 749 IF( iibe == jpi+1 ) lrecv_bdyext(ib_bdy,igrd,2,ir) = .true. 804 ! |___ ___| 805 iout1 = idbi-1 ; iout2 = idei+1 806 IF( iibi == iout1 .OR. ii1 == iout1 .OR. ii2 == iout1 .OR. ii3 == iout1 ) lrecv_bdyint(ib_bdy,igrd,1,ir)=.true. 807 IF( iibi == iout2 .OR. ii1 == iout2 .OR. ii2 == iout2 .OR. ii3 == iout2 ) lrecv_bdyint(ib_bdy,igrd,2,ir)=.true. 808 IF( iibe == iout1 ) lrecv_bdyext(ib_bdy,igrd,1,ir)=.true. 809 IF( iibe == iout2 ) lrecv_bdyext(ib_bdy,igrd,2,ir)=.true. 750 810 ! Check if neighbour has its rim parallel to its mpi subdomain border and located next to its halo 751 811 ! :¨¨¨¨¨|¨¨--> | | <--¨¨|¨¨¨¨¨: 752 812 ! : | x:o | neighbour limited by ... would need o | o:x | : 753 813 ! :.....|_._:_____| (1) W neighbour E neighbour (2) |_____:_._|.....: 754 IF( ii == 2 .AND. ( nbondi == 1 .OR. nbondi == 0 ) .AND. & 755 & ( iibi == 3 .OR. ii1 == 3 .OR. ii2 == 3 .OR. ii3 == 3 ) ) lsend_bdyint(ib_bdy,igrd,1,ir)=.true. 756 IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. & 757 & ( iibi == jpi-2 .OR. ii1 == jpi-2 .OR. ii2 == jpi-2 .OR. ii3 == jpi-2) ) lsend_bdyint(ib_bdy,igrd,2,ir)=.true. 758 IF( ii == 2 .AND. ( nbondi == 1 .OR. nbondi == 0 ) .AND. iibe == 3 ) lsend_bdyext(ib_bdy,igrd,1,ir)=.true. 759 IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. iibe == jpi-2 ) lsend_bdyext(ib_bdy,igrd,2,ir)=.true. 814 iout1 = idbi+2*ihl ; iint1 = iout1-1 ; iout2 = idei-2*ihl ; iint2 = iout2+1 815 IF( ii == iint1 .AND. (nbondi== 1 .OR. nbondi==0) .AND. & 816 & (iibi == iout1 .OR. ii1 == iout1 .OR. ii2 == iout1 .OR. ii3 == iout1) ) lsend_bdyint(ib_bdy,igrd,1,ir)=.true. 817 IF( ii == iint2 .AND. (nbondi==-1 .OR. nbondi==0) .AND. & 818 & (iibi == iout2 .OR. ii1 == iout2 .OR. ii2 == iout2 .OR. ii3 == iout2) ) lsend_bdyint(ib_bdy,igrd,2,ir)=.true. 819 IF( ii == iint1 .AND. (nbondi== 1 .OR. nbondi==0) .AND. iibe == iout1 ) lsend_bdyext(ib_bdy,igrd,1,ir)=.true. 820 IF( ii == iint2 .AND. (nbondi==-1 .OR. nbondi==0) .AND. iibe == iout2 ) lsend_bdyext(ib_bdy,igrd,2,ir)=.true. 760 821 ! 761 822 ! search neighbour in the north/south direction … … 764 825 ! | |___x___| OR | | x | 765 826 ! v o (4) | | 766 IF( ijbi == 0 .OR. ij1 == 0 .OR. ij2 == 0 .OR. ij3 == 0 ) lrecv_bdyint(ib_bdy,igrd,3,ir) = .true. 767 IF( ijbi == jpj+1 .OR. ij1 == jpj+1 .OR. ij2 == jpj+1 .OR. ij3 == jpj+1 ) lrecv_bdyint(ib_bdy,igrd,4,ir) = .true. 768 IF( ijbe == 0 ) lrecv_bdyext(ib_bdy,igrd,3,ir) = .true. 769 IF( ijbe == jpj+1 ) lrecv_bdyext(ib_bdy,igrd,4,ir) = .true. 827 iout1 = idbj-1 ; iout2 = idej+1 828 IF( ijbi == iout1 .OR. ij1 == iout1 .OR. ij2 == iout1 .OR. ij3 == iout1 ) lrecv_bdyint(ib_bdy,igrd,3,ir)=.true. 829 IF( ijbi == iout2 .OR. ij1 == iout2 .OR. ij2 == iout2 .OR. ij3 == iout2 ) lrecv_bdyint(ib_bdy,igrd,4,ir)=.true. 830 IF( ijbe == iout1 ) lrecv_bdyext(ib_bdy,igrd,3,ir)=.true. 831 IF( ijbe == iout2 ) lrecv_bdyext(ib_bdy,igrd,4,ir)=.true. 770 832 ! Check if neighbour has its rim parallel to its mpi subdomain _________ border and next to its halo 771 833 ! ^ | o | : : 772 834 ! | |¨¨¨¨x¨¨¨¨| neighbour limited by ... would need o | |....x....| 773 835 ! :_________: (3) S neighbour N neighbour (4) v | o | 774 IF( ij == 2 .AND. ( nbondj == 1 .OR. nbondj == 0 ) .AND. & 775 & ( ijbi == 3 .OR. ij1 == 3 .OR. ij2 == 3 .OR. ij3 == 3 ) ) lsend_bdyint(ib_bdy,igrd,3,ir)=.true. 776 IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. & 777 & ( ijbi == jpj-2 .OR. ij1 == jpj-2 .OR. ij2 == jpj-2 .OR. ij3 == jpj-2) ) lsend_bdyint(ib_bdy,igrd,4,ir)=.true. 778 IF( ij == 2 .AND. ( nbondj == 1 .OR. nbondj == 0 ) .AND. ijbe == 3 ) lsend_bdyext(ib_bdy,igrd,3,ir)=.true. 779 IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. ijbe == jpj-2 ) lsend_bdyext(ib_bdy,igrd,4,ir)=.true. 836 iout1 = idbj+2*ihl ; iint1 = iout1-1 ; iout2 = idej-2*ihl ; iint2 = iout2+1 837 IF( ij == iint1 .AND. (nbondj== 1 .OR. nbondj==0) .AND. & 838 & (ijbi == iout1 .OR. ij1 == iout1 .OR. ij2 == iout1 .OR. ij3 == iout1) ) lsend_bdyint(ib_bdy,igrd,3,ir)=.true. 839 IF( ij == iint2 .AND. (nbondj==-1 .OR. nbondj==0) .AND. & 840 & (ijbi == iout2 .OR. ij1 == iout2 .OR. ij2 == iout2 .OR. ij3 == iout2) ) lsend_bdyint(ib_bdy,igrd,4,ir)=.true. 841 IF( ij == iint1 .AND. (nbondj== 1 .OR. nbondj==0) .AND. ijbe == iout1 ) lsend_bdyext(ib_bdy,igrd,3,ir)=.true. 842 IF( ij == iint2 .AND. (nbondj==-1 .OR. nbondj==0) .AND. ijbe == iout2 ) lsend_bdyext(ib_bdy,igrd,4,ir)=.true. 780 843 END DO 781 844 END DO … … 799 862 END DO 800 863 ! 801 DEALLOCATE( nbidta, nbjdta, nbrdta ) 864 ! initialize bdyXmask for global use 865 bdytmask(1:jpi,1:jpj) = zbdytmask(1:jpi,1:jpj) 866 bdyumask(1:jpi,1:jpj) = zbdyumask(1:jpi,1:jpj) 867 bdyvmask(1:jpi,1:jpj) = zbdyvmask(1:jpi,1:jpj) 868 ! 869 DEALLOCATE( nbidta, nbjdta, nbrdta, zfmask, ztmask, zumask, zvmask, zbdytmask, zbdyumask, zbdyvmask ) 802 870 ! 803 871 END SUBROUTINE bdy_def 804 872 805 873 806 SUBROUTINE bdy_rim_treat( pumask, pvmask, pfmask, lrim0)874 SUBROUTINE bdy_rim_treat( pumask, pvmask, pfmask, pbdytmask, pbdyumask, pbdyvmask, lrim0, idbi, idei, idbj, idej, ldxtd ) 807 875 !!---------------------------------------------------------------------- 808 876 !! *** ROUTINE bdy_rim_treat *** … … 821 889 !! - and look at the ocean neighbours to compute ntreat 822 890 !!---------------------------------------------------------------------- 823 REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pfmask ! temporary fmask excluding coastal boundary condition (shlat) 824 REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pumask, pvmask ! temporary t/u/v mask array 825 LOGICAL , INTENT (in ) :: lrim0 ! .true. -> rim 0 .false. -> rim 1 891 REAL(wp), TARGET, DIMENSION(idbi:idei,idbj:idej), INTENT(in ) :: pfmask ! temporary fmask excluding coastal boundary condition (shlat) 892 REAL(wp), TARGET, DIMENSION(idbi:idei,idbj:idej), INTENT(in ) :: pumask, pvmask ! temporary t/u/v mask array 893 REAL(wp), TARGET, DIMENSION(idbi:idei,idbj:idej), INTENT(in ) :: pbdytmask, pbdyumask, pbdyvmask 894 LOGICAL , INTENT(in ) :: lrim0 ! .true. -> rim 0 .false. -> rim 1 895 INTEGER , INTENT(in ) :: idbi, idbj, idei, idej ! start/end of the subdomain 896 ! for extended and regular bdy treatment 897 LOGICAL, OPTIONAL , INTENT(in ) :: ldxtd ! number of halos added to nn_hls for time splitting 898 ! 826 899 INTEGER :: ib_bdy, ii, ij, igrd, ib, icount ! dummy loop indices 827 INTEGER :: i_offset, j_offset, inn 900 INTEGER :: i_offset, j_offset, inn, ihl ! local integer 828 901 INTEGER :: ibeg, iend ! local integer 829 902 LOGICAL :: llnon, llson, llean, llwen ! local logicals indicating the presence of a ocean neighbour … … 831 904 REAL(wp) :: zefl, zwfl, znfl, zsfl ! local scalars 832 905 CHARACTER(LEN=1), DIMENSION(jpbgrd) :: cgrid 833 REAL(wp) , DIMENSION( jpi,jpj) :: ztmp906 REAL(wp) , DIMENSION(idbi:idei,idbj:idej) :: ztmp 834 907 !!---------------------------------------------------------------------- 835 908 836 909 cgrid = (/'t','u','v'/) 910 ihl = nn_hls 911 IF( PRESENT(ldxtd) ) THEN ; IF( ldxtd ) ihl = nn_hls + nn_hlts ; ENDIF 837 912 838 913 DO ib_bdy = 1, nb_bdy ! Indices and directions of rim velocity components … … 844 919 DO igrd = 1, jpbgrd 845 920 SELECT CASE( igrd ) 846 CASE( 1 ) ; zmask => pumask ; i_offset = 0847 CASE( 2 ) ; zmask => bdytmask ; i_offset = 1848 CASE( 3 ) ; zmask => pfmask ; i_offset = 0921 CASE( 1 ) ; zmask => pumask ; i_offset = 0 922 CASE( 2 ) ; zmask => pbdytmask ; i_offset = 1 923 CASE( 3 ) ; zmask => pfmask ; i_offset = 0 849 924 END SELECT 850 925 icount = 0 … … 858 933 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 859 934 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 860 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE935 IF( ii == idbi .OR. ii == idei .OR. ij == idbj .OR. ij == idej ) CYCLE 861 936 zwfl = zmask(ii+i_offset-1,ij) 862 937 zefl = zmask(ii+i_offset ,ij) … … 873 948 ' are not boundary points (flagu calculation). Check nbi, nbj, indices for boundary set ',ib_bdy 874 949 CALL ctl_stop( ctmp1 ) 875 ENDIF 950 ENDIF 876 951 SELECT CASE( igrd ) 877 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )878 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )879 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )880 END SELECT 952 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1., khlcom = ihl ) 953 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1., khlcom = ihl ) 954 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1., khlcom = ihl ) 955 END SELECT 881 956 DO ib = ibeg, iend 882 957 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) … … 892 967 DO igrd = 1, jpbgrd 893 968 SELECT CASE( igrd ) 894 CASE( 1 ) ; zmask => pvmask ; j_offset = 0895 CASE( 2 ) ; zmask => pfmask ; j_offset = 0896 CASE( 3 ) ; zmask => bdytmask ; j_offset = 1969 CASE( 1 ) ; zmask => pvmask ; j_offset = 0 970 CASE( 2 ) ; zmask => pfmask ; j_offset = 0 971 CASE( 3 ) ; zmask => pbdytmask ; j_offset = 1 897 972 END SELECT 898 973 icount = 0 … … 906 981 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 907 982 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 908 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE983 IF( ii == idbi .OR. ii == idei .OR. ij == idbj .OR. ij == idej ) CYCLE 909 984 zsfl = zmask(ii,ij+j_offset-1) 910 985 znfl = zmask(ii,ij+j_offset ) … … 923 998 ENDIF 924 999 SELECT CASE( igrd ) 925 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )926 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )927 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )928 END SELECT 1000 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1., khlcom = ihl ) 1001 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1., khlcom = ihl ) 1002 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1., khlcom = ihl ) 1003 END SELECT 929 1004 DO ib = ibeg, iend 930 1005 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) … … 939 1014 DO igrd = 1, jpbgrd 940 1015 SELECT CASE( igrd ) 941 CASE( 1 ) ; zmask => bdytmask942 CASE( 2 ) ; zmask => bdyumask943 CASE( 3 ) ; zmask => bdyvmask1016 CASE( 1 ) ; zmask => pbdytmask 1017 CASE( 2 ) ; zmask => pbdyumask 1018 CASE( 3 ) ; zmask => pbdyvmask 944 1019 END SELECT 945 1020 ztmp(:,:) = -999._wp … … 952 1027 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 953 1028 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 954 IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )CYCLE1029 IF( ii == idbi .OR. ii == idei .OR. ij == idbj .OR. ij == idej ) CYCLE 955 1030 llnon = zmask(ii ,ij+1) == 1. 956 1031 llson = zmask(ii ,ij-1) == 1. … … 1011 1086 END DO 1012 1087 SELECT CASE( igrd ) 1013 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )1014 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )1015 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )1016 END SELECT 1088 CASE( 1 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'T', 1., khlcom = ihl ) 1089 CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1., khlcom = ihl ) 1090 CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1., khlcom = ihl ) 1091 END SELECT 1017 1092 DO ib = ibeg, iend 1018 1093 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) … … 1040 1115 INTEGER, INTENT( out) :: ii1, ij1, ii2, ij2, ii3, ij3 1041 1116 !!---------------------------------------------------------------------- 1042 SELECT CASE( itreat ) ! points that will be used by bdy routines, - 1will be discarded1117 SELECT CASE( itreat ) ! points that will be used by bdy routines, -99 will be discarded 1043 1118 ! ! ! _____ ! _____ 1044 1119 ! 1 | o ! 2 o | ! 3 | x ! 4 x | 1045 1120 ! |_x_ _ ! _ _x_| ! | o ! o | 1046 CASE( 1 ) ; ii1 = ii+1 ; ij1 = ij+1 ; ii2 = - 1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -11047 CASE( 2 ) ; ii1 = ii-1 ; ij1 = ij+1 ; ii2 = - 1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -11048 CASE( 3 ) ; ii1 = ii+1 ; ij1 = ij-1 ; ii2 = - 1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -11049 CASE( 4 ) ; ii1 = ii-1 ; ij1 = ij-1 ; ii2 = - 1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -11121 CASE( 1 ) ; ii1 = ii+1 ; ij1 = ij+1 ; ii2 = -99 ; ij2 = -99 ; ii3 = -99 ; ij3 = -99 1122 CASE( 2 ) ; ii1 = ii-1 ; ij1 = ij+1 ; ii2 = -99 ; ij2 = -99 ; ii3 = -99 ; ij3 = -99 1123 CASE( 3 ) ; ii1 = ii+1 ; ij1 = ij-1 ; ii2 = -99 ; ij2 = -99 ; ii3 = -99 ; ij3 = -99 1124 CASE( 4 ) ; ii1 = ii-1 ; ij1 = ij-1 ; ii2 = -99 ; ij2 = -99 ; ii3 = -99 ; ij3 = -99 1050 1125 ! | ! | ! o ! ______ ! or incomplete corner 1051 1126 ! 5 | x o ! 6 o x | ! 7 __x__ ! 8 x ! 7 ____ o 1052 1127 ! | ! | ! ! o ! |x___ 1053 CASE( 5 ) ; ii1 = ii+1 ; ij1 = ij ; ii2 = - 1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -11054 CASE( 6 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = - 1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -11055 CASE( 7 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = - 1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -11056 CASE( 8 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = - 1 ; ij2 = -1 ; ii3 = -1 ; ij3 = -11128 CASE( 5 ) ; ii1 = ii+1 ; ij1 = ij ; ii2 = -99 ; ij2 = -99 ; ii3 = -99 ; ij3 = -99 1129 CASE( 6 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = -99 ; ij2 = -99 ; ii3 = -99 ; ij3 = -99 1130 CASE( 7 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = -99 ; ij2 = -99 ; ii3 = -99 ; ij3 = -99 1131 CASE( 8 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = -99 ; ij2 = -99 ; ii3 = -99 ; ij3 = -99 1057 1132 ! o ! o ! _____| ! |_____ 1058 1133 ! 9 ____x o ! 10 o x___ ! 11 x o ! 12 o x 1059 1134 ! | ! | ! o ! o 1060 CASE( 9 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = - 1 ; ij3 = -11061 CASE( 10 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = - 1 ; ij3 = -11062 CASE( 11 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = - 1 ; ij3 = -11063 CASE( 12 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = - 1 ; ij3 = -11135 CASE( 9 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = -99 ; ij3 = -99 1136 CASE( 10 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = -99 ; ij3 = -99 1137 CASE( 11 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = -99 ; ij3 = -99 1138 CASE( 12 ) ; ii1 = ii ; ij1 = ij-1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = -99 ; ij3 = -99 1064 1139 ! |_ o ! o _| ! ¨¨|_|¨¨ ! o 1065 1140 ! 13 _| x o ! 14 o x |_ ! 15 o x o ! 16 o x o 1066 1141 ! | o ! o | ! o ! __|¨|__ 1067 CASE( 13 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = ii ; ij3 = ij-1 1068 CASE( 14 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = ii ; ij3 = ij-1 1142 CASE( 13 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii+1 ; ij2 = ij ; ii3 = ii ; ij3 = ij-1 1143 CASE( 14 ) ; ii1 = ii ; ij1 = ij+1 ; ii2 = ii-1 ; ij2 = ij ; ii3 = ii ; ij3 = ij-1 1069 1144 CASE( 15 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = ii ; ij2 = ij-1 ; ii3 = ii+1 ; ij3 = ij 1070 1145 CASE( 16 ) ; ii1 = ii-1 ; ij1 = ij ; ii2 = ii ; ij2 = ij+1 ; ii3 = ii+1 ; ij3 = ij -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/BDY/bdylib.F90
r11258 r11380 449 449 END SUBROUTINE bdy_orlanski_3d 450 450 451 SUBROUTINE bdy_nmn( idx, igrd, phia, lrim0)451 SUBROUTINE bdy_nmn( idx, igrd, idbi, idei, idbj, idej, ipk, phia, ldrim0, pmask ) 452 452 !!---------------------------------------------------------------------- 453 453 !! *** SUBROUTINE bdy_nmn *** … … 463 463 !! ! o 464 464 !!---------------------------------------------------------------------- 465 INTEGER, INTENT(in ) :: igrd ! grid index 466 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated), must be masked 467 TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices 468 LOGICAL, OPTIONAL, INTENT(in ) :: lrim0 ! indicate if rim 0 is treated 469 !! 465 TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices 466 INTEGER , INTENT(in ) :: igrd ! grid index 467 INTEGER , INTENT(in ) :: idbi, idei, idbj, idej, ipk ! size of phia array 468 REAL(wp), DIMENSION(idbi:idei,idbj:idej,ipk), INTENT(inout) :: phia ! model after 3D field (to be updated), must be masked 469 LOGICAL , OPTIONAL, INTENT(in ) :: ldrim0 ! indicate if rim 0 is treated 470 REAL(wp), OPTIONAL, TARGET, DIMENSION(idbi:idei,idbj:idej,1), INTENT(in ) :: pmask ! optional mask for extended domain 471 !! ! always 2d : used by dyn_spg_ts 470 472 REAL(wp) :: zweight 471 473 REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask ! land/sea mask for field … … 477 479 !!---------------------------------------------------------------------- 478 480 ! 479 ipkm1 = MAX( SIZE(phia,3) - 1, 1 ) 480 ! 481 SELECT CASE(igrd) 481 ipkm1 = MAX( ipk-1, 1 ) 482 ! 483 IF( PRESENT(pmask) ) THEN 484 zmask => pmask ! mask for extended domain ! N.B. do not specify (:,:,:) as it does not work for arrays 485 ELSE ! with LBOUND < 1 486 SELECT CASE(igrd) 482 487 CASE(1) ; zmask => tmask(:,:,:) 483 488 CASE(2) ; zmask => umask(:,:,:) 484 489 CASE(3) ; zmask => vmask(:,:,:) 485 490 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for igrd in bdy_nmn' ) 486 END SELECT 487 ! 488 IF( PRESENT(lrim0) ) THEN 489 IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 490 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 491 END SELECT 492 END IF 493 ! 494 IF( PRESENT(ldrim0) ) THEN 495 IF( ldrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 496 ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 491 497 END IF 492 ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both498 ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both 493 499 END IF 494 500 ! … … 500 506 SELECT CASE( itreat ) 501 507 CASE( 1:8 ) 502 IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE508 IF( ii1 < idbi .OR. ii1 > idei .OR. ij1 < idbj .OR. ij1 > idej ) CYCLE 503 509 DO ik = 1, ipkm1 504 510 IF( zmask(ii1,ij1,ik) /= 0. ) phia(ii,ij,ik) = phia(ii1,ij1,ik) 505 511 END DO 506 512 CASE( 9:12 ) 507 IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE508 IF( ii2 < 1 .OR. ii2 > jpi .OR. ij2 < 1 .OR. ij2 > jpj ) CYCLE513 IF( ii1 < idbi .OR. ii1 > idei .OR. ij1 < idbj .OR. ij1 > idej ) CYCLE 514 IF( ii2 < idbi .OR. ii2 > idei .OR. ij2 < idbj .OR. ij2 > idej ) CYCLE 509 515 DO ik = 1, ipkm1 510 516 zweight = zmask(ii1,ij1,ik) + zmask(ii2,ij2,ik) … … 512 518 END DO 513 519 CASE( 13:16 ) 514 IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj ) CYCLE515 IF( ii2 < 1 .OR. ii2 > jpi .OR. ij2 < 1 .OR. ij2 > jpj ) CYCLE516 IF( ii3 < 1 .OR. ii3 > jpi .OR. ij3 < 1 .OR. ij3 > jpj ) CYCLE520 IF( ii1 < idbi .OR. ii1 > idei .OR. ij1 < idbj .OR. ij1 > idej ) CYCLE 521 IF( ii2 < idbi .OR. ii2 > idei .OR. ij2 < idbj .OR. ij2 > idej ) CYCLE 522 IF( ii3 < idbi .OR. ii3 > idei .OR. ij3 < idbj .OR. ij3 > idej ) CYCLE 517 523 DO ik = 1, ipkm1 518 524 zweight = zmask(ii1,ij1,ik) + zmask(ii2,ij2,ik) + zmask(ii3,ij3,ik) -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/BDY/bdytra.F90
r11210 r11380 73 73 CASE('specified' ) ! treat the whole rim at once 74 74 IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy), tsa(:,:,:,jn), zdta(jn)%tra ) 75 CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd , tsa(:,:,:,jn), llrim0 ) !tsa masked75 CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd, 1,jpi, 1,jpj, 1, tsa(:,:,:,jn), llrim0 ) !tsa masked 76 76 CASE('orlanski' ) ; CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), & 77 77 & zdta(jn)%tra, llrim0, ll_npo=.false. ) … … 98 98 END DO 99 99 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 100 CALL lbc_lnk( 'bdytra', tsa, 'T', 1., kfillmode=jpfillnothing ,l send=llsend1, lrecv=llrecv1 )100 CALL lbc_lnk( 'bdytra', tsa, 'T', 1., kfillmode=jpfillnothing ,ldsend=llsend1, ldrecv=llrecv1 ) 101 101 END IF 102 102 ! … … 126 126 igrd = 1 ! Everything is at T-points here 127 127 IF( jpa == jp_tem ) THEN 128 CALL bdy_nmn( idx, igrd, pta, llrim0 )128 CALL bdy_nmn( idx, igrd, 1,jpi, 1,jpj, 1, pta, llrim0 ) 129 129 ELSE IF( jpa == jp_sal ) THEN 130 130 IF( .NOT. llrim0 ) RETURN -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/DIA/diadct.F90
r11365 r11380 11 11 !! 3.4 ! 09/2011 (C Bricaud) 12 12 !!---------------------------------------------------------------------- 13 !! 13 #if defined key_diadct 14 !!---------------------------------------------------------------------- 15 !! 'key_diadct' : 16 !!---------------------------------------------------------------------- 14 17 !!---------------------------------------------------------------------- 15 18 !! dia_dct : Compute the transport through a sec. … … 39 42 40 43 PUBLIC dia_dct ! routine called by step.F90 41 PUBLIC dia_dct_init ! routine called by nemogcm.F90 42 43 ! !!** namelist variables ** 44 LOGICAL, PUBLIC :: ln_diadct ! Calculate transport thru a section or not 45 INTEGER :: nn_dct ! Frequency of computation 46 INTEGER :: nn_dctwri ! Frequency of output 47 INTEGER :: nn_secdebug ! Number of the section to debug 44 PUBLIC dia_dct_init ! routine called by opa.F90 45 PUBLIC diadct_alloc ! routine called by nemo_init in nemogcm.F90 46 PRIVATE readsec 47 PRIVATE removepoints 48 PRIVATE transport 49 PRIVATE dia_dct_wri 50 51 LOGICAL, PUBLIC, PARAMETER :: lk_diadct = .TRUE. !: model-data diagnostics flag 52 53 INTEGER :: nn_dct ! Frequency of computation 54 INTEGER :: nn_dctwri ! Frequency of output 55 INTEGER :: nn_secdebug ! Number of the section to debug 48 56 49 57 INTEGER, PARAMETER :: nb_class_max = 10 … … 96 104 CONTAINS 97 105 98 INTEGER FUNCTION diadct_alloc() 99 !!---------------------------------------------------------------------- 100 !! *** FUNCTION diadct_alloc *** 101 !!---------------------------------------------------------------------- 102 103 ALLOCATE( transports_3d(nb_3d_vars,nb_sec_max,nb_point_max,jpk), & 104 & transports_2d(nb_2d_vars,nb_sec_max,nb_point_max) , STAT=diadct_alloc ) 105 106 CALL mpp_sum( 'diadct', diadct_alloc ) 107 IF( diadct_alloc /= 0 ) CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' ) 108 109 END FUNCTION diadct_alloc 106 INTEGER FUNCTION diadct_alloc() 107 !!---------------------------------------------------------------------- 108 !! *** FUNCTION diadct_alloc *** 109 !!---------------------------------------------------------------------- 110 INTEGER :: ierr(2) 111 !!---------------------------------------------------------------------- 112 113 ALLOCATE(transports_3d(nb_3d_vars,nb_sec_max,nb_point_max,jpk), STAT=ierr(1) ) 114 ALLOCATE(transports_2d(nb_2d_vars,nb_sec_max,nb_point_max) , STAT=ierr(2) ) 115 116 diadct_alloc = MAXVAL( ierr ) 117 IF( diadct_alloc /= 0 ) CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' ) 118 119 END FUNCTION diadct_alloc 120 110 121 111 122 SUBROUTINE dia_dct_init … … 119 130 INTEGER :: ios ! Local integer output status for namelist read 120 131 !! 121 NAMELIST/nam _diadct/ln_diadct, nn_dct, nn_dctwri,nn_secdebug132 NAMELIST/namdct/nn_dct,nn_dctwri,nn_secdebug 122 133 !!--------------------------------------------------------------------- 123 134 124 REWIND( numnam_ref ) ! Namelist nam _diadct in reference namelist : Diagnostic: transport through sections125 READ ( numnam_ref, nam _diadct, IOSTAT = ios, ERR = 901)126 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam _diadct in reference namelist' )127 128 REWIND( numnam_cfg ) ! Namelist nam _diadct in configuration namelist : Diagnostic: transport through sections129 READ ( numnam_cfg, nam _diadct, IOSTAT = ios, ERR = 902 )130 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam _diadct in configuration namelist' )131 IF(lwm) WRITE ( numond, nam _diadct )135 REWIND( numnam_ref ) ! Namelist namdct in reference namelist : Diagnostic: transport through sections 136 READ ( numnam_ref, namdct, IOSTAT = ios, ERR = 901) 137 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdct in reference namelist' ) 138 139 REWIND( numnam_cfg ) ! Namelist namdct in configuration namelist : Diagnostic: transport through sections 140 READ ( numnam_cfg, namdct, IOSTAT = ios, ERR = 902 ) 141 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdct in configuration namelist' ) 142 IF(lwm) WRITE ( numond, namdct ) 132 143 133 144 IF( lwp ) THEN … … 135 146 WRITE(numout,*) "diadct_init: compute transports through sections " 136 147 WRITE(numout,*) "~~~~~~~~~~~~~~~~~~~~~" 137 WRITE(numout,*) " Calculate transport thru sections: ln_diadct = ", ln_diadct 138 WRITE(numout,*) " Frequency of computation: nn_dct = ", nn_dct 139 WRITE(numout,*) " Frequency of write: nn_dctwri = ", nn_dctwri 148 WRITE(numout,*) " Frequency of computation: nn_dct = ",nn_dct 149 WRITE(numout,*) " Frequency of write: nn_dctwri = ",nn_dctwri 140 150 141 151 IF ( nn_secdebug .GE. 1 .AND. nn_secdebug .LE. nb_sec_max )THEN … … 145 155 ELSE ; WRITE(numout,*)" Wrong value for nn_secdebug : ",nn_secdebug 146 156 ENDIF 157 158 IF(nn_dct .GE. nn_dctwri .AND. MOD(nn_dct,nn_dctwri) .NE. 0) & 159 & CALL ctl_stop( 'diadct: nn_dct should be smaller and a multiple of nn_dctwri' ) 160 147 161 ENDIF 148 162 149 IF( ln_diadct ) THEN 150 ! control 151 IF(nn_dct .GE. nn_dctwri .AND. MOD(nn_dct,nn_dctwri) .NE. 0) & 152 & CALL ctl_stop( 'diadct: nn_dct should be smaller and a multiple of nn_dctwri' ) 153 154 ! allocate dia_dct arrays 155 IF( diadct_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' ) 156 157 !Read section_ijglobal.diadct 158 CALL readsec 159 160 !open output file 161 IF( lwm ) THEN 162 CALL ctl_opn( numdct_vol, 'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 163 CALL ctl_opn( numdct_heat, 'heat_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 164 CALL ctl_opn( numdct_salt, 'salt_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 165 ENDIF 166 167 ! Initialise arrays to zero 168 transports_3d(:,:,:,:)=0.0 169 transports_2d(:,:,:) =0.0 170 ! 163 !Read section_ijglobal.diadct 164 CALL readsec 165 166 !open output file 167 IF( lwm ) THEN 168 CALL ctl_opn( numdct_vol, 'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 169 CALL ctl_opn( numdct_heat, 'heat_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 170 CALL ctl_opn( numdct_salt, 'salt_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 171 171 ENDIF 172 173 ! Initialise arrays to zero 174 transports_3d(:,:,:,:)=0.0 175 transports_2d(:,:,:) =0.0 172 176 ! 173 177 END SUBROUTINE dia_dct_init … … 1235 1239 END FUNCTION interp 1236 1240 1241 #else 1242 !!---------------------------------------------------------------------- 1243 !! Default option : Dummy module 1244 !!---------------------------------------------------------------------- 1245 LOGICAL, PUBLIC, PARAMETER :: lk_diadct = .FALSE. !: diamht flag 1246 PUBLIC 1247 !! $Id$ 1248 CONTAINS 1249 1250 SUBROUTINE dia_dct_init ! Dummy routine 1251 IMPLICIT NONE 1252 WRITE(*,*) 'dia_dct_init: You should not have seen this print! error?' 1253 END SUBROUTINE dia_dct_init 1254 1255 SUBROUTINE dia_dct( kt ) ! Dummy routine 1256 IMPLICIT NONE 1257 INTEGER, INTENT( in ) :: kt ! ocean time-step index 1258 WRITE(*,*) 'dia_dct: You should not have seen this print! error?', kt 1259 END SUBROUTINE dia_dct 1260 #endif 1261 1237 1262 !!====================================================================== 1238 1263 END MODULE diadct -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/DIA/diaharm.F90
r11374 r11380 5 5 !!====================================================================== 6 6 !! History : 3.1 ! 2007 (O. Le Galloudec, J. Chanut) Original code 7 !!---------------------------------------------------------------------- 8 #if defined key_diaharm 9 !!---------------------------------------------------------------------- 10 !! 'key_diaharm' 7 11 !!---------------------------------------------------------------------- 8 12 USE oce ! ocean dynamics and tracers variables … … 22 26 IMPLICIT NONE 23 27 PRIVATE 28 29 LOGICAL, PUBLIC, PARAMETER :: lk_diaharm = .TRUE. 24 30 25 31 INTEGER, PARAMETER :: jpincomax = 2.*jpmax_harmo … … 27 33 28 34 ! !!** namelist variables ** 29 LOGICAL, PUBLIC :: ln_diaharm ! Choose tidal harmonic output or not 30 INTEGER :: nit000_han ! First time step used for harmonic analysis 31 INTEGER :: nitend_han ! Last time step used for harmonic analysis 32 INTEGER :: nstep_han ! Time step frequency for harmonic analysis 33 INTEGER :: nb_ana ! Number of harmonics to analyse 35 INTEGER :: nit000_han ! First time step used for harmonic analysis 36 INTEGER :: nitend_han ! Last time step used for harmonic analysis 37 INTEGER :: nstep_han ! Time step frequency for harmonic analysis 38 INTEGER :: nb_ana ! Number of harmonics to analyse 34 39 35 40 INTEGER , ALLOCATABLE, DIMENSION(:) :: name … … 48 53 CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: tname ! Names of tidal constituents ('M2', 'K1',...) 49 54 50 PUBLIC dia_harm ! routine called by step.F90 51 PUBLIC dia_harm_init ! routine called by nemogcm.F90 55 PUBLIC dia_harm ! routine called by step.F90 52 56 53 57 !!---------------------------------------------------------------------- … … 67 71 !! 68 72 !!-------------------------------------------------------------------- 69 INTEGER :: jh, nhan, ji73 INTEGER :: jh, nhan, jk, ji 70 74 INTEGER :: ios ! Local integer output status for namelist read 71 75 72 NAMELIST/nam_diaharm/ ln_diaharm,nit000_han, nitend_han, nstep_han, tname76 NAMELIST/nam_diaharm/ nit000_han, nitend_han, nstep_han, tname 73 77 !!---------------------------------------------------------------------- 74 78 … … 78 82 WRITE(numout,*) '~~~~~~~ ' 79 83 ENDIF 84 ! 85 IF( .NOT. ln_tide ) CALL ctl_stop( 'dia_harm_init : ln_tide must be true for harmonic analysis') 86 ! 87 CALL tide_init_Wave 80 88 ! 81 89 REWIND( numnam_ref ) ! Namelist nam_diaharm in reference namelist : Tidal harmonic analysis … … 88 96 ! 89 97 IF(lwp) THEN 90 WRITE(numout,*) 'Tidal diagnostics = ', ln_diaharm 91 WRITE(numout,*) ' First time step used for analysis: nit000_han= ', nit000_han 92 WRITE(numout,*) ' Last time step used for analysis: nitend_han= ', nitend_han 93 WRITE(numout,*) ' Time step frequency for harmonic analysis: nstep_han = ', nstep_han 98 WRITE(numout,*) 'First time step used for analysis: nit000_han= ', nit000_han 99 WRITE(numout,*) 'Last time step used for analysis: nitend_han= ', nitend_han 100 WRITE(numout,*) 'Time step frequency for harmonic analysis: nstep_han= ', nstep_han 94 101 ENDIF 95 102 96 IF( ln_diaharm .AND. .NOT.ln_tide ) CALL ctl_stop( 'dia_harm_init : ln_tide must be true for harmonic analysis') 97 98 IF( ln_diaharm ) THEN 99 100 CALL tide_init_Wave 101 ! 102 ! Basic checks on harmonic analysis time window: 103 ! ---------------------------------------------- 104 IF( nit000 > nit000_han ) CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000', & 105 & ' restart capability not implemented' ) 106 IF( nitend < nitend_han ) CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend', & 107 & 'restart capability not implemented' ) 108 109 IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 ) & 110 & CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' ) 111 ! 112 nb_ana = 0 113 DO jh=1,jpmax_harmo 114 DO ji=1,jpmax_harmo 115 IF(TRIM(tname(jh)) == Wave(ji)%cname_tide) THEN 116 nb_ana=nb_ana+1 117 ENDIF 118 END DO 119 END DO 120 ! 121 IF(lwp) THEN 122 WRITE(numout,*) ' Namelist nam_diaharm' 123 WRITE(numout,*) ' nb_ana = ', nb_ana 124 CALL flush(numout) 125 ENDIF 126 ! 127 IF (nb_ana > jpmax_harmo) THEN 128 WRITE(ctmp1,*) ' nb_ana must be lower than jpmax_harmo' 129 WRITE(ctmp2,*) ' jpmax_harmo= ', jpmax_harmo 130 CALL ctl_stop( 'dia_harm_init', ctmp1, ctmp2 ) 131 ENDIF 132 133 ALLOCATE(name (nb_ana)) 134 DO jh=1,nb_ana 135 DO ji=1,jpmax_harmo 136 IF (TRIM(tname(jh)) == Wave(ji)%cname_tide) THEN 137 name(jh) = ji 138 EXIT 139 END IF 140 END DO 141 END DO 142 143 ! Initialize frequency array: 144 ! --------------------------- 145 ALLOCATE( ana_freq(nb_ana), ut(nb_ana), vt(nb_ana), ft(nb_ana) ) 146 147 CALL tide_harmo( ana_freq, vt, ut, ft, name, nb_ana ) 148 149 IF(lwp) WRITE(numout,*) 'Analysed frequency : ',nb_ana ,'Frequency ' 150 151 DO jh = 1, nb_ana 152 IF(lwp) WRITE(numout,*) ' : ',tname(jh),' ',ana_freq(jh) 153 END DO 154 155 ! Initialize temporary arrays: 156 ! ---------------------------- 157 ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) ) 158 ana_temp(:,:,:,:) = 0._wp 159 103 ! Basic checks on harmonic analysis time window: 104 ! ---------------------------------------------- 105 IF( nit000 > nit000_han ) CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000', & 106 & ' restart capability not implemented' ) 107 IF( nitend < nitend_han ) CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend', & 108 & 'restart capability not implemented' ) 109 110 IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 ) & 111 & CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' ) 112 113 nb_ana = 0 114 DO jk=1,jpmax_harmo 115 DO ji=1,jpmax_harmo 116 IF(TRIM(tname(jk)) == Wave(ji)%cname_tide) THEN 117 nb_ana=nb_ana+1 118 ENDIF 119 END DO 120 END DO 121 ! 122 IF(lwp) THEN 123 WRITE(numout,*) ' Namelist nam_diaharm' 124 WRITE(numout,*) ' nb_ana = ', nb_ana 125 CALL flush(numout) 160 126 ENDIF 127 ! 128 IF (nb_ana > jpmax_harmo) THEN 129 WRITE(ctmp1,*) ' nb_ana must be lower than jpmax_harmo' 130 WRITE(ctmp2,*) ' jpmax_harmo= ', jpmax_harmo 131 CALL ctl_stop( 'dia_harm_init', ctmp1, ctmp2 ) 132 ENDIF 133 134 ALLOCATE(name (nb_ana)) 135 DO jk=1,nb_ana 136 DO ji=1,jpmax_harmo 137 IF (TRIM(tname(jk)) == Wave(ji)%cname_tide) THEN 138 name(jk) = ji 139 EXIT 140 END IF 141 END DO 142 END DO 143 144 ! Initialize frequency array: 145 ! --------------------------- 146 ALLOCATE( ana_freq(nb_ana), ut(nb_ana), vt(nb_ana), ft(nb_ana) ) 147 148 CALL tide_harmo( ana_freq, vt, ut, ft, name, nb_ana ) 149 150 IF(lwp) WRITE(numout,*) 'Analysed frequency : ',nb_ana ,'Frequency ' 151 152 DO jh = 1, nb_ana 153 IF(lwp) WRITE(numout,*) ' : ',tname(jh),' ',ana_freq(jh) 154 END DO 155 156 ! Initialize temporary arrays: 157 ! ---------------------------- 158 ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) ) 159 ana_temp(:,:,:,:) = 0._wp 161 160 162 161 END SUBROUTINE dia_harm_init … … 178 177 !!-------------------------------------------------------------------- 179 178 IF( ln_timing ) CALL timing_start('dia_harm') 179 ! 180 IF( kt == nit000 ) CALL dia_harm_init 180 181 ! 181 182 IF( kt >= nit000_han .AND. kt <= nitend_han .AND. MOD(kt,nstep_han) == 0 ) THEN … … 421 422 INTEGER, INTENT(in) :: init 422 423 ! 423 INTEGER :: ji_sd, jj_sd, ji1_sd, ji2_sd, j h1_sd, jh2_sd424 INTEGER :: ji_sd, jj_sd, ji1_sd, ji2_sd, jk1_sd, jk2_sd 424 425 REAL(wp) :: zval1, zval2, zx1 425 426 REAL(wp), DIMENSION(jpincomax) :: ztmpx, zcol1, zcol2 … … 433 434 ztmp3(:,:) = 0._wp 434 435 ! 435 DO j h1_sd = 1, nsparse436 DO j h2_sd = 1, nsparse437 nisparse(j h2_sd) = nisparse(jh2_sd)438 njsparse(j h2_sd) = njsparse(jh2_sd)439 IF( nisparse(j h2_sd) == nisparse(jh1_sd) ) THEN440 ztmp3(njsparse(j h1_sd),njsparse(jh2_sd)) = ztmp3(njsparse(jh1_sd),njsparse(jh2_sd)) &441 & + valuesparse(j h1_sd)*valuesparse(jh2_sd)436 DO jk1_sd = 1, nsparse 437 DO jk2_sd = 1, nsparse 438 nisparse(jk2_sd) = nisparse(jk2_sd) 439 njsparse(jk2_sd) = njsparse(jk2_sd) 440 IF( nisparse(jk2_sd) == nisparse(jk1_sd) ) THEN 441 ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) = ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) & 442 & + valuesparse(jk1_sd)*valuesparse(jk2_sd) 442 443 ENDIF 443 444 END DO … … 514 515 END SUBROUTINE SUR_DETERMINE 515 516 517 #else 518 !!---------------------------------------------------------------------- 519 !! Default case : Empty module 520 !!---------------------------------------------------------------------- 521 LOGICAL, PUBLIC, PARAMETER :: lk_diaharm = .FALSE. 522 CONTAINS 523 SUBROUTINE dia_harm ( kt ) ! Empty routine 524 INTEGER, INTENT( IN ) :: kt 525 WRITE(*,*) 'dia_harm: you should not have seen this print' 526 END SUBROUTINE dia_harm 527 #endif 528 516 529 !!====================================================================== 517 530 END MODULE diaharm -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/DYN/dynspg_ts.F90
r11372 r11380 64 64 USE diatmb ! Top,middle,bottom output 65 65 66 USE iom ! to remove67 66 68 67 IMPLICIT NONE … … 78 77 REAL(wp),SAVE :: rdtbt ! Barotropic time step 79 78 ! 80 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: wgtbtp1, wgtbtp2 ! 1st & 2nd weights used in time filtering of barotropic fields 81 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zwz ! ff_f/h at F points 82 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftnw, ftne ! triad of coriolis parameter 83 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftsw, ftse ! (only used with een vorticity scheme) 79 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: wgtbtp1, wgtbtp2 ! 1st & 2nd weights used in time filtering of barotropic fields 80 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zwz ! ff_f/h at F points 81 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftnw, ftne ! triad of coriolis parameter 82 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftsw, ftse ! (only used with een vorticity scheme) 83 84 !! Arrays at barotropic time step: ! befbefore! before ! now ! after ! 85 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubb_e , ub_e , un_e , ua_e !: u-external velocity 86 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vbb_e , vb_e , vn_e , va_e !: v-external velocity 87 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshbb_e, sshb_e, sshn_e, ssha_e !: external ssh 88 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_e !: external u-depth 89 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_e !: external v-depth 90 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hur_e !: inverse of u-depth 91 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hvr_e !: inverse of v-depth 92 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub2_b , vb2_b !: Half step fluxes (ln_bt_fw=T) 93 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_bf , vn_bf !: Asselin filtered half step fluxes (ln_bt_fw=T) 94 95 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_0_xtd , hu_0_xtd , hv_0_xtd 96 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_n_xtd , hv_n_xtd 97 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_e1e2t_xtd, r1_e1e2u_xtd, r1_e1e2v_xtd 98 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: e1e2t_xtd 99 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: e2u_xtd , e1v_xtd 100 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_e1u_xtd, r1_e2v_xtd 101 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask_xtd, ssumask_xtd, ssvmask_xtd 102 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ff_t_xtd ! used in ENT scheme 103 104 #if defined key_agrif 105 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub2_i_b, vb2_i_b !: Half step time integrated fluxes 106 #endif 84 107 85 108 REAL(wp) :: r1_12 = 1._wp / 12._wp ! local ratios … … 101 124 !! *** routine dyn_spg_ts_alloc *** 102 125 !!---------------------------------------------------------------------- 103 INTEGER :: ierr(3) 126 INTEGER :: ierr(6) 127 INTEGER :: idbi, idei, idbj, idej ! lower/upper bounds of extended arrays 104 128 !!---------------------------------------------------------------------- 105 129 ierr(:) = 0 106 ! 107 ALLOCATE( wgtbtp1(3*nn_baro), wgtbtp2(3*nn_baro), zwz(jpi,jpj), STAT=ierr(1) ) 108 IF( ln_dynvor_een .OR. ln_dynvor_eeT ) & 109 & ALLOCATE( ftnw(jpi,jpj) , ftne(jpi,jpj) , ftsw(jpi,jpj) , ftse(jpi,jpj), STAT=ierr(2) ) 130 idbi = 1 - nn_hlts ; idbj = 1 - nn_hlts 131 idei = jpi + nn_hlts ; idej = jpj + nn_hlts 132 ! 133 ALLOCATE( wgtbtp1(3*nn_baro), wgtbtp2(3*nn_baro), zwz(idbi:idei,idbj:idej), STAT=ierr(1) ) 134 IF( ln_dynvor_een .OR. ln_dynvor_eeT ) THEN 135 ALLOCATE( ftnw(idbi:idei,idbj:idej) , ftne(idbi:idei,idbj:idej) , ftsw(idbi:idei,idbj:idej) , ftse(idbi:idei,idbj:idej) & 136 & , STAT=ierr(2) ) 137 ELSEIF( ln_dynvor_enT ) THEN 138 ALLOCATE( ff_t_xtd(idbi:idei,idbj:idej), STAT=ierr(2) ) 139 END IF 110 140 ! 111 141 ALLOCATE( un_adv(jpi,jpj), vn_adv(jpi,jpj) , STAT=ierr(3) ) 142 ALLOCATE( ssha_e(idbi:idei,idbj:idej), sshn_e(idbi:idei,idbj:idej), sshb_e(idbi:idei,idbj:idej), sshbb_e(idbi:idei,idbj:idej) & 143 & , ua_e(idbi:idei,idbj:idej), un_e(idbi:idei,idbj:idej), ub_e(idbi:idei,idbj:idej), ubb_e(idbi:idei,idbj:idej) & 144 & , va_e(idbi:idei,idbj:idej), vn_e(idbi:idei,idbj:idej), vb_e(idbi:idei,idbj:idej), vbb_e(idbi:idei,idbj:idej) & 145 & , hu_e(idbi:idei,idbj:idej), hur_e(idbi:idei,idbj:idej), hv_e(idbi:idei,idbj:idej), hvr_e(idbi:idei,idbj:idej) & 146 & , STAT=ierr(4) ) 147 ! 148 ALLOCATE( ub2_b(jpi,jpj), vb2_b(jpi,jpj), un_bf(jpi,jpj), vn_bf(jpi,jpj) , STAT=ierr(5) ) 149 150 #if defined key_agrif 151 ALLOCATE( ub2_i_b(jpi,jpj), vb2_i_b(jpi,jpj) , STAT=ierr(5) ) 152 #endif 153 ALLOCATE( ht_0_xtd (idbi:idei,idbj:idej), hu_0_xtd (idbi:idei,idbj:idej), hv_0_xtd (idbi:idei,idbj:idej) & 154 & , r1_e1e2t_xtd(idbi:idei,idbj:idej), r1_e1e2u_xtd(idbi:idei,idbj:idej), r1_e1e2v_xtd(idbi:idei,idbj:idej) & 155 & , ssmask_xtd (idbi:idei,idbj:idej), ssumask_xtd (idbi:idei,idbj:idej), ssvmask_xtd (idbi:idei,idbj:idej) & 156 & , e1e2t_xtd (idbi:idei,idbj:idej), e2u_xtd (idbi:idei,idbj:idej), e1v_xtd (idbi:idei,idbj:idej) & 157 & , r1_e1u_xtd (idbi:idei,idbj:idej), r1_e2v_xtd (idbi:idei,idbj:idej) & 158 & , STAT=ierr(6) ) 112 159 ! 113 160 dyn_spg_ts_alloc = MAXVAL( ierr(:) ) … … 146 193 INTEGER, INTENT(in) :: kt ! ocean time-step index 147 194 ! 148 INTEGER :: ji, jj, jk, j n! dummy loop indices195 INTEGER :: ji, jj, jk, jm ! dummy loop indices 149 196 LOGICAL :: ll_fw_start ! =T : forward integration 150 197 LOGICAL :: ll_init ! =T : special startup of 2d equations … … 155 202 REAL(wp) :: zhu_bck, zhv_bck, zhdiv ! - - 156 203 REAL(wp) :: zun_save, zvn_save ! - - 157 REAL(wp), DIMENSION(jpi,jpj) :: zu_trd, zu_frc, zu_spg, zssh_frc 158 REAL(wp), DIMENSION(jpi,jpj) :: zv_trd, zv_frc, zv_spg 159 REAL(wp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhtp2_e 160 REAL(wp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zsshp2_e 161 REAL(wp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v ! top/bottom stress at u- & v-points 162 REAL(wp), DIMENSION(jpi,jpj) :: zhU, zhV ! fluxes 204 ! 205 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zu_trd, zssh_frc 206 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zv_trd 207 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zhU , zhV 208 ! 209 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: hu_n_xtd, hv_n_xtd 210 ! 211 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zu_spg , zv_spg 212 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zu_frc , zv_frc 213 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zsshu_a, zhup2_e, zhtp2_e 214 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zsshv_a, zhvp2_e, zsshp2_e 215 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zCdU_u , zCdU_v ! top/bottom stress at u- & v-points 216 163 217 ! 164 218 REAL(wp) :: zwdramp ! local scalar - only used if ln_wd_dl = .True. … … 170 224 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztwdmask, zuwdmask, zvwdmask ! ROMS wetting and drying masks at t,u,v points 171 225 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zuwdav2, zvwdav2 ! averages over the sub-steps of zuwdmask and zvwdmask 172 !!---------------------------------------------------------------------- 173 ! 226 227 228 INTEGER :: idbi, idei, idbj, idej ! lower/upper bounds of extended arrays 229 INTEGER :: ixtd ! number of halos over which the solution is currently correct 230 INTEGER :: ibi, iei, ibj, iej ! lower and upper bounds over which the solution is currently correct 231 !!---------------------------------------------------------------------- 232 ! 233 234 174 235 IF( ln_wd_il ) ALLOCATE( zcpx(jpi,jpj), zcpy(jpi,jpj) ) 175 236 ! !* Allocate temporary arrays 176 IF( ln_wd_dl ) ALLOCATE( ztwdmask(jpi,jpj), zuwdmask(jpi,jpj), zvwdmask(jpi,jpj), zuwdav2(jpi,jpj), zvwdav2(jpi,jpj)) 237 IF( ln_wd_dl ) ALLOCATE( ztwdmask(jpi,jpj), zuwdmask(jpi,jpj), zvwdmask(jpi,jpj), zuwdav2(jpi,jpj), zvwdav2(jpi,jpj) ) 238 239 idbi = 1 - nn_hlts ; idbj = 1 - nn_hlts 240 idei = jpi + nn_hlts ; idej = jpj + nn_hlts 241 ! ! allocate local arrays 242 ALLOCATE( zu_spg (idbi:idei,idbj:idej), zv_spg (idbi:idei,idbj:idej) & 243 & , zsshu_a (idbi:idei,idbj:idej), zsshv_a (idbi:idei,idbj:idej) & 244 & , zhup2_e (idbi:idei,idbj:idej), zhvp2_e (idbi:idei,idbj:idej) & 245 & , zCdU_u (idbi:idei,idbj:idej), zCdU_v (idbi:idei,idbj:idej) & 246 & , zhtp2_e (idbi:idei,idbj:idej), zsshp2_e(idbi:idei,idbj:idej) & 247 & , zu_trd (idbi:idei,idbj:idej), zu_frc (idbi:idei,idbj:idej) & 248 & , zv_trd (idbi:idei,idbj:idej), zv_frc (idbi:idei,idbj:idej) & 249 & , zhU (idbi:idei,idbj:idej), zhV (idbi:idei,idbj:idej) & 250 & , zssh_frc(idbi:idei,idbj:idej) ) 251 ! ! allocate redundant arrays 252 ALLOCATE( hu_n_xtd(idbi:idei,idbj:idej), hv_n_xtd(idbi:idei,idbj:idej) ) 177 253 ! 178 254 zmdi=1.e+20 ! missing data indicator for masking … … 227 303 ! != zu_frc = 1/H e3*d/dt(Ua) =! (Vertical mean of Ua, the 3D trends) 228 304 ! ! --------------------------- ! 229 zu_frc( :,:) = SUM( e3u_n(:,:,:) * ua(:,:,:) * umask(:,:,:) , DIM=3 ) * r1_hu_n(:,:)230 zv_frc( :,:) = SUM( e3v_n(:,:,:) * va(:,:,:) * vmask(:,:,:) , DIM=3 ) * r1_hv_n(:,:)305 zu_frc(1:jpi,1:jpj) = SUM( e3u_n(:,:,:) * ua(:,:,:) * umask(:,:,:) , DIM=3 ) * r1_hu_n(:,:) 306 zv_frc(1:jpi,1:jpj) = SUM( e3v_n(:,:,:) * va(:,:,:) * vmask(:,:,:) , DIM=3 ) * r1_hv_n(:,:) 231 307 ! 232 308 ! 233 309 ! != Ua => baroclinic trend =! (remove its vertical mean) 234 310 DO jk = 1, jpkm1 ! ------------------------ ! 235 ua(:,:,jk) = ( ua(:,:,jk) - zu_frc( :,:) ) * umask(:,:,jk)236 va(:,:,jk) = ( va(:,:,jk) - zv_frc( :,:) ) * vmask(:,:,jk)311 ua(:,:,jk) = ( ua(:,:,jk) - zu_frc(1:jpi,1:jpj) ) * umask(:,:,jk) 312 va(:,:,jk) = ( va(:,:,jk) - zv_frc(1:jpi,1:jpj) ) * vmask(:,:,jk) 237 313 END DO 238 314 … … 243 319 ! ! ------------------------------------------------- ! 244 320 ! 245 IF( kt == nit000 .OR. .NOT. ln_linssh ) CALL dyn_cor_2D_init ! Set zwz, the barotropic Coriolis force coefficient 246 ! ! recompute zwz = f/depth at every time step for (.NOT.ln_linssh) as the water colomn height changes 321 ! Set zwz, the barotropic Coriolis force coefficient 322 ! recompute zwz = f/depth at every time step for (.NOT.ln_linssh) as the water colomn height changes 323 IF( kt == nit000 .OR. .NOT. ln_linssh ) CALL dyn_cor_2d_init( idbi, idei, idbj, idej ) 247 324 ! 248 325 ! !* 2D Coriolis trends 249 zhU(:,:) = un_b(:,:) * hu_n(:,:) * e2u(:,:) ! now fluxes 250 zhV(:,:) = vn_b(:,:) * hv_n(:,:) * e1v(:,:) ! NB: FULL domain : put a value in last row and column 251 ! 252 CALL dyn_cor_2d( hu_n, hv_n, un_b, vn_b, zhU, zhV, & ! <<== in 253 & zu_trd, zv_trd ) ! ==>> out 326 zhU(1:jpi,1:jpj) = un_b(:,:) * hu_n(:,:) * e2u(:,:) ! now fluxes 327 zhV(1:jpi,1:jpj) = vn_b(:,:) * hv_n(:,:) * e1v(:,:) ! NB: FULL domain : put a value in last row and column 328 ! 329 ! ! ht_n, hu_n, hv_n, un_b, vn_b are of size 1:jpi 1:jpj 330 ! ! zhU, zhV, zu_trd, zv_trd are of size idbi:idei idbj:idej 331 CALL dyn_cor_2d( ht_n, hu_n, hv_n, un_b, vn_b, zhU, zhV, 1 , jpi , 1 , jpj & ! <<== in 332 & , zu_trd, zv_trd, idbi, idei, idbj, idej ) ! ==>> out 254 333 ! 255 334 IF( .NOT.ln_linssh ) THEN !* surface pressure gradient (variable volume only) … … 285 364 ! != Add bottom stress contribution from baroclinic velocities =! 286 365 ! ! ----------------------------------------------------------- ! 287 CALL dyn_drg_init( zu_frc, zv_frc, zCdU_u, zCdU_v ) ! also provide the barotropic drag coefficients 366 CALL drg_init( idbi, idei, idbj, idej, zu_frc, zv_frc, zCdU_u, zCdU_v ) ! also provide the barotropic drag coefficients 367 ! ! arrays are computed on inner domain 288 368 ! 289 369 ! != Add atmospheric pressure forcing =! … … 335 415 ! ! --------------------------------------------------- ! 336 416 IF (ln_bt_fw) THEN ! FORWARD integration: use kt+1/2 fluxes (NOW+1/2) 337 zssh_frc( :,:) = r1_rau0 * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) )417 zssh_frc(1:jpi,1:jpj) = r1_rau0 * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) 338 418 ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 fluxes (NOW) 339 419 zztmp = r1_rau0 * r1_2 340 zssh_frc( :,:) = zztmp * ( emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:) + fwfisf(:,:) + fwfisf_b(:,:) )420 zssh_frc(1:jpi,1:jpj) = zztmp * ( emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:) + fwfisf(:,:) + fwfisf_b(:,:) ) 341 421 ENDIF 342 422 ! != Add Stokes drift divergence =! (if exist) 343 423 IF( ln_sdw ) THEN ! ----------------------------- ! 344 zssh_frc( :,:) = zssh_frc(:,:) + div_sd(:,:)424 zssh_frc(1:jpi,1:jpj) = zssh_frc(1:jpi,1:jpj) + div_sd(:,:) 345 425 ENDIF 346 426 ! … … 349 429 ! ! ------------------------------------ ! 350 430 IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN 351 zssh_frc( :,:) = zssh_frc(:,:) - ssh_iau(:,:)431 zssh_frc(1:jpi,1:jpj) = zssh_frc(1:jpi,1:jpj) - ssh_iau(:,:) 352 432 ENDIF 353 433 #endif … … 357 437 IF( .NOT.Agrif_Root() ) CALL agrif_dta_ts( kt ) 358 438 #endif 439 440 359 441 ! 360 442 ! ----------------------------------------------------------------------- … … 366 448 ! ! ==================== ! 367 449 ! Initialize barotropic variables: 368 IF( ll_init ) THEN450 IF( ll_init ) THEN 369 451 sshbb_e(:,:) = 0._wp 370 452 ubb_e (:,:) = 0._wp … … 376 458 ! 377 459 IF( ln_linssh ) THEN ! mid-step ocean depth is fixed (hup2_e=hu_n=hu_0) 378 zh up2_e(:,:) = hu_n(:,:)379 zh vp2_e(:,:) = hv_n(:,:)380 zh tp2_e(:,:) = ht_n(:,:)460 zhtp2_e(1:jpi,1:jpj) = ht_n(1:jpi,1:jpj) 461 zhup2_e(1:jpi,1:jpj) = hu_n(1:jpi,1:jpj) 462 zhvp2_e(1:jpi,1:jpj) = hv_n(1:jpi,1:jpj) 381 463 ENDIF 382 464 ! 383 465 IF (ln_bt_fw) THEN ! FORWARD integration: start from NOW fields 384 sshn_e( :,:) = sshn(:,:)385 un_e ( :,:) = un_b(:,:)386 vn_e ( :,:) = vn_b(:,:)387 ! 388 hu_e ( :,:) = hu_n(:,:)389 hv_e ( :,:) = hv_n(:,:)390 hur_e ( :,:) = r1_hu_n(:,:)391 hvr_e ( :,:) = r1_hv_n(:,:)466 sshn_e(1:jpi,1:jpj) = sshn(1:jpi,1:jpj) 467 un_e (1:jpi,1:jpj) = un_b(1:jpi,1:jpj) 468 vn_e (1:jpi,1:jpj) = vn_b(1:jpi,1:jpj) 469 ! 470 hu_e (1:jpi,1:jpj) = hu_n(1:jpi,1:jpj) 471 hv_e (1:jpi,1:jpj) = hv_n(1:jpi,1:jpj) 472 hur_e (1:jpi,1:jpj) = r1_hu_n(1:jpi,1:jpj) 473 hvr_e (1:jpi,1:jpj) = r1_hv_n(1:jpi,1:jpj) 392 474 ELSE ! CENTRED integration: start from BEFORE fields 393 sshn_e(:,:) = sshb(:,:) 394 un_e (:,:) = ub_b(:,:) 395 vn_e (:,:) = vb_b(:,:) 396 ! 397 hu_e (:,:) = hu_b(:,:) 398 hv_e (:,:) = hv_b(:,:) 399 hur_e (:,:) = r1_hu_b(:,:) 400 hvr_e (:,:) = r1_hv_b(:,:) 401 ENDIF 475 sshn_e(1:jpi,1:jpj) = sshb(1:jpi,1:jpj) 476 un_e (1:jpi,1:jpj) = ub_b(1:jpi,1:jpj) 477 vn_e (1:jpi,1:jpj) = vb_b(1:jpi,1:jpj) 478 ! 479 hu_e (1:jpi,1:jpj) = hu_b(1:jpi,1:jpj) 480 hv_e (1:jpi,1:jpj) = hv_b(1:jpi,1:jpj) 481 hur_e (1:jpi,1:jpj) = r1_hu_b(1:jpi,1:jpj) 482 hvr_e (1:jpi,1:jpj) = r1_hv_b(1:jpi,1:jpj) 483 ENDIF 484 ! 485 hu_n_xtd(1:jpi,1:jpj) = hu_n(1:jpi,1:jpj) 486 hv_n_xtd(1:jpi,1:jpj) = hv_n(1:jpi,1:jpj) 487 ! 488 ! 489 ! ! Extend arrays 490 ! ! -------------- 491 ! 492 IF( ln_linssh ) THEN 493 CALL lbc_lnk_multi( 'dynspg_ts', hu_n_xtd, 'U', -1._wp, hv_n_xtd, 'V', -1._wp & 494 & , zCdU_u , 'U', -1._wp, zCdU_v , 'V', -1._wp & 495 & , zu_frc , 'U', -1._wp, zv_frc , 'V', -1._wp & 496 & , un_e , 'U', -1._wp, vn_e , 'V', -1._wp & 497 & , hu_e , 'U', -1._wp, hv_e , 'V', -1._wp & 498 & , hur_e , 'U', -1._wp, hvr_e , 'V', -1._wp & 499 & , zhtp2_e , 'T', 1._wp, zhup2_e, 'U', -1._wp, zhvp2_e , 'V', -1._wp & 500 & , zssh_frc, 'T', 1._wp, sshn_e , 'T', 1._wp, khlcom = nn_hls+nn_hlts ) 501 ELSE 502 CALL lbc_lnk_multi( 'dynspg_ts', hu_n_xtd, 'U', -1._wp, hv_n_xtd, 'V', -1._wp & 503 & , zCdU_u , 'U', -1._wp, zCdU_v , 'V', -1._wp & 504 & , zu_frc , 'U', -1._wp, zv_frc , 'V', -1._wp & 505 & , un_e , 'U', -1._wp, vn_e , 'V', -1._wp & 506 & , hu_e , 'U', -1._wp, hv_e , 'V', -1._wp & 507 & , hur_e , 'U', -1._wp, hvr_e , 'V', -1._wp & 508 & , zssh_frc, 'T', 1._wp, sshn_e , 'T', 1._wp, khlcom = nn_hls+nn_hlts ) 509 END IF 402 510 ! 403 511 ! Initialize sums: … … 413 521 zuwdav2 (:,:) = 0._wp 414 522 zvwdav2 (:,:) = 0._wp 415 END IF 416 523 END IF 524 525 ixtd = nn_hls + nn_hlts ! solution is now correct over the whole domain (interior + regular halos + time splitting halos) 526 ibi = 1 - nn_hlts ; ibj = 1 - nn_hlts 527 iei = jpi + nn_hlts ; iej = jpj + nn_hlts 417 528 ! ! ==================== ! 418 DO j n= 1, icycle ! sub-time-step loop !529 DO jm = 1, icycle ! sub-time-step loop ! 419 530 ! ! ==================== ! 420 531 ! 421 l_full_nf_update = j n == icycle ! false: disable full North fold update (performances) for jn= 1 to icycle-1532 l_full_nf_update = jm == icycle ! false: disable full North fold update (performances) for jm = 1 to icycle-1 422 533 ! 423 534 ! !== Update the forcing ==! (BDY and tides) 424 535 ! 425 IF( ln_bdy .AND. ln_tide ) CALL bdy_dta_tides( kt, kit=j n, kt_offset= noffset+1 )426 IF( ln_tide_pot .AND. ln_tide ) CALL upd_tide ( kt, kit=j n, kt_offset= noffset )427 ! 428 ! !== extrapolation at mid-step ==! (j n+1/2)536 IF( ln_bdy .AND. ln_tide ) CALL bdy_dta_tides( kt, kit=jm, kt_offset= noffset+1 ) 537 IF( ln_tide_pot .AND. ln_tide ) CALL upd_tide ( kt, kit=jm, kt_offset= noffset ) 538 ! 539 ! !== extrapolation at mid-step ==! (jm+1/2) 429 540 ! 430 541 ! !* Set extrapolation coefficients for predictor step: 431 IF ((jn<3).AND.ll_init) THEN ! Forward542 IF( (jm<3) .AND. ll_init ) THEN ! Forward 432 543 za1 = 1._wp 433 544 za2 = 0._wp … … 439 550 ENDIF 440 551 ! 441 ! !* Extrapolate barotropic velocities at mid-step (j n+1/2)552 ! !* Extrapolate barotropic velocities at mid-step (jm+1/2) 442 553 !-- m+1/2 m m-1 m-2 --! 443 554 !-- u = (3/2+beta) u -(1/2+2beta) u + beta u --! 444 555 !-------------------------------------------------------------------------! 445 ua_e( :,:) = za1 * un_e(:,:) + za2 * ub_e(:,:) + za3 * ubb_e(:,:)446 va_e( :,:) = za1 * vn_e(:,:) + za2 * vb_e(:,:) + za3 * vbb_e(:,:)556 ua_e(ibi:iei,ibj:iej) = za1 * un_e(ibi:iei,ibj:iej) + za2 * ub_e(ibi:iei,ibj:iej) + za3 * ubb_e(ibi:iei,ibj:iej) 557 va_e(ibi:iei,ibj:iej) = za1 * vn_e(ibi:iei,ibj:iej) + za2 * vb_e(ibi:iei,ibj:iej) + za3 * vbb_e(ibi:iei,ibj:iej) 447 558 448 559 IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) 449 560 ! ! ------------------ 450 ! Extrapolate Sea Level at step jit+0.5:561 ! !* Extrapolate Sea Level at mid-step (jm+1/2) 451 562 !-- m+1/2 m m-1 m-2 --! 452 563 !-- ssh = (3/2+beta) ssh -(1/2+2beta) ssh + beta ssh --! 453 564 !--------------------------------------------------------------------------------! 454 zsshp2_e( :,:) = za1 * sshn_e(:,:) + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:)455 565 zsshp2_e(ibi:iei,ibj:iej) = za1 * sshn_e (ibi:iei,ibj:iej) + za2 * sshb_e(ibi:iei,ibj:iej) & 566 & + za3 * sshbb_e(ibi:iei,ibj:iej) 456 567 ! set wetting & drying mask at tracer points for this barotropic mid-step 457 568 IF( ln_wd_dl ) CALL wad_tmsk( zsshp2_e, ztwdmask ) 458 569 ! 459 570 ! ! ocean t-depth at mid-step 460 zhtp2_e( :,:) = ht_0(:,:) + zsshp2_e(:,:)571 zhtp2_e(ibi:iei,ibj:iej) = ht_0_xtd(ibi:iei,ibj:iej) + zsshp2_e(ibi:iei,ibj:iej) 461 572 ! 462 ! ! ocean u- and v-depth at mid-step (separate DO-loops remove the need of a lbc_lnk) 463 DO jj = 1, jpj 464 DO ji = 1, jpim1 ! not jpi-column 465 zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj) & 466 & * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 467 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 468 END DO 469 END DO 470 DO jj = 1, jpjm1 ! not jpj-row 471 DO ji = 1, jpi 472 zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj) & 473 & * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & 474 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) 573 ! ! ocean u- and v-depth at mid-step 574 DO jj = ibj, iej-1 ! not last column, not last row 575 DO ji = ibi, iei-1 576 zhup2_e(ji,jj) = hu_0_xtd(ji,jj) + r1_2 * r1_e1e2u_xtd(ji,jj) & 577 & * ( e1e2t_xtd(ji ,jj) * zsshp2_e(ji ,jj) & 578 & + e1e2t_xtd(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask_xtd(ji,jj) 579 zhvp2_e(ji,jj) = hv_0_xtd(ji,jj) + r1_2 * r1_e1e2v_xtd(ji,jj) & 580 & * ( e1e2t_xtd(ji,jj ) * zsshp2_e(ji,jj ) & 581 & + e1e2t_xtd(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask_xtd(ji,jj) 475 582 END DO 476 583 END DO … … 478 585 ENDIF 479 586 ! 480 ! !== after SSH ==! (j n+1)587 ! !== after SSH ==! (jm+1) 481 588 ! 482 589 ! ! update (ua_e,va_e) to enforce volume conservation at open boundaries 483 590 ! ! values of zhup2_e and zhvp2_e on the halo are not needed in bdy_vol2d 484 IF( ln_bdy .AND. ln_vol ) CALL bdy_vol2d( kt, j n, ua_e, va_e, zhup2_e, zhvp2_e )591 IF( ln_bdy .AND. ln_vol ) CALL bdy_vol2d( kt, jm, ua_e, va_e, zhup2_e, zhvp2_e ) 485 592 ! 486 593 ! ! resulting flux at mid-step (not over the full domain) 487 zhU( 1:jpim1,1:jpj ) = e2u(1:jpim1,1:jpj ) * ua_e(1:jpim1,1:jpj ) * zhup2_e(1:jpim1,1:jpj ) ! not jpi-column488 zhV( 1:jpi ,1:jpjm1) = e1v(1:jpi ,1:jpjm1) * va_e(1:jpi ,1:jpjm1) * zhvp2_e(1:jpi ,1:jpjm1) ! not jpj-row594 zhU(ibi:iei-1,ibj:iej-1) = e2u_xtd(ibi:iei-1,ibj:iej-1) * ua_e(ibi:iei-1,ibj:iej-1) * zhup2_e(ibi:iei-1,ibj:iej-1) 595 zhV(ibi:iei-1,ibj:iej-1) = e1v_xtd(ibi:iei-1,ibj:iej-1) * va_e(ibi:iei-1,ibj:iej-1) * zhvp2_e(ibi:iei-1,ibj:iej-1) 489 596 ! 490 597 #if defined key_agrif … … 524 631 ! 525 632 ENDIF 526 !527 !528 ! Compute Sea Level at step jit+1529 !-- m+1 m m+1/2 --!530 !-- ssh = ssh - delta_t' * [ frc + div( flux ) ] --!531 !-------------------------------------------------------------------------!532 DO jj = 2, jpjm1 ! INNER domain533 DO ji = 2, jpim1534 zhdiv = ( zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1) ) * r1_e1e2t(ji,jj)535 ssha_e(ji,jj) = ( sshn_e(ji,jj) - rdtbt * ( zssh_frc(ji,jj) + zhdiv ) ) * ssmask(ji,jj)536 END DO537 END DO538 !539 CALL lbc_lnk_multi( 'dynspg_ts', ssha_e, 'T', 1._wp, zhU, 'U', -1._wp, zhV, 'V', -1._wp )540 !541 ! ! Sum over sub-time-steps to compute advective velocities542 za2 = wgtbtp2(jn) ! zhU, zhV hold fluxes extrapolated at jn+0.5543 un_adv(:,:) = un_adv(:,:) + za2 * zhU(:,:) * r1_e2u(:,:)544 vn_adv(:,:) = vn_adv(:,:) + za2 * zhV(:,:) * r1_e1v(:,:)545 633 ! sum over sub-time-steps to decide which baroclinic velocities to set to zero (zuwdav2 is only used when ln_wd_dl_bc=True) 546 634 IF ( ln_wd_dl_bc ) THEN … … 548 636 zvwdav2(1:jpi ,1:jpjm1) = zvwdav2(1:jpi ,1:jpjm1) + za2 * zvwdmask(1:jpi ,1:jpjm1) ! not jpj-row 549 637 END IF 638 ! 639 ! Sum over sub-time-steps to compute advective velocities (only correct on interior domain) 640 za2 = wgtbtp2(jm) ! zhU, zhV hold fluxes extrapolated at jm+1/2 641 un_adv(1:jpi,1:jpj) = un_adv(1:jpi,1:jpj) + za2 * zhU(1:jpi,1:jpj) * r1_e2u(1:jpi,1:jpj) 642 vn_adv(1:jpi,1:jpj) = vn_adv(1:jpi,1:jpj) + za2 * zhV(1:jpi,1:jpj) * r1_e1v(1:jpi,1:jpj) 643 ! 644 ! 645 ! Compute Sea Level at step jit+1 646 !-- m+1 m m+1/2 --! 647 !-- ssh = ssh - delta_t' * [ frc + div( flux ) ] --! 648 !-------------------------------------------------------------------------! 649 ! correct domain reduction 650 ixtd = ixtd - 1 651 ibi = ibi + 1 ; ibj = ibj + 1 652 iei = iei - 1 ; iej = iej - 1 653 DO jj = ibj, iej 654 DO ji = ibi, iei 655 zhdiv = ( zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1) ) * r1_e1e2t_xtd(ji,jj) 656 ssha_e(ji,jj) = ( sshn_e(ji,jj) - rdtbt * ( zssh_frc(ji,jj) + zhdiv ) ) * ssmask_xtd(ji,jj) 657 END DO 658 END DO 659 ! 660 IF( nn_hlts == 0 ) THEN 661 CALL lbc_lnk_multi( 'dynspg_ts', ssha_e, 'T', 1._wp, zhU, 'U', -1._wp, zhV, 'V', -1._wp ) 662 ixtd = nn_hls + nn_hlts ! solution is now correct over the whole domain 663 ibi = 1 - nn_hlts ; ibj = 1 - nn_hlts 664 iei = jpi + nn_hlts ; iej = jpj + nn_hlts 665 END IF 666 550 667 ! 551 668 ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T) 552 IF( ln_bdy ) CALL bdy_ssh( ssha_e ) 669 IF( ln_bdy ) THEN 670 CALL swap_bdyptr ! bdy treatment is now done on extended domain 671 CALL bdy_ssh( ssha_e, idbi, idei, idbj, idej, ldcomall=.true., pmask=ssmask_xtd, khlcom=nn_hls+nn_hlts ) 672 CALL swap_bdyptr ! bdy treatment is now done on regular domain 673 END IF 674 553 675 #if defined key_agrif 554 IF( .NOT.Agrif_Root() ) CALL agrif_ssh_ts( j n)676 IF( .NOT.Agrif_Root() ) CALL agrif_ssh_ts( jm ) 555 677 #endif 556 !557 ! Sea Surface Height at u-,v-points (vvl case only)558 IF( .NOT.ln_linssh ) THEN559 DO jj = 2, jpjm1 ! INNER domain, will be extended to whole domain later560 DO ji = 2, jpim1 ! NO Vector Opt.561 zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) &562 & * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) &563 & + e1e2t(ji+1,jj ) * ssha_e(ji+1,jj ) )564 zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj) &565 & * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) &566 & + e1e2t(ji ,jj+1) * ssha_e(ji ,jj+1) )567 END DO568 END DO569 ENDIF570 678 ! 571 679 ! Half-step back interpolation of SSH for surface pressure computation at step jit+1/2 572 !-- m+1/2 m+1 m m-1 m-2 --! 573 !-- ssh' = za0 * ssh + za1 * ssh + za2 * ssh + za3 * ssh --! 574 !------------------------------------------------------------------------------------------! 575 CALL ts_bck_interp( jn, ll_init, za0, za1, za2, za3 ) ! coeficients of the interpolation 576 zsshp2_e(:,:) = za0 * ssha_e(:,:) + za1 * sshn_e (:,:) & 577 & + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) 680 !-- m+1/2 m+1 m m-1 m-2 --! 681 !-- ssh' = za0 * ssh + za1 * ssh + za2 * ssh + za3 * ssh --! 682 !-----------------------------------------------------------------------------------------! 683 CALL ts_bck_interp( jm, ll_init, za0, za1, za2, za3 ) ! coeficients of the interpolation 684 zsshp2_e(ibi:iei,ibj:iej) = za0 * ssha_e(ibi:iei,ibj:iej) + za1 * sshn_e (ibi:iei,ibj:iej) & 685 & + za2 * sshb_e(ibi:iei,ibj:iej) + za3 * sshbb_e(ibi:iei,ibj:iej) 686 ! 687 ! 688 ! Sea Surface Height at u-,v-points (vvl case only) 689 IF( .NOT.ln_linssh ) THEN 690 DO jj = ibj, iej-1 691 DO ji = ibi, iei-1 692 zsshu_a(ji,jj) = r1_2 * ssumask_xtd(ji,jj) * r1_e1e2u_xtd(ji,jj) & 693 & * ( e1e2t_xtd(ji ,jj ) * ssha_e(ji ,jj ) & 694 & + e1e2t_xtd(ji+1,jj ) * ssha_e(ji+1,jj ) ) 695 zsshv_a(ji,jj) = r1_2 * ssvmask_xtd(ji,jj) * r1_e1e2v_xtd(ji,jj) & 696 & * ( e1e2t_xtd(ji ,jj ) * ssha_e(ji ,jj ) & 697 & + e1e2t_xtd(ji ,jj+1) * ssha_e(ji ,jj+1) ) 698 END DO 699 END DO 700 ENDIF 578 701 ! 579 702 ! ! Surface pressure gradient 580 703 zldg = ( 1._wp - rn_scal_load ) * grav ! local factor 581 DO jj = 2, jpjm1582 DO ji = 2, jpim1583 zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u (ji,jj)584 zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v (ji,jj)704 DO jj = ibj, iej-1 705 DO ji = ibi, iei-1 706 zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u_xtd(ji,jj) 707 zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v_xtd(ji,jj) 585 708 END DO 586 709 END DO … … 592 715 ! 593 716 ! Add Coriolis trend: 594 ! zwz array belowor triads normally depend on sea level with ln_linssh=F and should be updated717 ! - zwz array used in dyn_cor_2d or triads normally depend on sea level with ln_linssh=F and should be updated 595 718 ! at each time step. We however keep them constant here for optimization. 596 ! Recall that zhU and zhV hold fluxes at jn+0.5 (extrapolated not backward interpolated) 597 CALL dyn_cor_2d( zhup2_e, zhvp2_e, ua_e, va_e, zhU, zhV, zu_trd, zv_trd ) 719 ! - Recall that zhU and zhV hold fluxes at jm+1/2 (extrapolated not backward interpolated) 720 ! - zu_trd_xtd and zv_trd_xtd are only correct on (ibi+1:iei-1,ibj+1:iej-1) 721 ! NOTE : input flux arguments have to be correct (ibi:iei,ibj:iej) -> a lbc call between input arguments computation 722 ! and this call without fluxes (typically after ssh at step m+1 computation) would not yield correct results 723 CALL dyn_cor_2d( zhtp2_e, zhup2_e, zhvp2_e, ua_e, va_e, zhU, zhV , idbi, idei, idbj, idej & 724 & , zu_trd, zv_trd , idbi, idei, idbj, idej ) 598 725 ! 599 726 ! Add tidal astronomical forcing if defined 727 ! pot_astro is correct on 1:jpi,1:jpj 600 728 IF ( ln_tide .AND. ln_tide_pot ) THEN 601 729 DO jj = 2, jpjm1 … … 610 738 !jth do implicitly instead 611 739 IF ( .NOT. ll_wd ) THEN ! Revert to explicit for bit comparison tests in non wad runs 612 DO jj = 2, jpjm1613 DO ji = fs_2, fs_jpim1 ! vector opt.740 DO jj = ibj, iej 741 DO ji = ibi, iei 614 742 zu_trd(ji,jj) = zu_trd(ji,jj) + zCdU_u(ji,jj) * un_e(ji,jj) * hur_e(ji,jj) 615 743 zv_trd(ji,jj) = zv_trd(ji,jj) + zCdU_v(ji,jj) * vn_e(ji,jj) * hvr_e(ji,jj) … … 624 752 !-- u = u + delta_t' * \ (1-r)*g * grad_x( ssh') - f * k vect u + frc / --! 625 753 !-- --! 626 !-- FLUX FORM--!754 !-- FLUX FORM --! 627 755 !-- m+1 __1__ / m m / m+1/2 m+1/2 m+1/2 n \ \ --! 628 756 !-- u = m+1 | h * u + delta_t' * \ h * (1-r)*g * grad_x( ssh') - h * f * k vect u + h * frc / | --! 629 757 !-- h \ / --! 630 758 !------------------------------------------------------------------------------------------------------------------------! 759 ! correct domain reduction 760 ixtd = ixtd - 1 761 ibi = ibi + 1 ; ibj = ibj + 1 762 iei = iei - 1 ; iej = iej - 1 763 ! 631 764 IF( ln_dynadv_vec .OR. ln_linssh ) THEN !* Vector form 632 DO jj = 2, jpjm1633 DO ji = fs_2, fs_jpim1 ! vector opt.765 DO jj = ibj, iej 766 DO ji = ibi, iei 634 767 ua_e(ji,jj) = ( un_e(ji,jj) & 635 768 & + rdtbt * ( zu_spg(ji,jj) & 636 769 & + zu_trd(ji,jj) & 637 770 & + zu_frc(ji,jj) ) & 638 & ) * ssumask (ji,jj)771 & ) * ssumask_xtd(ji,jj) 639 772 640 773 va_e(ji,jj) = ( vn_e(ji,jj) & … … 642 775 & + zv_trd(ji,jj) & 643 776 & + zv_frc(ji,jj) ) & 644 & ) * ssvmask (ji,jj)777 & ) * ssvmask_xtd(ji,jj) 645 778 END DO 646 779 END DO 647 780 ! 648 781 ELSE !* Flux form 649 DO jj = 2, jpjm1 650 DO ji = 2, jpim1 651 ! ! hu_e, hv_e hold depth at jn, zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 652 ! ! backward interpolated depth used in spg terms at jn+1/2 653 zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * ( e1e2t(ji ,jj) * zsshp2_e(ji ,jj) & 654 & + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask(ji,jj) 655 zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * ( e1e2t(ji,jj ) * zsshp2_e(ji,jj ) & 656 & + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask(ji,jj) 657 ! ! inverse depth at jn+1 658 z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) 659 z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask(ji,jj) ) 782 DO jj = ibj, iej 783 DO ji = ibi, iei 784 ! ! hu_e, hv_e hold depth at jm, zhup2_e, zhvp2_e hold extrapolated depth at jm+1/2 785 ! ! backward interpolated depth used in spg terms at jm+1/2 786 zhu_bck = hu_0_xtd(ji,jj) + r1_2*r1_e1e2u_xtd(ji,jj) * & 787 & ( e1e2t_xtd(ji ,jj) * zsshp2_e(ji ,jj) & 788 & + e1e2t_xtd(ji+1,jj) * zsshp2_e(ji+1,jj) ) * ssumask_xtd(ji,jj) 789 zhv_bck = hv_0_xtd(ji,jj) + r1_2*r1_e1e2v_xtd(ji,jj) * & 790 & ( e1e2t_xtd(ji,jj ) * zsshp2_e(ji,jj ) & 791 & + e1e2t_xtd(ji,jj+1) * zsshp2_e(ji,jj+1) ) * ssvmask_xtd(ji,jj) 792 ! ! inverse depth at jm+1 793 z1_hu = ssumask_xtd(ji,jj) / ( hu_0_xtd(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask_xtd(ji,jj) ) 794 z1_hv = ssvmask_xtd(ji,jj) / ( hv_0_xtd(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask_xtd(ji,jj) ) 660 795 ! 661 ua_e(ji,jj) = ( hu_e (ji,jj) * un_e (ji,jj)&662 & + rdtbt * ( zhu_bck * zu_spg(ji,jj) & !663 & + zhup2_e(ji,jj) * zu_trd 664 & + hu_n (ji,jj) * zu_frc(ji,jj) ) ) * z1_hu796 ua_e(ji,jj) = ( hu_e (ji,jj) * un_e (ji,jj) & 797 & + rdtbt * ( zhu_bck * zu_spg(ji,jj) & ! 798 & + zhup2_e(ji,jj) * zu_trd(ji,jj) & ! 799 & + hu_n_xtd (ji,jj) * zu_frc(ji,jj) ) ) * z1_hu 665 800 ! 666 va_e(ji,jj) = ( hv_e (ji,jj) * vn_e (ji,jj)&667 & + rdtbt * ( zhv_bck * zv_spg(ji,jj) & !668 & + zhvp2_e(ji,jj) * zv_trd 669 & + hv_n (ji,jj) * zv_frc(ji,jj) ) ) * z1_hv801 va_e(ji,jj) = ( hv_e (ji,jj) * vn_e (ji,jj) & 802 & + rdtbt * ( zhv_bck * zv_spg(ji,jj) & ! 803 & + zhvp2_e(ji,jj) * zv_trd(ji,jj) & ! 804 & + hv_n_xtd (ji,jj) * zv_frc(ji,jj) ) ) * z1_hv 670 805 END DO 671 806 END DO … … 681 816 ENDIF 682 817 683 IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) 684 hu_e (2:jpim1,2:jpjm1) = hu_0(2:jpim1,2:jpjm1) + zsshu_a(2:jpim1,2:jpjm1) 685 hur_e(2:jpim1,2:jpjm1) = ssumask(2:jpim1,2:jpjm1) / ( hu_e(2:jpim1,2:jpjm1) + 1._wp - ssumask(2:jpim1,2:jpjm1) ) 686 hv_e (2:jpim1,2:jpjm1) = hv_0(2:jpim1,2:jpjm1) + zsshv_a(2:jpim1,2:jpjm1) 687 hvr_e(2:jpim1,2:jpjm1) = ssvmask(2:jpim1,2:jpjm1) / ( hv_e(2:jpim1,2:jpjm1) + 1._wp - ssvmask(2:jpim1,2:jpjm1) ) 688 CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp & 689 & , hu_e , 'U', -1._wp, hv_e , 'V', -1._wp & 690 & , hur_e, 'U', -1._wp, hvr_e, 'V', -1._wp ) 691 ELSE 692 CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp ) 693 ENDIF 694 ! 695 ! 696 ! ! open boundaries 697 IF( ln_bdy ) CALL bdy_dyn2d( jn, ua_e, va_e, un_e, vn_e, hur_e, hvr_e, ssha_e ) 818 IF( .NOT.ln_linssh ) THEN !* Update ocean depth (variable volume case only) and inverse depth 819 hu_e (ibi:iei,ibj:iej) = hu_0_xtd(ibi:iei,ibj:iej) + zsshu_a(ibi:iei,ibj:iej) 820 hv_e (ibi:iei,ibj:iej) = hv_0_xtd(ibi:iei,ibj:iej) + zsshv_a(ibi:iei,ibj:iej) 821 hur_e(ibi:iei,ibj:iej) = ssumask_xtd(ibi:iei,ibj:iej) / ( hu_e(ibi:iei,ibj:iej) + 1._wp - ssumask_xtd(ibi:iei,ibj:iej) ) 822 hvr_e(ibi:iei,ibj:iej) = ssvmask_xtd(ibi:iei,ibj:iej) / ( hv_e(ibi:iei,ibj:iej) + 1._wp - ssvmask_xtd(ibi:iei,ibj:iej) ) 823 ENDIF 824 825 IF( ixtd == 0 ) THEN 826 IF( .NOT. ln_linssh ) THEN 827 CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp & ! after 828 & , un_e , 'U', -1._wp, vn_e , 'V', -1._wp & ! now 829 & , ub_e , 'U', -1._wp, vb_e , 'V', -1._wp & ! before 830 & , ubb_e , 'U', -1._wp, vbb_e , 'V', -1._wp & ! before before 831 & , ssha_e, 'T', 1._wp, sshn_e , 'T', 1._wp & ! after, now 832 & , sshb_e, 'T', 1._wp, sshbb_e, 'T', 1._wp & ! before, before before 833 & , hu_e , 'U', -1._wp, hv_e , 'V', -1._wp & 834 & , hur_e , 'U', -1._wp, hvr_e , 'V', -1._wp & 835 & , khlcom = nn_hls+nn_hlts ) 836 ELSE 837 CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp & ! after 838 & , un_e , 'U', -1._wp, vn_e , 'V', -1._wp & ! now 839 & , ub_e , 'U', -1._wp, vb_e , 'V', -1._wp & ! before 840 & , ubb_e , 'U', -1._wp, vbb_e , 'V', -1._wp & ! before before 841 & , ssha_e, 'T', 1._wp, sshn_e , 'T', 1._wp & ! after, now 842 & , sshb_e, 'T', 1._wp, sshbb_e, 'T', 1._wp & ! before, before before 843 & , khlcom = nn_hls+nn_hlts ) 844 END IF 845 ixtd = nn_hls + nn_hlts ! solution is now correct over the whole domain 846 ibi = 1 - nn_hlts ; ibj = 1 - nn_hlts 847 iei = jpi + nn_hlts ; iej = jpj + nn_hlts 848 END IF 849 ! 850 ! 851 ! ! open boundaries 852 ! ! bdy treatment is here done on regular domain (nn_hlts forced to 1 if ln_bdy or ln_tides) 853 IF( ln_bdy ) CALL bdy_dyn2d( jm, ua_e, va_e, un_e, vn_e, hur_e, hvr_e, ssha_e, idbi, idei, idbj, idej & 854 & , ldcomall=.true., pumask=ssumask_xtd, pvmask=ssvmask_xtd, khlcom=nn_hls+nn_hlts ) 698 855 #if defined key_agrif 699 IF( .NOT.Agrif_Root() ) CALL agrif_dyn_ts( j n) ! Agrif856 IF( .NOT.Agrif_Root() ) CALL agrif_dyn_ts( jm ) ! Agrif 700 857 #endif 701 858 ! !* Swap … … 715 872 ! !* Sum over whole bt loop 716 873 ! ! ---------------------- 717 za1 = wgtbtp1(j n)874 za1 = wgtbtp1(jm) 718 875 IF( ln_dynadv_vec .OR. ln_linssh ) THEN ! Sum velocities 719 ua_b (:,:) = ua_b (:,:) + za1 * ua_e (:,:)720 va_b (:,:) = va_b (:,:) + za1 * va_e (:,:)876 ua_b(1:jpi,1:jpj) = ua_b(1:jpi,1:jpj) + za1 * ua_e(1:jpi,1:jpj) 877 va_b(1:jpi,1:jpj) = va_b(1:jpi,1:jpj) + za1 * va_e(1:jpi,1:jpj) 721 878 ELSE ! Sum transports 722 879 IF ( .NOT.ln_wd_dl ) THEN 723 ua_b (:,:) = ua_b (:,:) + za1 * ua_e (:,:) * hu_e (:,:)724 va_b (:,:) = va_b (:,:) + za1 * va_e (:,:) * hv_e (:,:)880 ua_b(1:jpi,1:jpj) = ua_b(1:jpi,1:jpj) + za1 * ua_e(1:jpi,1:jpj) * hu_e(1:jpi,1:jpj) 881 va_b(1:jpi,1:jpj) = va_b(1:jpi,1:jpj) + za1 * va_e(1:jpi,1:jpj) * hv_e(1:jpi,1:jpj) 725 882 ELSE 726 ua_b (:,:) = ua_b (:,:) + za1 * ua_e (:,:) * hu_e (:,:) * zuwdmask(:,:)727 va_b (:,:) = va_b (:,:) + za1 * va_e (:,:) * hv_e (:,:) * zvwdmask(:,:)883 ua_b(1:jpi,1:jpj) = ua_b(1:jpi,1:jpj) + za1 * ua_e(1:jpi,1:jpj) * hu_e(1:jpi,1:jpj) * zuwdmask(1:jpi,1:jpj) 884 va_b(1:jpi,1:jpj) = va_b(1:jpi,1:jpj) + za1 * va_e(1:jpi,1:jpj) * hv_e(1:jpi,1:jpj) * zvwdmask(1:jpi,1:jpj) 728 885 END IF 729 886 ENDIF 730 887 ! ! Sum sea level 731 ssha( :,:) = ssha(:,:) + za1 * ssha_e(:,:)888 ssha(1:jpi,1:jpj) = ssha(1:jpi,1:jpj) + za1 * ssha_e(1:jpi,1:jpj) 732 889 733 890 ! ! ==================== ! … … 737 894 ! Phase 3. update the general trend with the barotropic trend 738 895 ! ----------------------------------------------------------------------------- 896 ! Correction on regular halos 897 CALL lbc_lnk_multi( 'dynspg_ts', un_adv, 'U', -1._wp, vn_adv, 'V', -1._wp & 898 & , ua_b , 'U', -1._wp, va_b , 'V', -1._wp & 899 & , ssha , 'T', -1._wp ) 739 900 ! 740 901 ! Set advection velocity correction: … … 783 944 & + e1e2t(ji,jj+1) * ssha(ji,jj+1) ) 784 945 END DO 785 END DO 786 CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions946 END DO ! Boundary conditions 947 CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp, khlcom=nn_hls+nn_hlts ) ! change array used? 787 948 ! 788 949 DO jk=1,jpkm1 … … 791 952 END DO 792 953 ! Save barotropic velocities not transport: 793 ua_b(:,:) = ua_b(:,:) / ( hu_0(:,:) + zsshu_a( :,:) + 1._wp - ssumask(:,:) )794 va_b(:,:) = va_b(:,:) / ( hv_0(:,:) + zsshv_a( :,:) + 1._wp - ssvmask(:,:) )954 ua_b(:,:) = ua_b(:,:) / ( hu_0(:,:) + zsshu_a(1:jpi,1:jpj) + 1._wp - ssumask(:,:) ) 955 va_b(:,:) = va_b(:,:) / ( hv_0(:,:) + zsshv_a(1:jpi,1:jpj) + 1._wp - ssvmask(:,:) ) 795 956 ENDIF 796 957 … … 841 1002 ENDIF 842 1003 ! 1004 1005 ! deallocate temporary arrays 1006 DEALLOCATE( zu_trd , zv_trd & 1007 & , zu_frc , zv_frc & 1008 & , zu_spg , zv_spg & 1009 & , zsshu_a , zsshv_a & 1010 & , zhup2_e , zhvp2_e & 1011 & , zCdU_u , zCdU_v & 1012 & , zhU , zhV & 1013 & , zssh_frc, zsshp2_e & 1014 & , zhtp2_e & 1015 & , hu_n_xtd, hv_n_xtd ) 1016 ! 843 1017 END SUBROUTINE dyn_spg_ts 844 1018 … … 850 1024 !! ** Purpose : Set time-splitting weights for temporal averaging (or not) 851 1025 !!---------------------------------------------------------------------- 852 LOGICAL, INTENT(in ) :: ll_av ! temporal averaging=.true.853 LOGICAL, INTENT(in ) :: ll_fw ! forward time splitting =.true.854 INTEGER, INTENT(inout) :: jpit! cycle length1026 LOGICAL, INTENT(in ) :: ll_av ! temporal averaging=.true. 1027 LOGICAL, INTENT(in ) :: ll_fw ! forward time splitting =.true. 1028 INTEGER, INTENT(inout) :: jpit ! cycle length 855 1029 REAL(wp), DIMENSION(3*nn_baro), INTENT(inout) :: zwgt1, & ! Primary weights 856 1030 zwgt2 ! Secondary weights 857 1031 858 INTEGER :: jic, j n, ji ! temporary integers1032 INTEGER :: jic, jm, ji ! temporary integers 859 1033 REAL(wp) :: za1, za2 860 1034 !!---------------------------------------------------------------------- … … 880 1054 881 1055 CASE( 1 ) ! Boxcar, width = nn_baro 882 DO j n= 1, 3*nn_baro883 za1 = ABS(float(j n-jic))/float(nn_baro)1056 DO jm = 1, 3*nn_baro 1057 za1 = ABS(float(jm-jic))/float(nn_baro) 884 1058 IF (za1 < 0.5_wp) THEN 885 zwgt1(j n) = 1._wp886 jpit = j n1059 zwgt1(jm) = 1._wp 1060 jpit = jm 887 1061 ENDIF 888 1062 ENDDO 889 1063 890 1064 CASE( 2 ) ! Boxcar, width = 2 * nn_baro 891 DO j n= 1, 3*nn_baro892 za1 = ABS(float(j n-jic))/float(nn_baro)1065 DO jm = 1, 3*nn_baro 1066 za1 = ABS(float(jm-jic))/float(nn_baro) 893 1067 IF (za1 < 1._wp) THEN 894 zwgt1(j n) = 1._wp895 jpit = j n1068 zwgt1(jm) = 1._wp 1069 jpit = jm 896 1070 ENDIF 897 1071 ENDDO … … 905 1079 906 1080 ! Set secondary weights 907 DO j n= 1, jpit908 DO ji = j n, jpit909 zwgt2(j n) = zwgt2(jn) + zwgt1(ji)1081 DO jm = 1, jpit 1082 DO ji = jm, jpit 1083 zwgt2(jm) = zwgt2(jm) + zwgt1(ji) 910 1084 END DO 911 1085 END DO … … 914 1088 za1 = 1._wp / SUM(zwgt1(1:jpit)) 915 1089 za2 = 1._wp / SUM(zwgt2(1:jpit)) 916 DO j n= 1, jpit917 zwgt1(j n) = zwgt1(jn) * za1918 zwgt2(j n) = zwgt2(jn) * za21090 DO jm = 1, jpit 1091 zwgt1(jm) = zwgt1(jm) * za1 1092 zwgt2(jm) = zwgt2(jm) * za2 919 1093 END DO 920 1094 ! … … 1111 1285 ENDIF 1112 1286 ! 1287 ! initialize extended scale factors 1288 ht_0_xtd (1:jpi,1:jpj) = ht_0 (1:jpi,1:jpj) 1289 hu_0_xtd (1:jpi,1:jpj) = hu_0 (1:jpi,1:jpj) 1290 hv_0_xtd (1:jpi,1:jpj) = hv_0 (1:jpi,1:jpj) 1291 r1_e1e2t_xtd(1:jpi,1:jpj) = r1_e1e2t(1:jpi,1:jpj) 1292 r1_e1e2u_xtd(1:jpi,1:jpj) = r1_e1e2u(1:jpi,1:jpj) 1293 r1_e1e2v_xtd(1:jpi,1:jpj) = r1_e1e2v(1:jpi,1:jpj) 1294 e1e2t_xtd (1:jpi,1:jpj) = e1e2t (1:jpi,1:jpj) 1295 ssmask_xtd (1:jpi,1:jpj) = ssmask (1:jpi,1:jpj) 1296 ssumask_xtd (1:jpi,1:jpj) = ssumask (1:jpi,1:jpj) 1297 ssvmask_xtd (1:jpi,1:jpj) = ssvmask (1:jpi,1:jpj) 1298 e2u_xtd (1:jpi,1:jpj) = e2u (1:jpi,1:jpj) 1299 e1v_xtd (1:jpi,1:jpj) = e1v (1:jpi,1:jpj) 1300 r1_e1u_xtd (1:jpi,1:jpj) = r1_e1u (1:jpi,1:jpj) 1301 r1_e2v_xtd (1:jpi,1:jpj) = r1_e2v (1:jpi,1:jpj) 1302 ! 1303 CALL lbc_lnk_multi( 'dynspg_ts', ht_0_xtd , 'T', 1._wp, hu_0_xtd , 'U', -1._wp, hv_0_xtd , 'V', -1._wp & 1304 & , r1_e1e2t_xtd, 'T', 1._wp, r1_e1e2u_xtd, 'U', -1._wp, r1_e1e2v_xtd, 'V', -1._wp & 1305 & , ssmask_xtd , 'T', 1._wp, ssumask_xtd , 'U', -1._wp, ssvmask_xtd , 'V', -1._wp & 1306 & , e1e2t_xtd , 'T', 1._wp, e2u_xtd , 'U', -1._wp, e1v_xtd , 'V', -1._wp & 1307 & , r1_e1u_xtd , 'U', -1._wp, r1_e2v_xtd , 'V', -1._wp & 1308 & , khlcom = nn_hls+nn_hlts ) 1309 IF( ln_dynvor_enT ) THEN 1310 ff_t_xtd (1:jpi,1:jpj) = ff_t (1:jpi,1:jpj) 1311 CALL lbc_lnk_multi( 'dynspg_ts', ff_t_xtd , 'F', -1._wp, khlcom = nn_hls+nn_hlts ) 1312 END IF 1313 1314 ! 1113 1315 END SUBROUTINE dyn_spg_ts_init 1114 1316 1115 1317 1116 SUBROUTINE dyn_cor_2d_init 1318 SUBROUTINE dyn_cor_2d_init( kdbi, kdei, kdbj, kdej ) 1117 1319 !!--------------------------------------------------------------------- 1118 1320 !! *** ROUTINE dyn_cor_2d_init *** … … 1128 1330 !! Compute zwz = f / ( height of the water colomn ) 1129 1331 !!---------------------------------------------------------------------- 1332 INTEGER , INTENT(in ) :: kdbi, kdei, kdbj, kdej 1130 1333 INTEGER :: ji ,jj, jk ! dummy loop indices 1131 1334 REAL(wp) :: z1_ht … … 1137 1340 SELECT CASE( nn_een_e3f ) !* ff_f/e3 at F-point 1138 1341 CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) 1139 DO jj = 1, jpj m11140 DO ji = 1, jpi m11141 zwz(ji,jj) = ( ht_n(ji ,jj+1) + ht_n(ji+1,jj+1) + 1142 & 1342 DO jj = 1, jpj-1 1343 DO ji = 1, jpi-1 1344 zwz(ji,jj) = ( ht_n(ji ,jj+1) + ht_n(ji+1,jj+1) + & 1345 & ht_n(ji ,jj ) + ht_n(ji+1,jj ) ) * 0.25_wp 1143 1346 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 1144 1347 END DO 1145 1348 END DO 1146 1349 CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) 1147 DO jj = 1, jpj m11148 DO ji = 1, jpi m11149 zwz(ji,jj) = ( ht_n (ji ,jj+1) + ht_n (ji+1,jj+1) &1350 DO jj = 1, jpj-1 1351 DO ji = 1, jpi-1 1352 zwz(ji,jj) = ( ht_n (ji ,jj+1) + ht_n (ji+1,jj+1) & 1150 1353 & + ht_n (ji ,jj ) + ht_n (ji+1,jj ) ) & 1151 1354 & / ( MAX( 1._wp, ssmask(ji ,jj+1) + ssmask(ji+1,jj+1) & … … 1155 1358 END DO 1156 1359 END SELECT 1157 CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) 1158 ! 1159 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 1160 DO jj = 2, jpj 1161 DO ji = 2, jpi 1360 ! 1361 DO jj = 2, jpj-1 1362 DO ji = 2, jpi-1 1162 1363 ftne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1) 1163 1364 ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj ) … … 1166 1367 END DO 1167 1368 END DO 1369 CALL lbc_lnk_multi( 'dynspg_ts', ftne, 'F', 1._wp, ftnw, 'F', 1._wp & 1370 & , ftse, 'F', 1._wp, ftsw, 'F', 1._wp, khlcom = nn_hls+nn_hlts ) 1168 1371 ! 1169 1372 CASE( np_EET ) != EEN scheme using e3t (energy conserving scheme) 1170 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp1171 1373 DO jj = 2, jpj 1172 1374 DO ji = 2, jpi … … 1178 1380 END DO 1179 1381 END DO 1382 CALL lbc_lnk_multi( 'dynspg_ts', ftne, 'F', 1._wp, ftnw, 'F', 1._wp & 1383 & , ftse, 'F', 1._wp, ftsw, 'F', 1._wp, khlcom = nn_hls+nn_hlts ) 1180 1384 ! 1181 1385 CASE( np_ENE, np_ENS , np_MIX ) != all other schemes (ENE, ENS, MIX) except ENT ! … … 1223 1427 END DO 1224 1428 END DO 1225 CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp ) 1226 ! JC: TBC. hf should be greater than 0 1227 DO jj = 1, jpj 1228 DO ji = 1, jpi 1429 ! JC: TBC. hf should be greater than 0 1430 DO jj = 2, jpjm1 1431 DO ji = 2, jpim1 1229 1432 IF( zhf(ji,jj) /= 0._wp ) zwz(ji,jj) = 1._wp / zhf(ji,jj) 1230 1433 END DO 1231 1434 END DO 1232 zwz(:,:) = ff_f(:,:) * zwz(:,:) 1435 zwz(2:jpim1,2:jpjm1) = ff_f(2:jpim1,2:jpjm1) * zwz(2:jpim1,2:jpjm1) 1436 CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp, khlcom = nn_hls+nn_hlts ) 1233 1437 END SELECT 1234 1438 … … 1237 1441 1238 1442 1239 SUBROUTINE dyn_cor_2d( hu_n, hv_n, un_b, vn_b, zhU, zhV, zu_trd, zv_trd ) 1443 SUBROUTINE dyn_cor_2d( phgtt, phgtu, phgtv, pun, pvn, phU, phV, kdbi , kdei , kdbj , kdej , pu_trd, pv_trd & 1444 & , kdbi2, kdei2, kdbj2, kdej2 ) 1240 1445 !!--------------------------------------------------------------------- 1241 1446 !! *** ROUTINE dyn_cor_2d *** 1242 1447 !! 1243 1448 !! ** Purpose : Compute u and v coriolis trends 1244 !!---------------------------------------------------------------------- 1245 INTEGER :: ji ,jj ! dummy loop indices 1246 REAL(wp) :: zx1, zx2, zy1, zy2, z1_hu, z1_hv ! - - 1247 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: hu_n, hv_n, un_b, vn_b, zhU, zhV 1248 REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: zu_trd, zv_trd 1449 !! 1450 !! kdXX2 are useful in the initialisation where some arrays are not over the whole domain 1451 !! and some are 1452 !!---------------------------------------------------------------------- 1453 REAL(wp), DIMENSION(kdbi :kdei ,kdbj :kdej ), INTENT(in ) :: phgtt, phgtu, phgtv, pun, pvn ! height, speed 1454 INTEGER , INTENT(in ) :: kdbi , kdei , kdbj , kdej ! arrays size 1455 REAL(wp), DIMENSION(kdbi2:kdei2,kdbj2:kdej2), INTENT(in ) :: phU, phV ! flux 1456 REAL(wp), DIMENSION(kdbi2:kdei2,kdbj2:kdej2), INTENT( out) :: pu_trd, pv_trd 1457 INTEGER , INTENT(in ) :: kdbi2, kdei2, kdbj2, kdej2 ! arrays size 1458 INTEGER :: ji, jj ! dummy loop indices 1459 REAL(wp) :: zx1, zx2, zy1, zy2, z1_hu, z1_hv ! local integer 1249 1460 !!---------------------------------------------------------------------- 1250 1461 SELECT CASE( nvor_scheme ) 1251 1462 CASE( np_ENT ) ! enstrophy conserving scheme (f-point) 1252 DO jj = 2, jpjm11253 DO ji = 2, jpim11254 z1_hu = ssumask (ji,jj) / ( hu_n(ji,jj) + 1._wp - ssumask(ji,jj) )1255 z1_hv = ssvmask (ji,jj) / ( hv_n(ji,jj) + 1._wp - ssvmask(ji,jj) )1256 zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu&1257 & * ( e1e2t (ji+1,jj)*ht_n(ji+1,jj)*ff_t(ji+1,jj) * ( vn_b(ji+1,jj) + vn_b(ji+1,jj-1) ) &1258 & + e1e2t (ji ,jj)*ht_n(ji ,jj)*ff_t(ji ,jj) * ( vn_b(ji ,jj) + vn_b(ji ,jj-1) ) )1463 DO jj = kdbj+1, kdej-1 1464 DO ji = kdbi+1, kdei-1 1465 z1_hu = ssumask_xtd(ji,jj) / ( phgtu(ji,jj) + 1._wp - ssumask_xtd(ji,jj) ) 1466 z1_hv = ssvmask_xtd(ji,jj) / ( phgtv(ji,jj) + 1._wp - ssvmask_xtd(ji,jj) ) 1467 pu_trd(ji,jj) = + r1_4 * r1_e1e2u_xtd(ji,jj) * z1_hu & 1468 & * ( e1e2t_xtd(ji+1,jj)*phgtt(ji+1,jj)*ff_t_xtd(ji+1,jj) * ( pvn(ji+1,jj) + pvn(ji+1,jj-1) ) & 1469 & + e1e2t_xtd(ji ,jj)*phgtt(ji ,jj)*ff_t_xtd(ji ,jj) * ( pvn(ji ,jj) + pvn(ji ,jj-1) ) ) 1259 1470 ! 1260 zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv&1261 & * ( e1e2t (ji,jj+1)*ht_n(ji,jj+1)*ff_t(ji,jj+1) * ( un_b(ji,jj+1) + un_b(ji-1,jj+1) ) &1262 & + e1e2t (ji,jj )*ht_n(ji,jj )*ff_t(ji,jj ) * ( un_b(ji,jj ) + un_b(ji-1,jj ) ) )1471 pv_trd(ji,jj) = - r1_4 * r1_e1e2v_xtd(ji,jj) * z1_hv & 1472 & * ( e1e2t_xtd(ji,jj+1)*phgtt(ji,jj+1)*ff_t_xtd(ji,jj+1) * ( pun(ji,jj+1) + pun(ji-1,jj+1) ) & 1473 & + e1e2t_xtd(ji,jj )*phgtt(ji,jj )*ff_t_xtd(ji,jj ) * ( pun(ji,jj ) + pun(ji-1,jj ) ) ) 1263 1474 END DO 1264 END DO 1475 END DO 1265 1476 ! 1266 1477 CASE( np_ENE , np_MIX ) ! energy conserving scheme (t-point) ENE or MIX 1267 DO jj = 2, jpjm11268 DO ji = fs_2, fs_jpim1 ! vector opt.1269 zy1 = ( zhV(ji,jj-1) + zhV(ji+1,jj-1) ) * r1_e1u(ji,jj)1270 zy2 = ( zhV(ji,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj)1271 zx1 = ( zhU(ji-1,jj) + zhU(ji-1,jj+1) ) * r1_e2v(ji,jj)1272 zx2 = ( zhU(ji ,jj) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj)1478 DO jj = kdbj+1, kdej-1 1479 DO ji = kdbi+1, kdei-1 1480 zy1 = ( phV(ji,jj-1) + phV(ji+1,jj-1) ) * r1_e1u_xtd(ji,jj) 1481 zy2 = ( phV(ji,jj ) + phV(ji+1,jj ) ) * r1_e1u_xtd(ji,jj) 1482 zx1 = ( phU(ji-1,jj) + phU(ji-1,jj+1) ) * r1_e2v_xtd(ji,jj) 1483 zx2 = ( phU(ji ,jj) + phU(ji ,jj+1) ) * r1_e2v_xtd(ji,jj) 1273 1484 ! energy conserving formulation for planetary vorticity term 1274 zu_trd(ji,jj) = r1_4 * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 )1275 zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 )1485 pu_trd(ji,jj) = r1_4 * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 1486 pv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 1276 1487 END DO 1277 1488 END DO 1278 1489 ! 1279 1490 CASE( np_ENS ) ! enstrophy conserving scheme (f-point) 1280 DO jj = 2, jpjm11281 DO ji = fs_2, fs_jpim1 ! vector opt.1282 zy1 = r1_8 * ( zhV(ji ,jj-1) + zhV(ji+1,jj-1) &1283 & + zhV(ji ,jj ) + zhV(ji+1,jj ) ) * r1_e1u(ji,jj)1284 zx1 = - r1_8 * ( zhU(ji-1,jj ) + zhU(ji-1,jj+1) &1285 & + zhU(ji ,jj ) + zhU(ji ,jj+1) ) * r1_e2v(ji,jj)1286 zu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) )1287 zv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) )1288 END DO 1289 END DO 1290 ! 1291 CASE( np_EET , np_EEN ) ! energy & enstrophy scheme (using e3t or e3f) 1292 DO jj = 2, jpjm11293 DO ji = fs_2, fs_jpim1 ! vector opt.1294 zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * ( ftne(ji,jj ) * zhV(ji ,jj ) &1295 & + ftnw(ji+1,jj) * zhV(ji+1,jj ) &1296 & + ftse(ji,jj ) * zhV(ji ,jj-1) &1297 & + ftsw(ji+1,jj) * zhV(ji+1,jj-1) )1298 zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * ( ftsw(ji,jj+1) * zhU(ji-1,jj+1) &1299 & + ftse(ji,jj+1) * zhU(ji ,jj+1) &1300 & + ftnw(ji,jj ) * zhU(ji-1,jj ) &1301 & + ftne(ji,jj ) * zhU(ji ,jj ) )1491 DO jj = kdbj+1, kdej-1 1492 DO ji = kdbi+1, kdei-1 1493 zy1 = r1_8 * ( phV(ji ,jj-1) + phV(ji+1,jj-1) & 1494 & + phV(ji ,jj ) + phV(ji+1,jj ) ) * r1_e1u_xtd(ji,jj) 1495 zx1 = - r1_8 * ( phU(ji-1,jj ) + phU(ji-1,jj+1) & 1496 & + phU(ji ,jj ) + phU(ji ,jj+1) ) * r1_e2v_xtd(ji,jj) 1497 pu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) ) 1498 pv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) ) 1499 END DO 1500 END DO 1501 ! 1502 CASE( np_EET , np_EEN ) ! energy & enstrophy scheme (using e3t or e3f) 1503 DO jj = kdbj+1, kdej-1 1504 DO ji = kdbi+1, kdei-1 1505 pu_trd(ji,jj) = + r1_12 * r1_e1u_xtd(ji,jj) * ( ftne(ji,jj ) * phV(ji ,jj ) & 1506 & + ftnw(ji+1,jj) * phV(ji+1,jj ) & 1507 & + ftse(ji,jj ) * phV(ji ,jj-1) & 1508 & + ftsw(ji+1,jj) * phV(ji+1,jj-1) ) 1509 pv_trd(ji,jj) = - r1_12 * r1_e2v_xtd(ji,jj) * ( ftsw(ji,jj+1) * phU(ji-1,jj+1) & 1510 & + ftse(ji,jj+1) * phU(ji ,jj+1) & 1511 & + ftnw(ji,jj ) * phU(ji-1,jj ) & 1512 & + ftne(ji,jj ) * phU(ji ,jj ) ) 1302 1513 END DO 1303 1514 END DO … … 1305 1516 END SELECT 1306 1517 ! 1307 END SUBROUTINE dyn_cor_2 D1518 END SUBROUTINE dyn_cor_2d 1308 1519 1309 1520 … … 1448 1659 1449 1660 1450 SUBROUTINE d yn_drg_init( pu_RHSi, pv_RHSi, pCdU_u, pCdU_v )1451 !!---------------------------------------------------------------------- 1452 !! *** ROUTINE d yn_drg_init ***1661 SUBROUTINE drg_init( kdbi, kdei, kdbj, kdej, pu_frc, pv_frc, pCdU_u, pCdU_v ) 1662 !!---------------------------------------------------------------------- 1663 !! *** ROUTINE drg_init *** 1453 1664 !! 1454 1665 !! ** Purpose : - add the baroclinic top/bottom drag contribution to … … 1458 1669 !! ** Method : computation done over the INNER domain only 1459 1670 !!---------------------------------------------------------------------- 1460 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pu_RHSi, pv_RHSi ! baroclinic part of the barotropic RHS 1461 REAL(wp), DIMENSION(jpi,jpj), INTENT( out) :: pCdU_u , pCdU_v ! barotropic drag coefficients 1671 INTEGER , INTENT(in ) :: kdbi, kdei, kdbj, kdej ! arrays size 1672 REAL(wp), DIMENSION(kdbi:kdei,kdbj:kdej), INTENT(inout) :: pu_frc, pv_frc ! baroclinic part of the barotropic RHS 1673 REAL(wp), DIMENSION(kdbi:kdei,kdbj:kdej), INTENT( out) :: pCdU_u , pCdU_v ! barotropic drag coefficients 1462 1674 ! 1463 1675 INTEGER :: ji, jj ! dummy loop indices … … 1514 1726 DO jj = 2, jpjm1 1515 1727 DO ji = 2, jpim1 ! INNER domain 1516 pu_ RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) * wdrampu(ji,jj) * MAX( &1728 pu_frc(ji,jj) = pu_frc(ji,jj) + zu_i(ji,jj) * wdrampu(ji,jj) * MAX( & 1517 1729 & r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) , zztmp ) 1518 pv_ RHSi(ji,jj) = pv_RHSi(ji,jj) + zv_i(ji,jj) * wdrampv(ji,jj) * MAX( &1730 pv_frc(ji,jj) = pv_frc(ji,jj) + zv_i(ji,jj) * wdrampv(ji,jj) * MAX( & 1519 1731 & r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) , zztmp ) 1520 1732 END DO … … 1524 1736 DO jj = 2, jpjm1 1525 1737 DO ji = 2, jpim1 ! INNER domain 1526 pu_ RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj)1527 pv_ RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj)1738 pu_frc(ji,jj) = pu_frc(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj) 1739 pv_frc(ji,jj) = pv_frc(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj) 1528 1740 END DO 1529 1741 END DO … … 1560 1772 DO jj = 2, jpjm1 1561 1773 DO ji = 2, jpim1 ! INNER domain 1562 pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj) 1563 pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj) 1564 END DO 1565 END DO 1566 ! 1567 ENDIF 1568 ! 1569 END SUBROUTINE dyn_drg_init 1570 1571 SUBROUTINE ts_bck_interp( jn, ll_init, & ! <== in 1774 pu_frc(ji,jj) = pu_frc(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj) 1775 pv_frc(ji,jj) = pv_frc(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj) 1776 END DO 1777 END DO 1778 ! 1779 ENDIF 1780 ! 1781 END SUBROUTINE drg_init 1782 1783 1784 SUBROUTINE ts_bck_interp( km, ld_init, & ! <== in 1572 1785 & za0, za1, za2, za3 ) ! ==> out 1573 1786 !!---------------------------------------------------------------------- 1574 INTEGER ,INTENT(in ) :: jn! index of sub time step1575 LOGICAL ,INTENT(in ) :: l l_init !1787 INTEGER ,INTENT(in ) :: km ! index of sub time step 1788 LOGICAL ,INTENT(in ) :: ld_init ! 1576 1789 REAL(wp),INTENT( out) :: za0, za1, za2, za3 ! Half-step back interpolation coefficient 1577 1790 ! … … 1579 1792 !!---------------------------------------------------------------------- 1580 1793 ! ! set Half-step back interpolation coefficient 1581 IF ( jn==1 .AND. ll_init ) THEN !* Forward-backward1794 IF ( km==1 .AND. ld_init ) THEN !* Forward-backward 1582 1795 za0 = 1._wp 1583 1796 za1 = 0._wp 1584 1797 za2 = 0._wp 1585 1798 za3 = 0._wp 1586 ELSEIF( jn==2 .AND. ll_init ) THEN !* AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/121799 ELSEIF( km==2 .AND. ld_init ) THEN !* AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/12 1587 1800 za0 = 1.0833333333333_wp ! za0 = 1-gam-eps 1588 1801 za1 =-0.1666666666666_wp ! za1 = gam -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/DYN/sshwzv.F90
r11353 r11380 113 113 IF( ln_bdy ) THEN 114 114 CALL lbc_lnk( 'sshwzv', ssha, 'T', 1. ) ! Not sure that's necessary 115 CALL bdy_ssh( ssha )! Duplicate sea level across open boundaries115 CALL bdy_ssh( ssha, 1, jpi, 1, jpj ) ! Duplicate sea level across open boundaries 116 116 ENDIF 117 117 ENDIF -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/IOM/iom.F90
r11362 r11380 58 58 PUBLIC iom_init, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get 59 59 PUBLIC iom_chkatt, iom_getatt, iom_putatt, iom_getszuld, iom_rstput, iom_delay_rst, iom_put 60 PUBLIC iom_use, iom_context_finalize , iom_miss_val60 PUBLIC iom_use, iom_context_finalize 61 61 62 62 PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d … … 1671 1671 CHARACTER(LEN=*), INTENT(in) :: cdname 1672 1672 REAL(wp) , INTENT(in) :: pfield0d 1673 !!REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson1673 REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson 1674 1674 #if defined key_iomput 1675 !!clemzz(:,:)=pfield0d1676 !!clemCALL xios_send_field(cdname, zz)1677 CALL xios_send_field(cdname, (/pfield0d/))1675 zz(:,:)=pfield0d 1676 CALL xios_send_field(cdname, zz) 1677 !CALL xios_send_field(cdname, (/pfield0d/)) 1678 1678 #else 1679 1679 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings … … 2391 2391 !! NOT 'key_iomput' a few dummy routines 2392 2392 !!---------------------------------------------------------------------- 2393 2393 2394 SUBROUTINE iom_setkt( kt, cdname ) 2394 2395 INTEGER , INTENT(in):: kt … … 2405 2406 2406 2407 LOGICAL FUNCTION iom_use( cdname ) 2408 !!---------------------------------------------------------------------- 2409 !!---------------------------------------------------------------------- 2407 2410 CHARACTER(LEN=*), INTENT(in) :: cdname 2411 !!---------------------------------------------------------------------- 2408 2412 #if defined key_iomput 2409 2413 iom_use = xios_field_is_active( cdname ) … … 2412 2416 #endif 2413 2417 END FUNCTION iom_use 2414 2415 SUBROUTINE iom_miss_val( cdname, pmiss_val ) 2416 CHARACTER(LEN=*), INTENT(in ) :: cdname 2417 REAL(wp) , INTENT(out) :: pmiss_val 2418 #if defined key_iomput 2419 ! get missing value 2420 CALL xios_get_field_attr( cdname, default_value = pmiss_val ) 2421 #else 2422 IF( .FALSE. ) WRITE(numout,*) cdname, pmiss_val ! useless test to avoid compilation warnings 2423 #endif 2424 END SUBROUTINE iom_miss_val 2425 2418 2426 2419 !!====================================================================== 2427 2420 END MODULE iom -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/LBC/lbc_lnk_multi_generic.h90
r11262 r11380 15 15 #endif 16 16 17 SUBROUTINE ROUTINE_MULTI( cdname & 18 & , pt1, cdna1, psgn1, pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4, cdna4, psgn4 & 19 & , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8 & 20 & , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11 & 21 & , kfillmode, pfillval, lsend, lrecv, ihlcom ) 17 SUBROUTINE ROUTINE_MULTI( cdname & 18 & , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4 & 19 & , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8 & 20 & , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12 & 21 & , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16 & 22 & , pt17, cdna17, psgn17, pt18, cdna18, psgn18, pt19, cdna19, psgn19, pt20, cdna20, psgn20 & 23 & , kfillmode, pfillval, ldsend, ldrecv, khlcom ) 22 24 !!--------------------------------------------------------------------- 23 25 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 24 26 ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied 25 27 ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 , pt10 , pt11 28 ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt12 , pt13 , pt14 , pt15 , pt16 , pt17 , pt18 , pt19 , pt20 26 29 CHARACTER(len=1) , INTENT(in ) :: cdna1 ! nature of pt2D. array grid-points 27 30 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9, cdna10, cdna11 31 CHARACTER(len=1) , OPTIONAL , INTENT(in ) :: cdna12, cdna13, cdna14, cdna15, cdna16, cdna17, cdna18, cdna19, cdna20 28 32 REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold 29 33 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, psgn10, psgn11 34 REAL(wp) , OPTIONAL , INTENT(in ) :: psgn12, psgn13, psgn14, psgn15, psgn16, psgn17, psgn18, psgn19, psgn20 30 35 INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 31 36 REAL(wp) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 32 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: l send, lrecv ! indicate how communications are to be carried out33 INTEGER , OPTIONAL , INTENT(in ) :: ihlcom! number of ranks and rows to be communicated37 LOGICAL, DIMENSION(4), OPTIONAL , INTENT(in ) :: ldsend, ldrecv ! indicate how communications are to be carried out 38 INTEGER , OPTIONAL , INTENT(in ) :: khlcom ! number of ranks and rows to be communicated 34 39 !! 35 40 INTEGER :: kfld ! number of elements that will be attributed 36 PTR_TYPE , DIMENSION( 11) :: ptab_ptr ! pointer array37 CHARACTER(len=1) , DIMENSION( 11) :: cdna_ptr ! nature of ptab_ptr grid-points38 REAL(wp) , DIMENSION( 11) :: psgn_ptr ! sign used across the north fold boundary41 PTR_TYPE , DIMENSION(20) :: ptab_ptr ! pointer array 42 CHARACTER(len=1) , DIMENSION(20) :: cdna_ptr ! nature of ptab_ptr grid-points 43 REAL(wp) , DIMENSION(20) :: psgn_ptr ! sign used across the north fold boundary 39 44 !!--------------------------------------------------------------------- 40 45 ! … … 55 60 IF( PRESENT(psgn10) ) CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 56 61 IF( PRESENT(psgn11) ) CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 62 IF( PRESENT(psgn12) ) CALL ROUTINE_LOAD( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 63 IF( PRESENT(psgn13) ) CALL ROUTINE_LOAD( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 64 IF( PRESENT(psgn14) ) CALL ROUTINE_LOAD( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 65 IF( PRESENT(psgn15) ) CALL ROUTINE_LOAD( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 66 IF( PRESENT(psgn16) ) CALL ROUTINE_LOAD( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 67 IF( PRESENT(psgn17) ) CALL ROUTINE_LOAD( pt17, cdna17, psgn17, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 68 IF( PRESENT(psgn18) ) CALL ROUTINE_LOAD( pt18, cdna18, psgn18, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 69 IF( PRESENT(psgn19) ) CALL ROUTINE_LOAD( pt19, cdna19, psgn19, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 70 IF( PRESENT(psgn20) ) CALL ROUTINE_LOAD( pt20, cdna20, psgn20, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 57 71 ! 58 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, l send, lrecv, ihlcom )72 CALL lbc_lnk_ptr ( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, ldsend, ldrecv, khlcom ) 59 73 ! 60 74 END SUBROUTINE ROUTINE_MULTI -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/LBC/mpp_lnk_generic.h90
r11262 r11380 7 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f) 8 8 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 9 # define I_SIZE(ptab) SIZE(ptab(1)%pt2d,1) 10 # define J_SIZE(ptab) SIZE(ptab(1)%pt2d,2) 9 11 # define K_SIZE(ptab) 1 10 12 # define L_SIZE(ptab) 1 … … 13 15 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D) , INTENT(inout) :: ptab(f) 14 16 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 17 # define I_SIZE(ptab) SIZE(ptab(1)%pt3d,1) 18 # define J_SIZE(ptab) SIZE(ptab(1)%pt3d,2) 15 19 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) 16 20 # define L_SIZE(ptab) 1 … … 19 23 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D) , INTENT(inout) :: ptab(f) 20 24 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 25 # define I_SIZE(ptab) SIZE(ptab(1)%pt4d,1) 26 # define J_SIZE(ptab) SIZE(ptab(1)%pt4d,2) 21 27 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) 22 28 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) … … 26 32 # define NAT_IN(k) cd_nat 27 33 # define SGN_IN(k) psgn 34 # define I_SIZE(ptab) SIZE(ptab,1) 35 # define J_SIZE(ptab) SIZE(ptab,2) 28 36 # define F_SIZE(ptab) 1 29 37 # define OPT_K(k) … … 46 54 47 55 #if defined MULTI 48 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, l send, lrecv, ihlcom )56 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, ldsend, ldrecv, khlcom ) 49 57 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 50 58 #else 51 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, l send, lrecv, ihlcom )59 SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, ldsend, ldrecv, khlcom ) 52 60 #endif 53 61 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied … … 57 65 INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 58 66 REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 59 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: l send, lrecv ! communication with other 4 proc60 INTEGER ,OPTIONAL, INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated67 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: ldsend, ldrecv ! communication with other 4 proc 68 INTEGER ,OPTIONAL, INTENT(in ) :: khlcom ! number of ranks and rows to be communicated 61 69 ! 62 70 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices … … 80 88 ! ----------------------------------------- ! 81 89 ! 90 ipi = I_SIZE(ptab) 91 ipj = J_SIZE(ptab) 82 92 ipk = K_SIZE(ptab) ! 3rd dimension 83 93 ipl = L_SIZE(ptab) ! 4th - 84 94 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 85 95 ! 86 IF( PRESENT( ihlcom) ) THEN ; ihl = ihlcom87 ELSE ; ihl = 196 IF( PRESENT(khlcom) ) THEN ; ihl = khlcom 97 ELSE ; ihl = nn_hls 88 98 END IF 89 99 ! 90 100 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 91 101 ! 92 IF ( PRESENT(l send) .AND. PRESENT(lrecv) ) THEN93 llsend_we = l send(1) ; llsend_ea = lsend(2) ; llsend_so = lsend(3) ; llsend_no = lsend(4)94 llrecv_we = l recv(1) ; llrecv_ea = lrecv(2) ; llrecv_so = lrecv(3) ; llrecv_no = lrecv(4)95 ELSE IF( PRESENT(l send) .OR. PRESENT(lrecv) ) THEN96 WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments l send or lrecv'102 IF ( PRESENT(ldsend) .AND. PRESENT(ldrecv) ) THEN 103 llsend_we = ldsend(1) ; llsend_ea = ldsend(2) ; llsend_so = ldsend(3) ; llsend_no = ldsend(4) 104 llrecv_we = ldrecv(1) ; llrecv_ea = ldrecv(2) ; llrecv_so = ldrecv(3) ; llrecv_no = ldrecv(4) 105 ELSE IF( PRESENT(ldsend) .OR. PRESENT(ldrecv) ) THEN 106 WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments ldsend or ldrecv' 97 107 WRITE(ctmp2,*) ' ========== ' 98 108 CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) … … 149 159 ! 150 160 ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg 151 isize = ihl * jpj * ipk * ipl * ipf161 isize = ihl * ipj * ipk * ipl * ipf 152 162 ! 153 163 ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 154 IF( llsend_we ) ALLOCATE( zsnd_we(ihl, jpj,ipk,ipl,ipf) )155 IF( llsend_ea ) ALLOCATE( zsnd_ea(ihl, jpj,ipk,ipl,ipf) )156 IF( llrecv_we ) ALLOCATE( zrcv_we(ihl, jpj,ipk,ipl,ipf) )157 IF( llrecv_ea ) ALLOCATE( zrcv_ea(ihl, jpj,ipk,ipl,ipf) )164 IF( llsend_we ) ALLOCATE( zsnd_we(ihl,ipj,ipk,ipl,ipf) ) 165 IF( llsend_ea ) ALLOCATE( zsnd_ea(ihl,ipj,ipk,ipl,ipf) ) 166 IF( llrecv_we ) ALLOCATE( zrcv_we(ihl,ipj,ipk,ipl,ipf) ) 167 IF( llrecv_ea ) ALLOCATE( zrcv_ea(ihl,ipj,ipk,ipl,ipf) ) 158 168 ! 159 169 IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI 160 170 ishift = ihl 161 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl171 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ipj ; DO ji = 1, ihl 162 172 zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! ihl + 1 -> 2*ihl 163 173 END DO ; END DO ; END DO ; END DO ; END DO … … 165 175 ! 166 176 IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 167 ishift = jpi - 2 * ihl168 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl177 ishift = ipi - 2 * ihl 178 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ipj ; DO ji = 1, ihl 169 179 zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*ihl + 1 -> jpi - ihl 170 180 END DO ; END DO ; END DO ; END DO ; END DO … … 193 203 CASE ( jpfillnothing ) ! no filling 194 204 CASE ( jpfillmpi ) ! use data received by MPI 195 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl205 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ipj ; DO ji = 1, ihl 196 206 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> ihl 197 207 END DO; END DO ; END DO ; END DO ; END DO 198 208 CASE ( jpfillperio ) ! use east-weast periodicity 199 ishift2 = jpi - 2 * ihl200 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl209 ishift2 = ipi - 2 * ihl 210 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ipj ; DO ji = 1, ihl 201 211 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 202 212 END DO; END DO ; END DO ; END DO ; END DO … … 204 214 DO jf = 1, ipf ! number of arrays to be treated 205 215 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 206 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl216 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ipj ; DO ji = 1, ihl 207 217 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ihl+1,jj,jk,jl,jf) 208 218 END DO ; END DO ; END DO ; END DO … … 212 222 DO jf = 1, ipf ! number of arrays to be treated 213 223 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 214 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl224 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ipj ; DO ji = 1, ihl 215 225 ARRAY_IN(ji,jj,jk,jl,jf) = zland 216 226 END DO; END DO ; END DO ; END DO … … 221 231 ! 2.2 fill eastern halo 222 232 ! --------------------- 223 ishift = jpi - ihl ! fill halo from ji = jpi-ihl+1 to jpi233 ishift = ipi - ihl ! fill halo from ji = jpi-ihl+1 to jpi 224 234 SELECT CASE ( ifill_ea ) 225 235 CASE ( jpfillnothing ) ! no filling 226 236 CASE ( jpfillmpi ) ! use data received by MPI 227 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl237 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ipj ; DO ji = 1, ihl 228 238 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - ihl + 1 -> jpi 229 239 END DO ; END DO ; END DO ; END DO ; END DO 230 240 CASE ( jpfillperio ) ! use east-weast periodicity 231 241 ishift2 = ihl 232 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl242 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ipj ; DO ji = 1, ihl 233 243 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 234 244 END DO ; END DO ; END DO ; END DO ; END DO 235 245 CASE ( jpfillcopy ) ! filling with inner domain values 236 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl246 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ipj ; DO ji = 1, ihl 237 247 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 238 248 END DO ; END DO ; END DO ; END DO ; END DO 239 249 CASE ( jpfillcst ) ! filling with constant value 240 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl250 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ipj ; DO ji = 1, ihl 241 251 ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 242 252 END DO; END DO ; END DO ; END DO ; END DO … … 264 274 ! ---------------------------------------------------- ! 265 275 ! 266 IF( llsend_so ) ALLOCATE( zsnd_so( jpi,ihl,ipk,ipl,ipf) )267 IF( llsend_no ) ALLOCATE( zsnd_no( jpi,ihl,ipk,ipl,ipf) )268 IF( llrecv_so ) ALLOCATE( zrcv_so( jpi,ihl,ipk,ipl,ipf) )269 IF( llrecv_no ) ALLOCATE( zrcv_no( jpi,ihl,ipk,ipl,ipf) )270 ! 271 isize = jpi * ihl * ipk * ipl * ipf276 IF( llsend_so ) ALLOCATE( zsnd_so(ipi,ihl,ipk,ipl,ipf) ) 277 IF( llsend_no ) ALLOCATE( zsnd_no(ipi,ihl,ipk,ipl,ipf) ) 278 IF( llrecv_so ) ALLOCATE( zrcv_so(ipi,ihl,ipk,ipl,ipf) ) 279 IF( llrecv_no ) ALLOCATE( zrcv_no(ipi,ihl,ipk,ipl,ipf) ) 280 ! 281 isize = ipi * ihl * ipk * ipl * ipf 272 282 273 283 ! allocate local temporary arrays to be sent/received. Fill arrays to be sent 274 284 IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI 275 285 ishift = ihl 276 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi286 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, ipi 277 287 zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! ihl+1 -> 2*ihl 278 288 END DO ; END DO ; END DO ; END DO ; END DO … … 280 290 ! 281 291 IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 282 ishift = jpj - 2 * ihl283 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi292 ishift = ipj - 2 * ihl 293 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, ipi 284 294 zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*ihl+1 -> jpj-ihl 285 295 END DO ; END DO ; END DO ; END DO ; END DO … … 307 317 CASE ( jpfillnothing ) ! no filling 308 318 CASE ( jpfillmpi ) ! use data received by MPI 309 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi319 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, ipi 310 320 ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> ihl 311 321 END DO; END DO ; END DO ; END DO ; END DO 312 322 CASE ( jpfillperio ) ! use north-south periodicity 313 ishift2 = jpj - 2 * ihl314 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi323 ishift2 = ipj - 2 * ihl 324 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, ipi 315 325 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 316 326 END DO; END DO ; END DO ; END DO ; END DO … … 318 328 DO jf = 1, ipf ! number of arrays to be treated 319 329 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 320 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi330 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, ipi 321 331 ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ihl+1,jk,jl,jf) 322 332 END DO ; END DO ; END DO ; END DO … … 326 336 DO jf = 1, ipf ! number of arrays to be treated 327 337 IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point 328 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi338 DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, ipi 329 339 ARRAY_IN(ji,jj,jk,jl,jf) = zland 330 340 END DO; END DO ; END DO ; END DO … … 335 345 ! 5.2 fill northern halo 336 346 ! ---------------------- 337 ishift = jpj - ihl ! fill halo from jj = jpj-ihl+1 to jpj347 ishift = ipj - ihl ! fill halo from jj = jpj-ihl+1 to jpj 338 348 SELECT CASE ( ifill_no ) 339 349 CASE ( jpfillnothing ) ! no filling 340 350 CASE ( jpfillmpi ) ! use data received by MPI 341 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi351 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, ipi 342 352 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-ihl+1 -> jpj 343 353 END DO ; END DO ; END DO ; END DO ; END DO 344 354 CASE ( jpfillperio ) ! use north-south periodicity 345 355 ishift2 = ihl 346 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi356 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, ipi 347 357 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 348 358 END DO; END DO ; END DO ; END DO ; END DO 349 359 CASE ( jpfillcopy ) ! filling with inner domain values 350 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi360 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, ipi 351 361 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 352 362 END DO; END DO ; END DO ; END DO ; END DO 353 363 CASE ( jpfillcst ) ! filling with constant value 354 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi364 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, ipi 355 365 ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 356 366 END DO; END DO ; END DO ; END DO ; END DO … … 389 399 #undef SGN_IN 390 400 #undef ARRAY_IN 401 #undef I_SIZE 402 #undef J_SIZE 391 403 #undef K_SIZE 392 404 #undef L_SIZE -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/LBC/mppini.F90
r11317 r11380 168 168 & rn_ice_tem, rn_ice_sal, rn_ice_age, & 169 169 & ln_vol, nn_volctl, nn_rimwidth 170 NAMELIST/nammpp/ jpni, jpnj, ln_nnogather 170 NAMELIST/nammpp/ jpni, jpnj, ln_nnogather, nn_hlts 171 171 !!---------------------------------------------------------------------- 172 172 ! -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/nemogcm.F90
r11365 r11380 59 59 USE diaobs ! Observation diagnostics (dia_obs_init routine) 60 60 USE diacfl ! CFL diagnostics (dia_cfl_init routine) 61 USE diaharm ! tidal harmonics diagnostics (dia_harm_init routine)62 61 USE step ! NEMO time-stepping (stp routine) 63 62 USE icbini ! handle bergs, initialisation … … 473 472 IF( ln_diacfl ) CALL dia_cfl_init ! Initialise CFL diagnostics 474 473 CALL dia_ptr_init ! Poleward TRansports initialization 475 474 IF( lk_diadct ) CALL dia_dct_init ! Sections tranports 476 475 CALL dia_hsb_init ! heat content, salt content and volume budgets 477 476 CALL trd_init ! Mixed-layer/Vorticity/Integral constraints trends … … 479 478 CALL dia_tmb_init ! TMB outputs 480 479 CALL dia_25h_init ! 25h mean outputs 481 CALL dia_harm_init ! tidal harmonics outputs 482 IF( ln_diaobs ) CALL dia_obs( nit000-1 ) ! Observation operator for restart 480 IF( ln_diaobs ) CALL dia_obs( nit000-1 ) ! Observation operator for restart 483 481 484 482 ! ! Assimilation increments … … 641 639 USE trc_oce , ONLY : trc_oce_alloc 642 640 USE bdy_oce , ONLY : bdy_oce_alloc 641 #if defined key_diadct 642 USE diadct , ONLY : diadct_alloc 643 #endif 643 644 ! 644 645 INTEGER :: ierr … … 652 653 ierr = ierr + bdy_oce_alloc() ! bdy masks (incl. initialization) 653 654 ! 655 #if defined key_diadct 656 ierr = ierr + diadct_alloc () ! 657 #endif 658 ! 654 659 CALL mpp_sum( 'nemogcm', ierr ) 655 660 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' ) -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/oce.F90
r10425 r11380 38 38 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshb , sshn , ssha !: sea surface height at t-point [m] 39 39 40 !! Arrays at barotropic time step: ! befbefore! before ! now ! after !41 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ubb_e , ub_e , un_e , ua_e !: u-external velocity42 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vbb_e , vb_e , vn_e , va_e !: v-external velocity43 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshbb_e, sshb_e, sshn_e, ssha_e !: external ssh44 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_e !: external u-depth45 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_e !: external v-depth46 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hur_e !: inverse of u-depth47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hvr_e !: inverse of v-depth48 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub2_b , vb2_b !: Half step fluxes (ln_bt_fw=T)49 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_bf , vn_bf !: Asselin filtered half step fluxes (ln_bt_fw=T)50 #if defined key_agrif51 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub2_i_b, vb2_i_b !: Half step time integrated fluxes52 #endif53 40 ! 54 41 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: spgu, spgv !: horizontal surface pressure gradient … … 104 91 ALLOCATE( fraqsr_1lev(jpi,jpj) , STAT=ierr(3) ) 105 92 ! 106 ALLOCATE( ssha_e(jpi,jpj), sshn_e(jpi,jpj), sshb_e(jpi,jpj), sshbb_e(jpi,jpj), &107 & ua_e(jpi,jpj), un_e(jpi,jpj), ub_e(jpi,jpj), ubb_e(jpi,jpj), &108 & va_e(jpi,jpj), vn_e(jpi,jpj), vb_e(jpi,jpj), vbb_e(jpi,jpj), &109 & hu_e(jpi,jpj), hur_e(jpi,jpj), hv_e(jpi,jpj), hvr_e(jpi,jpj), STAT=ierr(4) )110 !111 ALLOCATE( ub2_b(jpi,jpj), vb2_b(jpi,jpj), un_bf(jpi,jpj), vn_bf(jpi,jpj) , STAT=ierr(6) )112 #if defined key_agrif113 ALLOCATE( ub2_i_b(jpi,jpj), vb2_i_b(jpi,jpj) , STAT=ierr(6) )114 #endif115 !116 93 oce_alloc = MAXVAL( ierr ) 117 94 IF( oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'oce_alloc: failed to allocate arrays' ) -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/par_oce.F90
r10068 r11380 75 75 INTEGER, PUBLIC, PARAMETER :: jpr2dj = 0 !: number of rows for extra outer halo 76 76 INTEGER, PUBLIC, PARAMETER :: nn_hls = 1 !: halo width (applies to both rows and columns) 77 INTEGER, PUBLIC :: nn_hlts !: added halo width for time splitting 77 78 78 79 !!---------------------------------------------------------------------- -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/step.F90
r11365 r11380 217 217 IF( ln_diacfl ) CALL dia_cfl ( kstp ) ! Courant number diagnostics 218 218 IF( lk_diahth ) CALL dia_hth ( kstp ) ! Thermocline depth (20 degres isotherm depth) 219 IF( l n_diadct ) CALL dia_dct ( kstp ) ! Transports219 IF( lk_diadct ) CALL dia_dct ( kstp ) ! Transports 220 220 CALL dia_ar5 ( kstp ) ! ar5 diag 221 IF( l n_diaharm ) CALL dia_harm( kstp ) ! Tidal harmonic analysis221 IF( lk_diaharm ) CALL dia_harm( kstp ) ! Tidal harmonic analysis 222 222 CALL dia_wri ( kstp ) ! ocean model: outputs 223 223 ! -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/timing.F90
r11373 r11380 657 657 ! Compute cpu/elapsed ratio 658 658 zall_ratio(:) = all_ctime(:) / all_etime(:) 659 ztot_ratio = SUM( all_ctime(:))/SUM(all_etime(:))660 zavg_ratio = SUM(zall_ratio(:))/REAL(jpnij,wp)659 ztot_ratio = SUM(zall_ratio(:)) 660 zavg_ratio = ztot_ratio/REAL(jpnij,wp) 661 661 zmax_ratio = MAXVAL(zall_ratio(:)) 662 662 zmin_ratio = MINVAL(zall_ratio(:)) … … 667 667 cllignes(2)='1x,"--------------------",//,' 668 668 cllignes(3)='1x,"Process Rank |"," Elapsed Time (s) |"," CPU Time (s) |"," Ratio CPU/Elapsed",/,' 669 cllignes(4)=' (4x,i6,4x,"|",f12.3,6x,"|",f12.3,2x,"|",4x,f7.3,/),'670 WRITE(cllignes(4)(1: 6),'(I6)') jpnij669 cllignes(4)=' (1x,i4,9x,"|",f12.3,6x,"|",f12.3,2x,"|",4x,f7.3,/),' 670 WRITE(cllignes(4)(1:4),'(I4)') jpnij 671 671 cllignes(5)='1x,"Total |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' 672 672 cllignes(6)='1x,"Minimum |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' -
NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/tests/demo_cfgs.txt
r10516 r11380 9 9 WAD OCE 10 10 BENCH OCE ICE TOP 11 DONUT OCE ICE
Note: See TracChangeset
for help on using the changeset viewer.