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