- Timestamp:
- 2020-06-05T18:56:01+02:00 (4 years ago)
- Location:
- NEMO/branches/UKMO/dev_r12866_HPC-02_Daley_Tiling_trial_extra_halo/src/OCE
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/UKMO/dev_r12866_HPC-02_Daley_Tiling_trial_extra_halo/src/OCE/DIA/diaar5.F90
r12958 r13054 34 34 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,: ) :: thick0 ! ocean thickness (interior domain) 35 35 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sn0 ! initial salinity 36 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: hstr_adv, hstr_ldf 36 37 37 38 LOGICAL :: l_ar5 … … 53 54 !!---------------------------------------------------------------------- 54 55 ! 55 ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , STAT=dia_ar5_alloc ) 56 ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , & 57 & hstr_adv(jpi,jpj,jpts,2), hstr_ldf(jpi,jpj,jpts,2), STAT=dia_ar5_alloc ) 56 58 ! 57 59 CALL mpp_sum ( 'diaar5', dia_ar5_alloc ) … … 301 303 END SUBROUTINE dia_ar5 302 304 303 304 SUBROUTINE dia_ar5_hst( ktra, cptr, puflx, pvflx ) 305 ! TODO: These changes and lbc_lnk not necessary if using XIOS (subdomain support, will not output haloes) 306 SUBROUTINE dia_ar5_hst( ktra, cptr, puflx, pvflx ) 305 307 !!---------------------------------------------------------------------- 306 308 !! *** ROUTINE dia_ar5_htr *** … … 311 313 INTEGER , INTENT(in ) :: ktra ! tracer index 312 314 CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf' 313 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in) :: puflx ! u-flux of advection/diffusion314 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in) :: pvflx ! v-flux of advection/diffusion315 REAL(wp), DIMENSION(A2D,jpk) , INTENT(in) :: puflx ! u-flux of advection/diffusion 316 REAL(wp), DIMENSION(A2D,jpk) , INTENT(in) :: pvflx ! v-flux of advection/diffusion 315 317 ! 316 318 INTEGER :: ji, jj, jk 317 REAL(wp), DIMENSION(jpi,jpj) :: z2d 318 319 320 z2d(:,:) = puflx(:,:,1) 321 DO_3D_00_00( 1, jpkm1 ) 322 z2d(ji,jj) = z2d(ji,jj) + puflx(ji,jj,jk) 323 END_3D 324 CALL lbc_lnk( 'diaar5', z2d, 'U', -1. ) 325 IF( cptr == 'adv' ) THEN 326 IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in i-direction 327 IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0 * z2d ) ! advective salt transport in i-direction 328 ENDIF 329 IF( cptr == 'ldf' ) THEN 330 IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * z2d ) ! diffusive heat transport in i-direction 331 IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0 * z2d ) ! diffusive salt transport in i-direction 332 ENDIF 333 ! 334 z2d(:,:) = pvflx(:,:,1) 335 DO_3D_00_00( 1, jpkm1 ) 336 z2d(ji,jj) = z2d(ji,jj) + pvflx(ji,jj,jk) 337 END_3D 338 CALL lbc_lnk( 'diaar5', z2d, 'V', -1. ) 339 IF( cptr == 'adv' ) THEN 340 IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in j-direction 341 IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0 * z2d ) ! advective salt transport in j-direction 342 ENDIF 343 IF( cptr == 'ldf' ) THEN 344 IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * z2d ) ! diffusive heat transport in j-direction 345 IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0 * z2d ) ! diffusive salt transport in j-direction 346 ENDIF 347 319 320 IF( cptr /= 'adv' .AND. cptr /= 'ldf' ) RETURN 321 IF( ktra /= jp_tem .AND. ktra /= jp_sal ) RETURN 322 323 IF( cptr == 'adv' ) THEN 324 DO_2D_00_00 325 hstr_adv(ji,jj,ktra,1) = puflx(ji,jj,1) 326 hstr_adv(ji,jj,ktra,2) = pvflx(ji,jj,1) 327 END_2D 328 DO_3D_00_00( 1, jpkm1 ) 329 hstr_adv(ji,jj,ktra,1) = hstr_adv(ji,jj,ktra,1) + puflx(ji,jj,jk) 330 hstr_adv(ji,jj,ktra,2) = hstr_adv(ji,jj,ktra,2) + pvflx(ji,jj,jk) 331 END_3D 332 ELSE IF( cptr == 'ldf' ) THEN 333 DO_2D_00_00 334 hstr_ldf(ji,jj,ktra,1) = puflx(ji,jj,1) 335 hstr_ldf(ji,jj,ktra,2) = pvflx(ji,jj,1) 336 END_2D 337 DO_3D_00_00( 1, jpkm1 ) 338 hstr_ldf(ji,jj,ktra,1) = hstr_ldf(ji,jj,ktra,1) + puflx(ji,jj,jk) 339 hstr_ldf(ji,jj,ktra,2) = hstr_ldf(ji,jj,ktra,2) + pvflx(ji,jj,jk) 340 END_3D 341 ENDIF 342 343 IF( ntile == 0 .OR. ntile == nijtile ) THEN 344 IF( cptr == 'adv' ) THEN 345 CALL lbc_lnk( 'diaar5', hstr_adv(:,:,ktra,1), 'U', -1. ) 346 IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * hstr_adv(:,:,ktra,1) ) ! advective heat transport in i-direction 347 IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0 * hstr_adv(:,:,ktra,1) ) ! advective salt transport in i-direction 348 CALL lbc_lnk( 'diaar5', hstr_adv(:,:,ktra,2), 'V', -1. ) 349 IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * hstr_adv(:,:,ktra,2) ) ! advective heat transport in j-direction 350 IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0 * hstr_adv(:,:,ktra,2) ) ! advective salt transport in j-direction 351 ENDIF 352 IF( cptr == 'ldf' ) THEN 353 CALL lbc_lnk( 'diaar5', hstr_ldf(:,:,ktra,1), 'U', -1. ) 354 IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * hstr_ldf(:,:,ktra,1) ) ! diffusive heat transport in i-direction 355 IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0 * hstr_ldf(:,:,ktra,1) ) ! diffusive salt transport in i-direction 356 CALL lbc_lnk( 'diaar5', hstr_ldf(:,:,ktra,2), 'V', -1. ) 357 IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * hstr_ldf(:,:,ktra,2) ) ! diffusive heat transport in j-direction 358 IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0 * hstr_ldf(:,:,ktra,2) ) ! diffusive salt transport in j-direction 359 ENDIF 360 ENDIF 348 361 END SUBROUTINE dia_ar5_hst 349 362 … … 367 380 IF( iom_use( 'voltot' ) .OR. iom_use( 'sshtot' ) .OR. iom_use( 'sshdyn' ) .OR. & 368 381 & iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) .OR. & 369 & iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) ) L_ar5 = .TRUE. 382 & iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) .OR. & 383 & iom_use( 'uadv_heattr' ) .OR. iom_use( 'udiff_heattr' ) .OR. & 384 & iom_use( 'uadv_salttr' ) .OR. iom_use( 'udiff_salttr' ) .OR. & 385 & iom_use( 'vadv_heattr' ) .OR. iom_use( 'vdiff_heattr' ) .OR. & 386 & iom_use( 'vadv_salttr' ) .OR. iom_use( 'vdiff_salttr' ) ) L_ar5 = .TRUE. 370 387 371 388 IF( l_ar5 ) THEN -
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 -
NEMO/branches/UKMO/dev_r12866_HPC-02_Daley_Tiling_trial_extra_halo/src/OCE/do_loop_substitute.h90
r12979 r13054 114 114 #define Ntie2 Ntie0 + nn_hls 115 115 #define Ntje2 Ntje0 + nn_hls 116 #define A2D Ntis2:Ntie2,Ntjs2:Ntje2 116 #define A1Di Ntis2:Ntie2 117 #define A1Dj Ntjs2:Ntje2 118 #define A2D A1Di,A1Dj 117 119 118 120 #define DO_2D_00_00 DO jj = Ntjs0, Ntje0 ; DO ji = Ntis0, Ntie0
Note: See TracChangeset
for help on using the changeset viewer.