Changeset 14037 for NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DIA/diaptr.F90
- Timestamp:
- 2020-12-03T12:20:38+01:00 (3 years ago)
- Location:
- NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/OCE/DIA/diaptr.F90 (modified) (19 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG
- Property svn:externals
-
old new 8 8 9 9 # SETTE 10 ^/utils/CI/sette @13292sette10 ^/utils/CI/sette_wave@13990 sette
-
- Property svn:externals
-
NEMO/branches/2020/dev_r13333_KERNEL-08_techene_gm_HPG_SPG/src/OCE/DIA/diaptr.F90
r13295 r14037 22 22 USE oce ! ocean dynamics and active tracers 23 23 USE dom_oce ! ocean space and time domain 24 USE domain, ONLY : dom_tile 24 25 USE phycst ! physical constants 25 26 ! … … 32 33 PRIVATE 33 34 35 INTERFACE ptr_sum 36 MODULE PROCEDURE ptr_sum_3d, ptr_sum_2d 37 END INTERFACE 38 34 39 INTERFACE ptr_sj 35 40 MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d 36 41 END INTERFACE 37 42 38 PUBLIC ptr_sj ! call by tra_ldf & tra_adv routines39 PUBLIC ptr_sjk !40 PUBLIC dia_ptr_init ! call in memogcm41 43 PUBLIC dia_ptr ! call in step module 42 44 PUBLIC dia_ptr_hst ! called from tra_ldf/tra_adv routines 43 45 44 ! !!** namelist namptr ** 45 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) 46 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) 47 48 LOGICAL , PUBLIC :: l_diaptr !: tracers trend flag (set from namelist in trdini) 49 INTEGER, PARAMETER, PUBLIC :: nptr = 5 ! (glo, atl, pac, ind, ipc) 46 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) 47 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) 48 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: pvtr_int, pzon_int !: Other zonal integrals 49 50 LOGICAL, PUBLIC :: l_diaptr !: tracers trend flag 51 INTEGER, PARAMETER :: jp_msk = 3 52 INTEGER, PARAMETER :: jp_vtr = 4 50 53 51 54 REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup … … 56 59 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S) 57 60 58 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:) :: p_fval1d 59 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d 60 61 LOGICAL :: ll_init = .TRUE. !: tracers trend flag (set from namelist in trdini) 62 61 LOGICAL :: ll_init = .TRUE. !: tracers trend flag 62 63 63 !! * Substitutions 64 64 # include "do_loop_substitute.h90" … … 77 77 INTEGER , INTENT(in) :: kt ! ocean time-step index 78 78 INTEGER , INTENT(in) :: Kmm ! time level index 79 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport 79 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport 80 !!---------------------------------------------------------------------- 81 ! 82 IF( ln_timing ) CALL timing_start('dia_ptr') 83 84 IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init ! -> will define l_diaptr and nbasin 85 ! 86 IF( l_diaptr ) THEN 87 ! Calculate zonal integrals 88 IF( PRESENT( pvtr ) ) THEN 89 CALL dia_ptr_zint( Kmm, pvtr ) 90 ELSE 91 CALL dia_ptr_zint( Kmm ) 92 ENDIF 93 94 ! Calculate diagnostics only when zonal integrals have finished 95 IF( ntile == 0 .OR. ntile == nijtile ) CALL dia_ptr_iom(kt, Kmm, pvtr) 96 ENDIF 97 98 IF( ln_timing ) CALL timing_stop('dia_ptr') 99 ! 100 END SUBROUTINE dia_ptr 101 102 103 SUBROUTINE dia_ptr_iom( kt, Kmm, pvtr ) 104 !!---------------------------------------------------------------------- 105 !! *** ROUTINE dia_ptr_iom *** 106 !!---------------------------------------------------------------------- 107 !! ** Purpose : Calculate diagnostics and send to XIOS 108 !!---------------------------------------------------------------------- 109 INTEGER , INTENT(in) :: kt ! ocean time-step index 110 INTEGER , INTENT(in) :: Kmm ! time level index 111 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport 80 112 ! 81 113 INTEGER :: ji, jj, jk, jn ! dummy loop indices 82 REAL(wp) :: zsfc,zvfc ! local scalar83 114 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 84 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace85 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace86 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace87 115 REAL(wp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace 88 116 ! 89 117 !overturning calculation 90 REAL(wp), DIMENSION(jpj,jpk,nptr) :: sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse 91 REAL(wp), DIMENSION(jpj,jpk,nptr) :: zt_jk, zs_jk ! i-mean T and S, j-Stream-Function 92 93 REAL(wp), DIMENSION(jpi,jpj,jpk,nptr) :: z4d1, z4d2 94 REAL(wp), DIMENSION(jpi,jpj,nptr) :: z3dtr ! i-mean T and S, j-Stream-Function 95 !!---------------------------------------------------------------------- 96 ! 97 IF( ln_timing ) CALL timing_start('dia_ptr') 98 99 IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init 100 ! 101 IF( .NOT. l_diaptr ) RETURN 118 REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse 119 REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: zt_jk, zs_jk ! i-mean T and S, j-Stream-Function 120 121 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: z4d1, z4d2 122 REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: z3dtr 123 !!---------------------------------------------------------------------- 124 ! 125 ALLOCATE( z3dtr(jpi,jpj,nbasin) ) 102 126 103 127 IF( PRESENT( pvtr ) ) THEN 104 128 IF( iom_use( 'zomsf' ) ) THEN ! effective MSF 105 DO jn = 1, nptr ! by sub-basins 106 z4d1(1,:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) ! zonal cumulative effective transport excluding closed seas 107 DO jk = jpkm1, 1, -1 129 ALLOCATE( z4d1(jpi,jpj,jpk,nbasin) ) 130 ! 131 DO jn = 1, nbasin ! by sub-basins 132 z4d1(1,:,:,jn) = pvtr_int(:,:,jp_vtr,jn) ! zonal cumulative effective transport excluding closed seas 133 DO jk = jpkm1, 1, -1 108 134 z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn) ! effective j-Stream-Function (MSF) 109 135 END DO 110 DO ji = 1, jpi136 DO ji = 2, jpi 111 137 z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) 112 138 ENDDO 113 139 END DO 114 140 CALL iom_put( 'zomsf', z4d1 * rc_sv ) 115 ENDIF 141 ! 142 DEALLOCATE( z4d1 ) 143 ENDIF 144 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 145 ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin), & 146 & zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) ) 147 ! 148 DO jn = 1, nbasin 149 sjk(:,:,jn) = pvtr_int(:,:,jp_msk,jn) 150 r1_sjk(:,:,jn) = 0._wp 151 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 152 ! i-mean T and S, j-Stream-Function, basin 153 zt_jk(:,:,jn) = pvtr_int(:,:,jp_tem,jn) * r1_sjk(:,:,jn) 154 zs_jk(:,:,jn) = pvtr_int(:,:,jp_sal,jn) * r1_sjk(:,:,jn) 155 v_msf(:,:,jn) = pvtr_int(:,:,jp_vtr,jn) 156 hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 157 hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) 158 ! 159 ENDDO 160 DO jn = 1, nbasin 161 z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 162 DO ji = 2, jpi 163 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 164 ENDDO 165 ENDDO 166 CALL iom_put( 'sophtove', z3dtr ) 167 DO jn = 1, nbasin 168 z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 169 DO ji = 2, jpi 170 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 171 ENDDO 172 ENDDO 173 CALL iom_put( 'sopstove', z3dtr ) 174 ! 175 DEALLOCATE( sjk, r1_sjk, v_msf, zt_jk, zs_jk ) 176 ENDIF 177 178 IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 179 ! Calculate barotropic heat and salt transport here 180 ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) ) 181 ! 182 DO jn = 1, nbasin 183 sjk(:,1,jn) = SUM( pvtr_int(:,:,jp_msk,jn), 2 ) 184 r1_sjk(:,1,jn) = 0._wp 185 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 186 ! 187 zvsum(:) = SUM( pvtr_int(:,:,jp_vtr,jn), 2 ) 188 ztsum(:) = SUM( pvtr_int(:,:,jp_tem,jn), 2 ) 189 zssum(:) = SUM( pvtr_int(:,:,jp_sal,jn), 2 ) 190 hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 191 hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) 192 ! 193 ENDDO 194 DO jn = 1, nbasin 195 z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 196 DO ji = 2, jpi 197 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 198 ENDDO 199 ENDDO 200 CALL iom_put( 'sophtbtr', z3dtr ) 201 DO jn = 1, nbasin 202 z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 203 DO ji = 2, jpi 204 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 205 ENDDO 206 ENDDO 207 CALL iom_put( 'sopstbtr', z3dtr ) 208 ! 209 DEALLOCATE( sjk, r1_sjk ) 210 ENDIF 211 ! 212 hstr_ove(:,:,:) = 0._wp ! Zero before next timestep 213 hstr_btr(:,:,:) = 0._wp 214 pvtr_int(:,:,:,:) = 0._wp 215 ELSE 216 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface 217 ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) ) 218 ! 219 DO jn = 1, nbasin 220 z4d1(1,:,:,jn) = pzon_int(:,:,jp_msk,jn) 221 DO ji = 2, jpi 222 z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) 223 ENDDO 224 ENDDO 225 CALL iom_put( 'zosrf', z4d1 ) 226 ! 227 DO jn = 1, nbasin 228 z4d2(1,:,:,jn) = pzon_int(:,:,jp_tem,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) 229 DO ji = 2, jpi 230 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 231 ENDDO 232 ENDDO 233 CALL iom_put( 'zotem', z4d2 ) 234 ! 235 DO jn = 1, nbasin 236 z4d2(1,:,:,jn) = pzon_int(:,:,jp_sal,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) 237 DO ji = 2, jpi 238 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 239 ENDDO 240 ENDDO 241 CALL iom_put( 'zosal', z4d2 ) 242 ! 243 DEALLOCATE( z4d1, z4d2 ) 244 ENDIF 245 ! 246 ! ! Advective and diffusive heat and salt transport 247 IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN 248 ! 249 DO jn = 1, nbasin 250 z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 251 DO ji = 2, jpi 252 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 253 ENDDO 254 ENDDO 255 CALL iom_put( 'sophtadv', z3dtr ) 256 DO jn = 1, nbasin 257 z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 258 DO ji = 2, jpi 259 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 260 ENDDO 261 ENDDO 262 CALL iom_put( 'sopstadv', z3dtr ) 263 ENDIF 264 ! 265 IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN 266 ! 267 DO jn = 1, nbasin 268 z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 269 DO ji = 2, jpi 270 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 271 ENDDO 272 ENDDO 273 CALL iom_put( 'sophtldf', z3dtr ) 274 DO jn = 1, nbasin 275 z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 276 DO ji = 2, jpi 277 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 278 ENDDO 279 ENDDO 280 CALL iom_put( 'sopstldf', z3dtr ) 281 ENDIF 282 ! 283 IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN 284 ! 285 DO jn = 1, nbasin 286 z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 287 DO ji = 2, jpi 288 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 289 ENDDO 290 ENDDO 291 CALL iom_put( 'sophteiv', z3dtr ) 292 DO jn = 1, nbasin 293 z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 294 DO ji = 2, jpi 295 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 296 ENDDO 297 ENDDO 298 CALL iom_put( 'sopsteiv', z3dtr ) 299 ENDIF 300 ! 301 IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 302 DO jn = 1, nbasin 303 z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 304 DO ji = 2, jpi 305 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 306 ENDDO 307 ENDDO 308 CALL iom_put( 'sophtvtr', z3dtr ) 309 DO jn = 1, nbasin 310 z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 311 DO ji = 2, jpi 312 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 313 ENDDO 314 ENDDO 315 CALL iom_put( 'sopstvtr', z3dtr ) 316 ENDIF 317 ! 318 IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN 319 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Use full domain 320 CALL iom_get_var( 'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml 321 z2d(:,:) = ptr_ci_2d( z2d(:,:) ) 322 CALL iom_put( 'uocetr_vsum_cumul', z2d ) 323 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = nijtile ) ! Revert to tile domain 324 ENDIF 325 ! 326 hstr_adv(:,:,:) = 0._wp ! Zero before next timestep 327 hstr_ldf(:,:,:) = 0._wp 328 hstr_eiv(:,:,:) = 0._wp 329 hstr_vtr(:,:,:) = 0._wp 330 pzon_int(:,:,:,:) = 0._wp 331 ENDIF 332 ! 333 DEALLOCATE( z3dtr ) 334 ! 335 END SUBROUTINE dia_ptr_iom 336 337 338 SUBROUTINE dia_ptr_zint( Kmm, pvtr ) 339 !!---------------------------------------------------------------------- 340 !! *** ROUTINE dia_ptr_zint *** 341 !!---------------------------------------------------------------------- 342 !! ** Purpose : i and i-k sum operations on arrays 343 !! 344 !! ** Method : - Call ptr_sjk (i sum) or ptr_sj (i-k sum) to perform the sum operation 345 !! - Call ptr_sum to add this result to the sum over tiles 346 !! 347 !! ** Action : pvtr_int - terms for volume streamfunction, heat/salt transport barotropic/overturning terms 348 !! pzon_int - terms for i mean temperature/salinity 349 !!---------------------------------------------------------------------- 350 INTEGER , INTENT(in) :: Kmm ! time level index 351 REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport 352 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zmask ! 3D workspace 353 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zts ! 4D workspace 354 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: sjk, v_msf ! Zonal sum: i-k surface area, j-effective transport 355 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt_jk, zs_jk ! Zonal sum: i-k surface area * (T, S) 356 REAL(wp) :: zsfc, zvfc ! i-k surface area 357 INTEGER :: ji, jj, jk, jn ! dummy loop indices 358 !!---------------------------------------------------------------------- 359 360 IF( PRESENT( pvtr ) ) THEN 361 ! i sum of effective j transport excluding closed seas 362 IF( iom_use( 'zomsf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 363 ALLOCATE( v_msf(A1Dj(nn_hls),jpk,nbasin) ) 364 365 DO jn = 1, nbasin 366 v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) 367 ENDDO 368 369 CALL ptr_sum( pvtr_int(:,:,jp_vtr,:), v_msf(:,:,:) ) 370 371 DEALLOCATE( v_msf ) 372 ENDIF 373 374 ! i sum of j surface area, j surface area - temperature/salinity product on V grid 116 375 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 117 376 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 118 ! define fields multiplied by scalar 377 ALLOCATE( zmask(A2D(nn_hls),jpk), zts(A2D(nn_hls),jpk,jpts), & 378 & sjk(A1Dj(nn_hls),jpk,nbasin), & 379 & zt_jk(A1Dj(nn_hls),jpk,nbasin), zs_jk(A1Dj(nn_hls),jpk,nbasin) ) 380 119 381 zmask(:,:,:) = 0._wp 120 382 zts(:,:,:,:) = 0._wp 383 121 384 DO_3D( 1, 0, 1, 1, 1, jpkm1 ) 122 385 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 123 386 zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc 124 zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc 387 zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid 125 388 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 126 389 END_3D 127 ENDIF 128 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 129 DO jn = 1, nptr 130 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 131 r1_sjk(:,:,jn) = 0._wp 132 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 133 ! i-mean T and S, j-Stream-Function, basin 134 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 135 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 136 v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) 137 hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 138 hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) 139 ! 140 ENDDO 141 DO jn = 1, nptr 142 z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 143 DO ji = 1, jpi 144 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 145 ENDDO 146 ENDDO 147 CALL iom_put( 'sophtove', z3dtr ) 148 DO jn = 1, nptr 149 z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 150 DO ji = 1, jpi 151 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 152 ENDDO 153 ENDDO 154 CALL iom_put( 'sopstove', z3dtr ) 155 ENDIF 156 157 IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 158 ! Calculate barotropic heat and salt transport here 159 DO jn = 1, nptr 160 sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 161 r1_sjk(:,1,jn) = 0._wp 162 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 163 ! 164 zvsum(:) = ptr_sj( pvtr(:,:,:), btmsk34(:,:,jn) ) 165 ztsum(:) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 166 zssum(:) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 167 hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 168 hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) 169 ! 170 ENDDO 171 DO jn = 1, nptr 172 z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 173 DO ji = 1, jpi 174 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 175 ENDDO 176 ENDDO 177 CALL iom_put( 'sophtbtr', z3dtr ) 178 DO jn = 1, nptr 179 z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 180 DO ji = 1, jpi 181 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 182 ENDDO 183 ENDDO 184 CALL iom_put( 'sopstbtr', z3dtr ) 185 ENDIF 186 ! 390 391 DO jn = 1, nbasin 392 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:) , btmsk(:,:,jn) ) 393 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 394 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 395 ENDDO 396 397 CALL ptr_sum( pvtr_int(:,:,jp_msk,:), sjk(:,:,:) ) 398 CALL ptr_sum( pvtr_int(:,:,jp_tem,:), zt_jk(:,:,:) ) 399 CALL ptr_sum( pvtr_int(:,:,jp_sal,:), zs_jk(:,:,:) ) 400 401 DEALLOCATE( zmask, zts, sjk, zt_jk, zs_jk ) 402 ENDIF 187 403 ELSE 188 ! 189 zmask(:,:,:) = 0._wp 190 zts(:,:,:,:) = 0._wp 191 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface 404 ! i sum of j surface area - temperature/salinity product on T grid 405 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN 406 ALLOCATE( zmask(A2D(nn_hls),jpk), zts(A2D(nn_hls),jpk,jpts), & 407 & sjk(A1Dj(nn_hls),jpk,nbasin), & 408 & zt_jk(A1Dj(nn_hls),jpk,nbasin), zs_jk(A1Dj(nn_hls),jpk,nbasin) ) 409 410 zmask(:,:,:) = 0._wp 411 zts(:,:,:,:) = 0._wp 412 192 413 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 193 414 zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) … … 196 417 zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc 197 418 END_3D 198 ! 199 DO jn = 1, nptr 200 zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 201 z4d1(:,:,:,jn) = zmask(:,:,:) 202 ENDDO 203 CALL iom_put( 'zosrf', z4d1 ) 204 ! 205 DO jn = 1, nptr 206 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 207 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) 208 DO ji = 1, jpi 209 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 210 ENDDO 211 ENDDO 212 CALL iom_put( 'zotem', z4d2 ) 213 ! 214 DO jn = 1, nptr 215 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 216 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) 217 DO ji = 1, jpi 218 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 219 ENDDO 220 ENDDO 221 CALL iom_put( 'zosal', z4d2 ) 222 ! 223 ENDIF 224 ! 225 ! ! Advective and diffusive heat and salt transport 226 IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN 227 ! 228 DO jn = 1, nptr 229 z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 230 DO ji = 1, jpi 231 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 232 ENDDO 233 ENDDO 234 CALL iom_put( 'sophtadv', z3dtr ) 235 DO jn = 1, nptr 236 z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 237 DO ji = 1, jpi 238 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 239 ENDDO 240 ENDDO 241 CALL iom_put( 'sopstadv', z3dtr ) 242 ENDIF 243 ! 244 IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN 245 ! 246 DO jn = 1, nptr 247 z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 248 DO ji = 1, jpi 249 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 250 ENDDO 251 ENDDO 252 CALL iom_put( 'sophtldf', z3dtr ) 253 DO jn = 1, nptr 254 z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 255 DO ji = 1, jpi 256 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 257 ENDDO 258 ENDDO 259 CALL iom_put( 'sopstldf', z3dtr ) 260 ENDIF 261 ! 262 IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN 263 ! 264 DO jn = 1, nptr 265 z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 266 DO ji = 1, jpi 267 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 268 ENDDO 269 ENDDO 270 CALL iom_put( 'sophteiv', z3dtr ) 271 DO jn = 1, nptr 272 z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 273 DO ji = 1, jpi 274 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 275 ENDDO 276 ENDDO 277 CALL iom_put( 'sopsteiv', z3dtr ) 278 ENDIF 279 ! 419 420 DO jn = 1, nbasin 421 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:) , btmsk(:,:,jn) ) 422 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 423 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 424 ENDDO 425 426 CALL ptr_sum( pzon_int(:,:,jp_msk,:), sjk(:,:,:) ) 427 CALL ptr_sum( pzon_int(:,:,jp_tem,:), zt_jk(:,:,:) ) 428 CALL ptr_sum( pzon_int(:,:,jp_sal,:), zs_jk(:,:,:) ) 429 430 DEALLOCATE( zmask, zts, sjk, zt_jk, zs_jk ) 431 ENDIF 432 433 ! i-k sum of j surface area - temperature/salinity product on V grid 280 434 IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 435 ALLOCATE( zts(A2D(nn_hls),jpk,jpts) ) 436 281 437 zts(:,:,:,:) = 0._wp 438 282 439 DO_3D( 1, 0, 1, 1, 1, jpkm1 ) 283 440 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) … … 285 442 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 286 443 END_3D 287 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 288 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 289 DO jn = 1, nptr 290 z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 291 DO ji = 1, jpi 292 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 293 ENDDO 294 ENDDO 295 CALL iom_put( 'sophtvtr', z3dtr ) 296 DO jn = 1, nptr 297 z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 298 DO ji = 1, jpi 299 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 300 ENDDO 301 ENDDO 302 CALL iom_put( 'sopstvtr', z3dtr ) 303 ENDIF 304 ! 305 IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN 306 CALL iom_get_var( 'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml 307 z2d(:,:) = ptr_ci_2d( z2d(:,:) ) 308 CALL iom_put( 'uocetr_vsum_cumul', z2d ) 309 ENDIF 310 ! 444 445 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 446 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 447 448 DEALLOCATE( zts ) 449 ENDIF 311 450 ENDIF 312 ! 313 IF( ln_timing ) CALL timing_stop('dia_ptr') 314 ! 315 END SUBROUTINE dia_ptr 451 END SUBROUTINE dia_ptr_zint 316 452 317 453 … … 320 456 !! *** ROUTINE dia_ptr_init *** 321 457 !! 322 !! ** Purpose : Initialization , namelist read458 !! ** Purpose : Initialization 323 459 !!---------------------------------------------------------------------- 324 460 INTEGER :: inum, jn ! local integers … … 327 463 !!---------------------------------------------------------------------- 328 464 329 l_diaptr = .FALSE. 330 IF( iom_use( 'zomsf' ) .OR. iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. & 331 & iom_use( 'zosrf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 332 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR. & 333 & iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. & 334 & iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR. & 335 & iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) ) l_diaptr = .TRUE. 336 337 465 ! l_diaptr is defined with iom_use 466 ! --> dia_ptr_init must be done after the call to iom_init 467 ! --> cannot be .TRUE. without cpp key: key_iom --> nbasin define by iom_init is initialized 468 l_diaptr = iom_use( 'zomsf' ) .OR. iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. & 469 & iom_use( 'zosrf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 470 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR. & 471 & iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. & 472 & iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR. & 473 & iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) 474 338 475 IF(lwp) THEN ! Control print 339 476 WRITE(numout,*) 340 477 WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization' 341 478 WRITE(numout,*) '~~~~~~~~~~~~' 342 WRITE(numout,*) ' Namelist namptr : set ptr parameters'343 479 WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) l_diaptr = ', l_diaptr 344 480 ENDIF … … 347 483 ! 348 484 IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) 349 485 ! 350 486 rc_pwatt = rc_pwatt * rho0_rcp ! conversion from K.s-1 to PetaWatt 351 487 rc_ggram = rc_ggram * rho0 ! conversion from m3/s to Gg/s … … 354 490 355 491 btmsk(:,:,1) = tmask_i(:,:) 356 CALL iom_open( 'subbasins', inum, ldstop = .FALSE. ) 357 CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 358 CALL iom_get( inum, jpdom_global, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin 359 CALL iom_get( inum, jpdom_global, 'indmsk', btmsk(:,:,4) ) ! Indian basin 360 CALL iom_close( inum ) 361 btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin 362 DO jn = 2, nptr 363 btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only 492 IF( nbasin == 5 ) THEN ! nbasin has been initialized in iom_init to define the axis "basin" 493 CALL iom_open( 'subbasins', inum ) 494 CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 495 CALL iom_get( inum, jpdom_global, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin 496 CALL iom_get( inum, jpdom_global, 'indmsk', btmsk(:,:,4) ) ! Indian basin 497 CALL iom_close( inum ) 498 btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin 499 ENDIF 500 DO jn = 2, nbasin 501 btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only 364 502 END DO 365 503 ! JD : modification so that overturning streamfunction is available in Atlantic at 34S to compare with observations … … 370 508 END WHERE 371 509 btmsk34(:,:,1) = btmsk(:,:,1) 372 DO jn = 2, n ptr373 btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:) ! interior domain only510 DO jn = 2, nbasin 511 btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:) ! interior domain only 374 512 ENDDO 375 513 … … 382 520 hstr_btr(:,:,:) = 0._wp ! 383 521 hstr_vtr(:,:,:) = 0._wp ! 522 pvtr_int(:,:,:,:) = 0._wp 523 pzon_int(:,:,:,:) = 0._wp 384 524 ! 385 525 ll_init = .FALSE. … … 399 539 INTEGER , INTENT(in ) :: ktra ! tracer index 400 540 CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv' 401 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pvflx ! 3D input array of advection/diffusion 541 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: pvflx ! 3D input array of advection/diffusion 542 REAL(wp), DIMENSION(A1Dj(nn_hls),nbasin) :: zsj ! 402 543 INTEGER :: jn ! 403 544 545 DO jn = 1, nbasin 546 zsj(:,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 547 ENDDO 404 548 ! 405 549 IF( cptr == 'adv' ) THEN 406 IF( ktra == jp_tem ) THEN 407 DO jn = 1, nptr 408 hstr_adv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 409 ENDDO 410 ENDIF 411 IF( ktra == jp_sal ) THEN 412 DO jn = 1, nptr 413 hstr_adv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 414 ENDDO 415 ENDIF 550 IF( ktra == jp_tem ) CALL ptr_sum( hstr_adv(:,jp_tem,:), zsj(:,:) ) 551 IF( ktra == jp_sal ) CALL ptr_sum( hstr_adv(:,jp_sal,:), zsj(:,:) ) 552 ELSE IF( cptr == 'ldf' ) THEN 553 IF( ktra == jp_tem ) CALL ptr_sum( hstr_ldf(:,jp_tem,:), zsj(:,:) ) 554 IF( ktra == jp_sal ) CALL ptr_sum( hstr_ldf(:,jp_sal,:), zsj(:,:) ) 555 ELSE IF( cptr == 'eiv' ) THEN 556 IF( ktra == jp_tem ) CALL ptr_sum( hstr_eiv(:,jp_tem,:), zsj(:,:) ) 557 IF( ktra == jp_sal ) CALL ptr_sum( hstr_eiv(:,jp_sal,:), zsj(:,:) ) 558 ELSE IF( cptr == 'vtr' ) THEN 559 IF( ktra == jp_tem ) CALL ptr_sum( hstr_vtr(:,jp_tem,:), zsj(:,:) ) 560 IF( ktra == jp_sal ) CALL ptr_sum( hstr_vtr(:,jp_sal,:), zsj(:,:) ) 416 561 ENDIF 417 562 ! 418 IF( cptr == 'ldf' ) THEN 419 IF( ktra == jp_tem ) THEN 420 DO jn = 1, nptr 421 hstr_ldf(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 422 ENDDO 423 ENDIF 424 IF( ktra == jp_sal ) THEN 425 DO jn = 1, nptr 426 hstr_ldf(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 427 ENDDO 428 ENDIF 563 END SUBROUTINE dia_ptr_hst 564 565 566 SUBROUTINE ptr_sum_2d( phstr, pva ) 567 !!---------------------------------------------------------------------- 568 !! *** ROUTINE ptr_sum_2d *** 569 !!---------------------------------------------------------------------- 570 !! ** Purpose : Add two 2D arrays with (j,nbasin) dimensions 571 !! 572 !! ** Method : - phstr = phstr + pva 573 !! - Call mpp_sum if the final tile 574 !! 575 !! ** Action : phstr 576 !!---------------------------------------------------------------------- 577 REAL(wp), DIMENSION(jpj,nbasin) , INTENT(inout) :: phstr ! 578 REAL(wp), DIMENSION(A1Dj(nn_hls),nbasin), INTENT(in) :: pva ! 579 INTEGER :: jj 580 #if defined key_mpp_mpi 581 INTEGER, DIMENSION(1) :: ish1d 582 INTEGER, DIMENSION(2) :: ish2d 583 REAL(wp), DIMENSION(jpj*nbasin) :: zwork 584 #endif 585 586 DO jj = ntsj, ntej 587 phstr(jj,:) = phstr(jj,:) + pva(jj,:) 588 END DO 589 590 #if defined key_mpp_mpi 591 IF( ntile == 0 .OR. ntile == nijtile ) THEN 592 ish1d(1) = jpj*nbasin 593 ish2d(1) = jpj ; ish2d(2) = nbasin 594 zwork(:) = RESHAPE( phstr(:,:), ish1d ) 595 CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) 596 phstr(:,:) = RESHAPE( zwork, ish2d ) 429 597 ENDIF 430 ! 431 IF( cptr == 'eiv' ) THEN 432 IF( ktra == jp_tem ) THEN 433 DO jn = 1, nptr 434 hstr_eiv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 435 ENDDO 436 ENDIF 437 IF( ktra == jp_sal ) THEN 438 DO jn = 1, nptr 439 hstr_eiv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 440 ENDDO 441 ENDIF 598 #endif 599 END SUBROUTINE ptr_sum_2d 600 601 602 SUBROUTINE ptr_sum_3d( phstr, pva ) 603 !!---------------------------------------------------------------------- 604 !! *** ROUTINE ptr_sum_3d *** 605 !!---------------------------------------------------------------------- 606 !! ** Purpose : Add two 3D arrays with (j,k,nbasin) dimensions 607 !! 608 !! ** Method : - phstr = phstr + pva 609 !! - Call mpp_sum if the final tile 610 !! 611 !! ** Action : phstr 612 !!---------------------------------------------------------------------- 613 REAL(wp), DIMENSION(jpj,jpk,nbasin) , INTENT(inout) :: phstr ! 614 REAL(wp), DIMENSION(A1Dj(nn_hls),jpk,nbasin), INTENT(in) :: pva ! 615 INTEGER :: jj, jk 616 #if defined key_mpp_mpi 617 INTEGER, DIMENSION(1) :: ish1d 618 INTEGER, DIMENSION(3) :: ish3d 619 REAL(wp), DIMENSION(jpj*jpk*nbasin) :: zwork 620 #endif 621 622 DO jk = 1, jpk 623 DO jj = ntsj, ntej 624 phstr(jj,jk,:) = phstr(jj,jk,:) + pva(jj,jk,:) 625 END DO 626 END DO 627 628 #if defined key_mpp_mpi 629 IF( ntile == 0 .OR. ntile == nijtile ) THEN 630 ish1d(1) = jpj*jpk*nbasin 631 ish3d(1) = jpj ; ish3d(2) = jpk ; ish3d(3) = nbasin 632 zwork(:) = RESHAPE( phstr(:,:,:), ish1d ) 633 CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) 634 phstr(:,:,:) = RESHAPE( zwork, ish3d ) 442 635 ENDIF 443 ! 444 IF( cptr == 'vtr' ) THEN 445 IF( ktra == jp_tem ) THEN 446 DO jn = 1, nptr 447 hstr_vtr(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 448 ENDDO 449 ENDIF 450 IF( ktra == jp_sal ) THEN 451 DO jn = 1, nptr 452 hstr_vtr(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 453 ENDDO 454 ENDIF 455 ENDIF 456 ! 457 END SUBROUTINE dia_ptr_hst 636 #endif 637 END SUBROUTINE ptr_sum_3d 458 638 459 639 … … 463 643 !!---------------------------------------------------------------------- 464 644 INTEGER :: dia_ptr_alloc ! return value 465 INTEGER, DIMENSION( 3) :: ierr645 INTEGER, DIMENSION(2) :: ierr 466 646 !!---------------------------------------------------------------------- 467 647 ierr(:) = 0 468 648 ! 649 ! nbasin has been initialized in iom_init to define the axis "basin" 650 ! 469 651 IF( .NOT. ALLOCATED( btmsk ) ) THEN 470 ALLOCATE( btmsk(jpi,jpj,nptr) , btmsk34(jpi,jpj,nptr), & 471 & hstr_adv(jpj,jpts,nptr), hstr_eiv(jpj,jpts,nptr), & 472 & hstr_ove(jpj,jpts,nptr), hstr_btr(jpj,jpts,nptr), & 473 & hstr_ldf(jpj,jpts,nptr), hstr_vtr(jpj,jpts,nptr), STAT=ierr(1) ) 474 ! 475 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 652 ALLOCATE( btmsk(jpi,jpj,nbasin) , btmsk34(jpi,jpj,nbasin), & 653 & hstr_adv(jpj,jpts,nbasin), hstr_eiv(jpj,jpts,nbasin), & 654 & hstr_ove(jpj,jpts,nbasin), hstr_btr(jpj,jpts,nbasin), & 655 & hstr_ldf(jpj,jpts,nbasin), hstr_vtr(jpj,jpts,nbasin), STAT=ierr(1) ) 656 ! 657 ALLOCATE( pvtr_int(jpj,jpk,jpts+2,nbasin), & 658 & pzon_int(jpj,jpk,jpts+1,nbasin), STAT=ierr(2) ) 476 659 ! 477 660 dia_ptr_alloc = MAXVAL( ierr ) … … 493 676 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 494 677 !!---------------------------------------------------------------------- 495 REAL(wp), INTENT(in), DIMENSION( jpi,jpj,jpk) :: pvflx ! mask flux array at V-point496 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) 678 REAL(wp), INTENT(in), DIMENSION(A2D(nn_hls),jpk) :: pvflx ! mask flux array at V-point 679 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 497 680 ! 498 681 INTEGER :: ji, jj, jk ! dummy loop arguments 499 INTEGER :: ijpj ! ??? 500 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 682 REAL(wp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value 501 683 !!-------------------------------------------------------------------- 502 684 ! 503 p_fval => p_fval1d504 505 ijpj = jpj506 685 p_fval(:) = 0._wp 507 686 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 508 687 p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 509 688 END_3D 510 #if defined key_mpp_mpi511 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl)512 #endif513 !514 689 END FUNCTION ptr_sj_3d 515 690 … … 526 701 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 527 702 !!---------------------------------------------------------------------- 528 REAL(wp) , INTENT(in), DIMENSION( jpi,jpj):: pvflx ! mask flux array at V-point703 REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls)) :: pvflx ! mask flux array at V-point 529 704 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 530 705 ! 531 706 INTEGER :: ji,jj ! dummy loop arguments 532 INTEGER :: ijpj ! ??? 533 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 707 REAL(wp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value 534 708 !!-------------------------------------------------------------------- 535 ! 536 p_fval => p_fval1d 537 538 ijpj = jpj 709 ! 539 710 p_fval(:) = 0._wp 540 711 DO_2D( 0, 0, 0, 0 ) 541 712 p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) 542 713 END_2D 543 #if defined key_mpp_mpi544 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl )545 #endif546 !547 714 END FUNCTION ptr_sj_2d 548 715 … … 570 737 p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) 571 738 END_2D 572 CALL lbc_lnk( 'diaptr', p_fval, 'U', -1.0_wp )573 739 END DO 574 740 ! … … 589 755 !! 590 756 IMPLICIT none 591 REAL(wp) , INTENT(in), DIMENSION( jpi,jpj,jpk) :: pta ! mask flux array at V-point592 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) 757 REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls),jpk) :: pta ! mask flux array at V-point 758 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 593 759 !! 594 760 INTEGER :: ji, jj, jk ! dummy loop arguments 595 REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value 596 #if defined key_mpp_mpi 597 INTEGER, DIMENSION(1) :: ish 598 INTEGER, DIMENSION(2) :: ish2 599 INTEGER :: ijpjjpk 600 REAL(wp), DIMENSION(jpj*jpk) :: zwork ! mask flux array at V-point 601 #endif 761 REAL(wp), DIMENSION(A1Dj(nn_hls),jpk) :: p_fval ! return function value 602 762 !!-------------------------------------------------------------------- 603 763 ! 604 p_fval => p_fval2d605 606 764 p_fval(:,:) = 0._wp 607 765 ! … … 609 767 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 610 768 END_3D 611 !612 #if defined key_mpp_mpi613 ijpjjpk = jpj*jpk614 ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk615 zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )616 CALL mpp_sum( 'diaptr', zwork, ijpjjpk, ncomm_znl )617 p_fval(:,:) = RESHAPE( zwork, ish2 )618 #endif619 !620 769 END FUNCTION ptr_sjk 621 770
Note: See TracChangeset
for help on using the changeset viewer.
