Changeset 13054 for NEMO/branches/UKMO/dev_r12866_HPC-02_Daley_Tiling_trial_extra_halo/src/OCE/DIA/diaptr.F90
- Timestamp:
- 2020-06-05T18:56:01+02:00 (4 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/UKMO/dev_r12866_HPC-02_Daley_Tiling_trial_extra_halo/src/OCE/DIA/diaptr.F90
r12738 r13054 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 … … 43 48 44 49 ! !!** 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) 50 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) 51 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) 52 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: pvtr_int, pzon_int !: Other zonal integrals 47 53 48 54 LOGICAL , PUBLIC :: l_diaptr !: tracers trend flag (set from namelist in trdini) 49 55 INTEGER, PARAMETER, PUBLIC :: nptr = 5 ! (glo, atl, pac, ind, ipc) 56 INTEGER, PARAMETER :: jp_msk = 3 57 INTEGER, PARAMETER :: jp_vtr = 4 50 58 51 59 REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup … … 55 63 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks 56 64 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S) 57 58 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:) :: p_fval1d59 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d60 65 61 66 LOGICAL :: ll_init = .TRUE. !: tracers trend flag (set from namelist in trdini) … … 69 74 CONTAINS 70 75 76 ! TODO: Most changes and some code in this module not necessary if using XIOS (subdomain support, axis operations) 71 77 SUBROUTINE dia_ptr( kt, Kmm, pvtr ) 72 78 !!---------------------------------------------------------------------- … … 78 84 ! 79 85 INTEGER :: ji, jj, jk, jn ! dummy loop indices 80 REAL(wp) :: zsfc,zvfc ! local scalar86 INTEGER :: itile 81 87 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 82 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace83 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace84 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace85 88 REAL(wp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace 86 89 ! … … 99 102 IF( .NOT. l_diaptr ) RETURN 100 103 104 ! Calculate zonal integrals 105 IF( PRESENT( pvtr ) ) THEN 106 CALL dia_ptr_zint( Kmm, pvtr ) 107 ELSE 108 CALL dia_ptr_zint( Kmm ) 109 ENDIF 110 111 ! Calculate diagnostics only when zonal integrals have finished 112 IF( ntile /= 0 .AND. ntile /= nijtile ) RETURN 113 101 114 IF( PRESENT( pvtr ) ) THEN 102 115 IF( iom_use( 'zomsf' ) ) THEN ! effective MSF 103 116 DO jn = 1, nptr ! by sub-basins 104 z4d1(1,:,:,jn) = p tr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )! zonal cumulative effective transport excluding closed seas105 DO jk = jpkm1, 1, -1 117 z4d1(1,:,:,jn) = pvtr_int(:,:,jp_vtr,jn) ! zonal cumulative effective transport excluding closed seas 118 DO jk = jpkm1, 1, -1 106 119 z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn) ! effective j-Stream-Function (MSF) 107 120 END DO … … 112 125 CALL iom_put( 'zomsf', z4d1 * rc_sv ) 113 126 ENDIF 114 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. &115 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN116 ! define fields multiplied by scalar117 zmask(:,:,:) = 0._wp118 zts(:,:,:,:) = 0._wp119 DO_3D_10_11( 1, jpkm1 )120 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm)121 zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc122 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 grid123 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc124 END_3D125 ENDIF126 127 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 127 128 DO jn = 1, nptr 128 sjk(:,:,jn) = p tr_sjk( zmask(:,:,:), btmsk(:,:,jn))129 sjk(:,:,jn) = pvtr_int(:,:,jp_msk,jn) 129 130 r1_sjk(:,:,jn) = 0._wp 130 131 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 131 132 ! i-mean T and S, j-Stream-Function, basin 132 zt_jk(:,:,jn) = p tr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn)) * r1_sjk(:,:,jn)133 zs_jk(:,:,jn) = p tr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn)) * r1_sjk(:,:,jn)134 v_msf(:,:,jn) = p tr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )133 zt_jk(:,:,jn) = pvtr_int(:,:,jp_tem,jn) * r1_sjk(:,:,jn) 134 zs_jk(:,:,jn) = pvtr_int(:,:,jp_sal,jn) * r1_sjk(:,:,jn) 135 v_msf(:,:,jn) = pvtr_int(:,:,jp_vtr,jn) 135 136 hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 136 137 hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) … … 156 157 ! Calculate barotropic heat and salt transport here 157 158 DO jn = 1, nptr 158 sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn))159 sjk(:,1,jn) = SUM( pvtr_int(:,:,jp_msk,jn), 2 ) 159 160 r1_sjk(:,1,jn) = 0._wp 160 161 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 161 162 ! 162 zvsum(:) = ptr_sj( pvtr(:,:,:), btmsk34(:,:,jn))163 ztsum(:) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn))164 zssum(:) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn))163 zvsum(:) = SUM( pvtr_int(:,:,jp_vtr,jn), 2 ) 164 ztsum(:) = SUM( pvtr_int(:,:,jp_tem,jn), 2 ) 165 zssum(:) = SUM( pvtr_int(:,:,jp_sal,jn), 2 ) 165 166 hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 166 167 hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) … … 183 184 ENDIF 184 185 ! 186 hstr_ove(:,:,:) = 0._wp ! Zero before next timestep 187 hstr_btr(:,:,:) = 0._wp 188 pvtr_int(:,:,:,:) = 0._wp 185 189 ELSE 186 ! 187 zmask(:,:,:) = 0._wp 188 zts(:,:,:,:) = 0._wp 189 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface 190 DO_3D_11_11( 1, jpkm1 ) 191 zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) 192 zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc 193 zts(ji,jj,jk,jp_tem) = ts(ji,jj,jk,jp_tem,Kmm) * zsfc 194 zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc 195 END_3D 190 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface 196 191 ! 197 192 DO jn = 1, nptr 198 zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 199 z4d1(:,:,:,jn) = zmask(:,:,:) 193 z4d1(1,:,:,jn) = pzon_int(:,:,jp_msk,jn) 194 DO ji = 2, jpi 195 z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) 196 ENDDO 200 197 ENDDO 201 198 CALL iom_put( 'zosrf', z4d1 ) 202 199 ! 203 200 DO jn = 1, nptr 204 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 205 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) 206 DO ji = 1, jpi 201 z4d2(1,:,:,jn) = pzon_int(:,:,jp_tem,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) 202 DO ji = 2, jpi 207 203 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 208 204 ENDDO … … 211 207 ! 212 208 DO jn = 1, nptr 213 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 214 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) 215 DO ji = 1, jpi 209 z4d2(1,:,:,jn) = pzon_int(:,:,jp_sal,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) 210 DO ji = 2, jpi 216 211 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 217 212 ENDDO … … 277 272 ! 278 273 IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 279 zts(:,:,:,:) = 0._wp280 DO_3D_10_11( 1, jpkm1 )281 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm)282 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 grid283 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc284 END_3D285 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) )286 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) )287 274 DO jn = 1, nptr 288 275 z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) … … 301 288 ENDIF 302 289 ! 290 ! TODO: Possibly not necessary if using XIOS (if cumulative axis operations are possible) 303 291 IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN 292 itile = ntile 293 CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Use full domain 304 294 CALL iom_get_var( 'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml 305 295 z2d(:,:) = ptr_ci_2d( z2d(:,:) ) 306 296 CALL iom_put( 'uocetr_vsum_cumul', z2d ) 307 ENDIF 308 ! 297 IF( ntile /= itile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = itile ) ! Revert to tile domain 298 ENDIF 299 ! 300 hstr_adv(:,:,:) = 0._wp ! Zero before next timestep 301 hstr_ldf(:,:,:) = 0._wp 302 hstr_eiv(:,:,:) = 0._wp 303 hstr_vtr(:,:,:) = 0._wp 304 pzon_int(:,:,:,:) = 0._wp 309 305 ENDIF 310 306 ! … … 312 308 ! 313 309 END SUBROUTINE dia_ptr 310 311 312 SUBROUTINE dia_ptr_zint( Kmm, pvtr ) 313 !!---------------------------------------------------------------------- 314 !! *** ROUTINE dia_ptr_zint *** 315 !!---------------------------------------------------------------------- 316 !! ** Purpose : i and i-k sum operations on arrays 317 !! 318 !! ** Method : - Call ptr_sjk (i sum) or ptr_sj (i-k sum) to perform the sum operation 319 !! - Call ptr_sum to add this result to the sum over tiles 320 !! 321 !! ** Action : pvtr_int - terms for volume streamfunction, heat/salt transport barotropic/overturning terms 322 !! pzon_int - terms for i mean temperature/salinity 323 !!---------------------------------------------------------------------- 324 INTEGER , INTENT(in) :: Kmm ! time level index 325 REAL(wp), DIMENSION(A2D,jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport 326 REAL(wp), DIMENSION(A2D,jpk) :: zmask ! 3D workspace 327 REAL(wp), DIMENSION(A2D,jpk,jpts) :: zts ! 4D workspace 328 REAL(wp), DIMENSION(A1Dj,jpk,nptr) :: sjk, v_msf ! Zonal sum: i-k surface area, j-effective transport 329 REAL(wp), DIMENSION(A1Dj,jpk,nptr) :: zt_jk, zs_jk ! Zonal sum: i-k surface area * (T, S) 330 REAL(wp) :: zsfc, zvfc ! i-k surface area 331 INTEGER :: ji, jj, jk, jn ! dummy loop indices 332 333 IF( PRESENT( pvtr ) ) THEN 334 ! i sum of effective j transport excluding closed seas 335 IF( iom_use( 'zomsf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 336 DO jn = 1, nptr 337 v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) 338 ENDDO 339 340 CALL ptr_sum( pvtr_int(:,:,jp_vtr,:), v_msf(:,:,:) ) 341 ENDIF 342 343 ! i sum of j surface area, j surface area - temperature/salinity product on V grid 344 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 345 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 346 zmask(:,:,:) = 0._wp 347 zts(:,:,:,:) = 0._wp 348 349 DO_3D_10_11( 1, jpkm1 ) 350 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 351 zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc 352 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 353 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 354 END_3D 355 356 DO jn = 1, nptr 357 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:) , btmsk(:,:,jn) ) 358 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 359 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 360 ENDDO 361 362 CALL ptr_sum( pvtr_int(:,:,jp_msk,:), sjk(:,:,:) ) 363 CALL ptr_sum( pvtr_int(:,:,jp_tem,:), zt_jk(:,:,:) ) 364 CALL ptr_sum( pvtr_int(:,:,jp_sal,:), zs_jk(:,:,:) ) 365 ENDIF 366 ELSE 367 ! i sum of j surface area - temperature/salinity product on T grid 368 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN 369 zmask(:,:,:) = 0._wp 370 zts(:,:,:,:) = 0._wp 371 372 DO_3D_11_11( 1, jpkm1 ) 373 zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) 374 zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc 375 zts(ji,jj,jk,jp_tem) = ts(ji,jj,jk,jp_tem,Kmm) * zsfc 376 zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc 377 END_3D 378 379 DO jn = 1, nptr 380 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:) , btmsk(:,:,jn) ) 381 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 382 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 383 ENDDO 384 385 CALL ptr_sum( pzon_int(:,:,jp_msk,:), sjk(:,:,:) ) 386 CALL ptr_sum( pzon_int(:,:,jp_tem,:), zt_jk(:,:,:) ) 387 CALL ptr_sum( pzon_int(:,:,jp_sal,:), zs_jk(:,:,:) ) 388 ENDIF 389 390 ! i-k sum of j surface area - temperature/salinity product on V grid 391 IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 392 zts(:,:,:,:) = 0._wp 393 394 DO_3D_10_11( 1, jpkm1 ) 395 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 396 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 397 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 398 END_3D 399 400 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 401 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 402 ENDIF 403 ENDIF 404 END SUBROUTINE dia_ptr_zint 314 405 315 406 … … 380 471 hstr_btr(:,:,:) = 0._wp ! 381 472 hstr_vtr(:,:,:) = 0._wp ! 473 pvtr_int(:,:,:,:) = 0._wp 474 pzon_int(:,:,:,:) = 0._wp 382 475 ! 383 476 ll_init = .FALSE. … … 397 490 INTEGER , INTENT(in ) :: ktra ! tracer index 398 491 CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv' 399 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pvflx ! 3D input array of advection/diffusion 492 REAL(wp), DIMENSION(A2D,jpk) , INTENT(in) :: pvflx ! 3D input array of advection/diffusion 493 REAL(wp), DIMENSION(A1Dj,nptr) :: zsj ! 400 494 INTEGER :: jn ! 401 495 496 DO jn = 1, nptr 497 zsj(:,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 498 ENDDO 402 499 ! 403 500 IF( cptr == 'adv' ) THEN 404 IF( ktra == jp_tem ) THEN 405 DO jn = 1, nptr 406 hstr_adv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 407 ENDDO 408 ENDIF 409 IF( ktra == jp_sal ) THEN 410 DO jn = 1, nptr 411 hstr_adv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 412 ENDDO 413 ENDIF 501 IF( ktra == jp_tem ) CALL ptr_sum( hstr_adv(:,jp_tem,:), zsj(:,:) ) 502 IF( ktra == jp_sal ) CALL ptr_sum( hstr_adv(:,jp_sal,:), zsj(:,:) ) 503 ELSE IF( cptr == 'ldf' ) THEN 504 IF( ktra == jp_tem ) CALL ptr_sum( hstr_ldf(:,jp_tem,:), zsj(:,:) ) 505 IF( ktra == jp_sal ) CALL ptr_sum( hstr_ldf(:,jp_sal,:), zsj(:,:) ) 506 ELSE IF( cptr == 'eiv' ) THEN 507 IF( ktra == jp_tem ) CALL ptr_sum( hstr_eiv(:,jp_tem,:), zsj(:,:) ) 508 IF( ktra == jp_sal ) CALL ptr_sum( hstr_eiv(:,jp_sal,:), zsj(:,:) ) 509 ELSE IF( cptr == 'vtr' ) THEN 510 IF( ktra == jp_tem ) CALL ptr_sum( hstr_vtr(:,jp_tem,:), zsj(:,:) ) 511 IF( ktra == jp_sal ) CALL ptr_sum( hstr_vtr(:,jp_sal,:), zsj(:,:) ) 414 512 ENDIF 415 513 ! 416 IF( cptr == 'ldf' ) THEN 417 IF( ktra == jp_tem ) THEN 418 DO jn = 1, nptr 419 hstr_ldf(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 420 ENDDO 421 ENDIF 422 IF( ktra == jp_sal ) THEN 423 DO jn = 1, nptr 424 hstr_ldf(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 425 ENDDO 426 ENDIF 514 END SUBROUTINE dia_ptr_hst 515 516 517 SUBROUTINE ptr_sum_2d( phstr, pva ) 518 !!---------------------------------------------------------------------- 519 !! *** ROUTINE ptr_sum_2d *** 520 !!---------------------------------------------------------------------- 521 !! ** Purpose : Add two 2D arrays with (j,nptr) dimensions 522 !! 523 !! ** Method : - phstr = phstr + pva 524 !! - Call mpp_sum if the final tile 525 !! 526 !! ** Action : phstr 527 !!---------------------------------------------------------------------- 528 REAL(wp), DIMENSION(jpj,nptr) , INTENT(inout) :: phstr ! 529 REAL(wp), DIMENSION(A1Dj,nptr), INTENT(in) :: pva ! 530 INTEGER :: jj 531 #if defined key_mpp_mpi 532 INTEGER, DIMENSION(1) :: ish1d 533 INTEGER, DIMENSION(2) :: ish2d 534 REAL(wp), DIMENSION(jpj*nptr) :: zwork 535 #endif 536 537 DO jj = Ntjs0, Ntje0 538 phstr(jj,:) = phstr(jj,:) + pva(jj,:) 539 END DO 540 541 #if defined key_mpp_mpi 542 IF( ntile == 0 .OR. ntile == nijtile ) THEN 543 ish1d(1) = jpj*nptr 544 ish2d(1) = jpj ; ish2d(2) = nptr 545 zwork(:) = RESHAPE( phstr(:,:), ish1d ) 546 CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) 547 phstr(:,:) = RESHAPE( zwork, ish2d ) 427 548 ENDIF 428 ! 429 IF( cptr == 'eiv' ) THEN 430 IF( ktra == jp_tem ) THEN 431 DO jn = 1, nptr 432 hstr_eiv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 433 ENDDO 434 ENDIF 435 IF( ktra == jp_sal ) THEN 436 DO jn = 1, nptr 437 hstr_eiv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 438 ENDDO 439 ENDIF 549 #endif 550 END SUBROUTINE ptr_sum_2d 551 552 553 SUBROUTINE ptr_sum_3d( phstr, pva ) 554 !!---------------------------------------------------------------------- 555 !! *** ROUTINE ptr_sum_3d *** 556 !!---------------------------------------------------------------------- 557 !! ** Purpose : Add two 3D arrays with (j,k,nptr) dimensions 558 !! 559 !! ** Method : - phstr = phstr + pva 560 !! - Call mpp_sum if the final tile 561 !! 562 !! ** Action : phstr 563 !!---------------------------------------------------------------------- 564 REAL(wp), DIMENSION(jpj,jpk,nptr) , INTENT(inout) :: phstr ! 565 REAL(wp), DIMENSION(A1Dj,jpk,nptr), INTENT(in) :: pva ! 566 INTEGER :: jj, jk 567 #if defined key_mpp_mpi 568 INTEGER, DIMENSION(1) :: ish1d 569 INTEGER, DIMENSION(3) :: ish3d 570 REAL(wp), DIMENSION(jpj*jpk*nptr) :: zwork 571 #endif 572 573 DO jk = 1, jpk 574 DO jj = Ntjs0, Ntje0 575 phstr(jj,jk,:) = phstr(jj,jk,:) + pva(jj,jk,:) 576 END DO 577 END DO 578 579 #if defined key_mpp_mpi 580 IF( ntile == 0 .OR. ntile == nijtile ) THEN 581 ish1d(1) = jpj*jpk*nptr 582 ish3d(1) = jpj ; ish3d(2) = jpk ; ish3d(3) = nptr 583 zwork(:) = RESHAPE( phstr(:,:,:), ish1d ) 584 CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) 585 phstr(:,:,:) = RESHAPE( zwork, ish3d ) 440 586 ENDIF 441 ! 442 IF( cptr == 'vtr' ) THEN 443 IF( ktra == jp_tem ) THEN 444 DO jn = 1, nptr 445 hstr_vtr(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 446 ENDDO 447 ENDIF 448 IF( ktra == jp_sal ) THEN 449 DO jn = 1, nptr 450 hstr_vtr(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 451 ENDDO 452 ENDIF 453 ENDIF 454 ! 455 END SUBROUTINE dia_ptr_hst 587 #endif 588 END SUBROUTINE ptr_sum_3d 456 589 457 590 … … 461 594 !!---------------------------------------------------------------------- 462 595 INTEGER :: dia_ptr_alloc ! return value 463 INTEGER, DIMENSION( 3) :: ierr596 INTEGER, DIMENSION(2) :: ierr 464 597 !!---------------------------------------------------------------------- 465 598 ierr(:) = 0 … … 471 604 & hstr_ldf(jpj,jpts,nptr), hstr_vtr(jpj,jpts,nptr), STAT=ierr(1) ) 472 605 ! 473 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 606 ALLOCATE( pvtr_int(jpj,jpk,jpts+2,nptr), & 607 & pzon_int(jpj,jpk,jpts+1,nptr), STAT=ierr(2) ) 474 608 ! 475 609 dia_ptr_alloc = MAXVAL( ierr ) … … 491 625 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 492 626 !!---------------------------------------------------------------------- 493 REAL(wp), INTENT(in), DIMENSION( jpi,jpj,jpk) :: pvflx ! mask flux array at V-point494 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) 627 REAL(wp), INTENT(in), DIMENSION(A2D,jpk) :: pvflx ! mask flux array at V-point 628 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 495 629 ! 496 630 INTEGER :: ji, jj, jk ! dummy loop arguments 497 INTEGER :: ijpj ! ??? 498 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 631 REAL(wp), DIMENSION(A1Dj) :: p_fval ! function value 499 632 !!-------------------------------------------------------------------- 500 633 ! 501 p_fval => p_fval1d502 503 ijpj = jpj504 634 p_fval(:) = 0._wp 505 635 DO_3D_00_00( 1, jpkm1 ) 506 636 p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 507 637 END_3D 508 #if defined key_mpp_mpi509 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl)510 #endif511 !512 638 END FUNCTION ptr_sj_3d 513 639 … … 524 650 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 525 651 !!---------------------------------------------------------------------- 526 REAL(wp) , INTENT(in), DIMENSION( jpi,jpj):: pvflx ! mask flux array at V-point652 REAL(wp) , INTENT(in), DIMENSION(A2D) :: pvflx ! mask flux array at V-point 527 653 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 528 654 ! 529 655 INTEGER :: ji,jj ! dummy loop arguments 530 INTEGER :: ijpj ! ??? 531 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 656 REAL(wp), DIMENSION(A1Dj) :: p_fval ! function value 532 657 !!-------------------------------------------------------------------- 533 658 ! 534 p_fval => p_fval1d535 536 ijpj = jpj537 659 p_fval(:) = 0._wp 538 660 DO_2D_00_00 539 661 p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) 540 662 END_2D 541 #if defined key_mpp_mpi542 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl )543 #endif544 !545 663 END FUNCTION ptr_sj_2d 546 664 … … 587 705 !! 588 706 IMPLICIT none 589 REAL(wp) , INTENT(in), DIMENSION( jpi,jpj,jpk) :: pta ! mask flux array at V-point590 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) 707 REAL(wp) , INTENT(in), DIMENSION(A2D,jpk) :: pta ! mask flux array at V-point 708 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 591 709 !! 592 710 INTEGER :: ji, jj, jk ! dummy loop arguments 593 REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value 594 #if defined key_mpp_mpi 595 INTEGER, DIMENSION(1) :: ish 596 INTEGER, DIMENSION(2) :: ish2 597 INTEGER :: ijpjjpk 598 REAL(wp), DIMENSION(jpj*jpk) :: zwork ! mask flux array at V-point 599 #endif 711 REAL(wp), DIMENSION(A1Dj,jpk) :: p_fval ! return function value 600 712 !!-------------------------------------------------------------------- 601 713 ! 602 p_fval => p_fval2d603 604 714 p_fval(:,:) = 0._wp 605 !606 715 DO_3D_00_00( 1, jpkm1 ) 607 716 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 608 717 END_3D 609 !610 #if defined key_mpp_mpi611 ijpjjpk = jpj*jpk612 ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk613 zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )614 CALL mpp_sum( 'diaptr', zwork, ijpjjpk, ncomm_znl )615 p_fval(:,:) = RESHAPE( zwork, ish2 )616 #endif617 !618 718 END FUNCTION ptr_sjk 619 719
Note: See TracChangeset
for help on using the changeset viewer.