Changeset 13519
- Timestamp:
- 2020-09-24T20:51:13+02:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r13383_HPC-02_Daley_Tiling/src/OCE/DIA
- Files:
-
- 2 edited
-
diaar5.F90 (modified) (5 diffs)
-
diaptr.F90 (modified) (22 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r13383_HPC-02_Daley_Tiling/src/OCE/DIA/diaar5.F90
r13295 r13519 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 … … 54 55 !!---------------------------------------------------------------------- 55 56 ! 56 ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , STAT=dia_ar5_alloc ) 57 ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , & 58 & hstr_adv(jpi,jpj,jpts,2), hstr_ldf(jpi,jpj,jpts,2), STAT=dia_ar5_alloc ) 57 59 ! 58 60 CALL mpp_sum ( 'diaar5', dia_ar5_alloc ) … … 306 308 END SUBROUTINE dia_ar5 307 309 308 309 SUBROUTINE dia_ar5_hst( ktra, cptr, puflx, pvflx ) 310 ! TEMP: These changes and lbc_lnk not necessary if using XIOS (subdomain support, will not output haloes) 311 SUBROUTINE dia_ar5_hst( ktra, cptr, puflx, pvflx ) 310 312 !!---------------------------------------------------------------------- 311 313 !! *** ROUTINE dia_ar5_htr *** … … 316 318 INTEGER , INTENT(in ) :: ktra ! tracer index 317 319 CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf' 318 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in) :: puflx ! u-flux of advection/diffusion319 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in) :: pvflx ! v-flux of advection/diffusion320 REAL(wp), DIMENSION(ST_2D(nn_hls),jpk) , INTENT(in) :: puflx ! u-flux of advection/diffusion 321 REAL(wp), DIMENSION(ST_2D(nn_hls),jpk) , INTENT(in) :: pvflx ! v-flux of advection/diffusion 320 322 ! 321 323 INTEGER :: ji, jj, jk 322 REAL(wp), DIMENSION(jpi,jpj) :: z2d 323 324 325 z2d(:,:) = puflx(:,:,1) 326 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 327 z2d(ji,jj) = z2d(ji,jj) + puflx(ji,jj,jk) 328 END_3D 329 CALL lbc_lnk( 'diaar5', z2d, 'U', -1.0_wp ) 330 IF( cptr == 'adv' ) THEN 331 IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in i-direction 332 IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0 * z2d ) ! advective salt transport in i-direction 333 ENDIF 334 IF( cptr == 'ldf' ) THEN 335 IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * z2d ) ! diffusive heat transport in i-direction 336 IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0 * z2d ) ! diffusive salt transport in i-direction 337 ENDIF 338 ! 339 z2d(:,:) = pvflx(:,:,1) 340 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 341 z2d(ji,jj) = z2d(ji,jj) + pvflx(ji,jj,jk) 342 END_3D 343 CALL lbc_lnk( 'diaar5', z2d, 'V', -1.0_wp ) 344 IF( cptr == 'adv' ) THEN 345 IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in j-direction 346 IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0 * z2d ) ! advective salt transport in j-direction 347 ENDIF 348 IF( cptr == 'ldf' ) THEN 349 IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * z2d ) ! diffusive heat transport in j-direction 350 IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0 * z2d ) ! diffusive salt transport in j-direction 351 ENDIF 352 324 325 IF( cptr /= 'adv' .AND. cptr /= 'ldf' ) RETURN 326 IF( ktra /= jp_tem .AND. ktra /= jp_sal ) RETURN 327 328 IF( cptr == 'adv' ) THEN 329 DO_2D( 0, 0, 0, 0 ) 330 hstr_adv(ji,jj,ktra,1) = puflx(ji,jj,1) 331 hstr_adv(ji,jj,ktra,2) = pvflx(ji,jj,1) 332 END_2D 333 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 334 hstr_adv(ji,jj,ktra,1) = hstr_adv(ji,jj,ktra,1) + puflx(ji,jj,jk) 335 hstr_adv(ji,jj,ktra,2) = hstr_adv(ji,jj,ktra,2) + pvflx(ji,jj,jk) 336 END_3D 337 ELSE IF( cptr == 'ldf' ) THEN 338 DO_2D( 0, 0, 0, 0 ) 339 hstr_ldf(ji,jj,ktra,1) = puflx(ji,jj,1) 340 hstr_ldf(ji,jj,ktra,2) = pvflx(ji,jj,1) 341 END_2D 342 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 343 hstr_ldf(ji,jj,ktra,1) = hstr_ldf(ji,jj,ktra,1) + puflx(ji,jj,jk) 344 hstr_ldf(ji,jj,ktra,2) = hstr_ldf(ji,jj,ktra,2) + pvflx(ji,jj,jk) 345 END_3D 346 ENDIF 347 348 IF( ntile == 0 .OR. ntile == nijtile ) THEN 349 IF( cptr == 'adv' ) THEN 350 CALL lbc_lnk( 'diaar5', hstr_adv(:,:,ktra,1), 'U', -1.0_wp ) 351 IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * hstr_adv(:,:,ktra,1) ) ! advective heat transport in i-direction 352 IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0 * hstr_adv(:,:,ktra,1) ) ! advective salt transport in i-direction 353 CALL lbc_lnk( 'diaar5', hstr_adv(:,:,ktra,2), 'V', -1.0_wp ) 354 IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * hstr_adv(:,:,ktra,2) ) ! advective heat transport in j-direction 355 IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0 * hstr_adv(:,:,ktra,2) ) ! advective salt transport in j-direction 356 ENDIF 357 IF( cptr == 'ldf' ) THEN 358 CALL lbc_lnk( 'diaar5', hstr_ldf(:,:,ktra,1), 'U', -1.0_wp ) 359 IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * hstr_ldf(:,:,ktra,1) ) ! diffusive heat transport in i-direction 360 IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0 * hstr_ldf(:,:,ktra,1) ) ! diffusive salt transport in i-direction 361 CALL lbc_lnk( 'diaar5', hstr_ldf(:,:,ktra,2), 'V', -1.0_wp ) 362 IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * hstr_ldf(:,:,ktra,2) ) ! diffusive heat transport in j-direction 363 IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0 * hstr_ldf(:,:,ktra,2) ) ! diffusive salt transport in j-direction 364 ENDIF 365 ENDIF 353 366 END SUBROUTINE dia_ar5_hst 354 367 … … 373 386 & iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) .OR. & 374 387 & iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) .OR. & 388 & iom_use( 'uadv_heattr' ) .OR. iom_use( 'udiff_heattr' ) .OR. & 389 & iom_use( 'uadv_salttr' ) .OR. iom_use( 'udiff_salttr' ) .OR. & 390 & iom_use( 'vadv_heattr' ) .OR. iom_use( 'vdiff_heattr' ) .OR. & 391 & iom_use( 'vadv_salttr' ) .OR. iom_use( 'vdiff_salttr' ) .OR. & 375 392 & iom_use( 'rhop' ) ) L_ar5 = .TRUE. 376 393 -
NEMO/branches/2020/dev_r13383_HPC-02_Daley_Tiling/src/OCE/DIA/diaptr.F90
r13295 r13519 22 22 USE oce ! ocean dynamics and active tracers 23 23 USE dom_oce ! ocean space and time domain 24 ! TEMP: Possibly not necessary if using XIOS (if cumulative axis operations are possible) 25 USE domain, ONLY : dom_tile 24 26 USE phycst ! physical constants 25 27 ! … … 32 34 PRIVATE 33 35 36 INTERFACE ptr_sum 37 MODULE PROCEDURE ptr_sum_3d, ptr_sum_2d 38 END INTERFACE 39 34 40 INTERFACE ptr_sj 35 41 MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d … … 43 49 44 50 ! !!** 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) 51 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) 52 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) 53 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: pvtr_int, pzon_int !: Other zonal integrals 47 54 48 55 LOGICAL , PUBLIC :: l_diaptr !: tracers trend flag (set from namelist in trdini) 49 56 INTEGER, PARAMETER, PUBLIC :: nptr = 5 ! (glo, atl, pac, ind, ipc) 57 INTEGER, PARAMETER :: jp_msk = 3 58 INTEGER, PARAMETER :: jp_vtr = 4 50 59 51 60 REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup … … 55 64 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks 56 65 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 66 61 67 LOGICAL :: ll_init = .TRUE. !: tracers trend flag (set from namelist in trdini) … … 71 77 CONTAINS 72 78 79 ! TEMP: Most changes and some code in this module not necessary if using XIOS (subdomain support, axis operations) 73 80 SUBROUTINE dia_ptr( kt, Kmm, pvtr ) 74 81 !!---------------------------------------------------------------------- … … 77 84 INTEGER , INTENT(in) :: kt ! ocean time-step index 78 85 INTEGER , INTENT(in) :: Kmm ! time level index 79 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport 86 REAL(wp), DIMENSION(ST_2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport 87 !!---------------------------------------------------------------------- 88 ! 89 IF( ln_timing ) CALL timing_start('dia_ptr') 90 91 IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init 92 ! 93 IF( l_diaptr ) THEN 94 ! Calculate zonal integrals 95 IF( PRESENT( pvtr ) ) THEN 96 CALL dia_ptr_zint( Kmm, pvtr ) 97 ELSE 98 CALL dia_ptr_zint( Kmm ) 99 ENDIF 100 101 ! Calculate diagnostics only when zonal integrals have finished 102 IF( ntile == 0 .OR. ntile == nijtile ) CALL dia_ptr_iom(kt, Kmm, pvtr) 103 ENDIF 104 105 IF( ln_timing ) CALL timing_stop('dia_ptr') 106 ! 107 END SUBROUTINE dia_ptr 108 109 110 SUBROUTINE dia_ptr_iom( kt, Kmm, pvtr ) 111 !!---------------------------------------------------------------------- 112 !! *** ROUTINE dia_ptr_iom *** 113 !!---------------------------------------------------------------------- 114 !! ** Purpose : Calculate diagnostics and send to XIOS 115 !!---------------------------------------------------------------------- 116 INTEGER , INTENT(in) :: kt ! ocean time-step index 117 INTEGER , INTENT(in) :: Kmm ! time level index 118 REAL(wp), DIMENSION(ST_2D(nn_hls),jpk) , INTENT(in), OPTIONAL :: pvtr ! j-effective transport 80 119 ! 81 120 INTEGER :: ji, jj, jk, jn ! dummy loop indices 82 REAL(wp) :: zsfc,zvfc ! local scalar83 121 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 122 REAL(wp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace 88 123 ! … … 94 129 REAL(wp), DIMENSION(jpi,jpj,nptr) :: z3dtr ! i-mean T and S, j-Stream-Function 95 130 !!---------------------------------------------------------------------- 96 !97 IF( ln_timing ) CALL timing_start('dia_ptr')98 99 IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init100 !101 IF( .NOT. l_diaptr ) RETURN102 131 103 132 IF( PRESENT( pvtr ) ) THEN 104 133 IF( iom_use( 'zomsf' ) ) THEN ! effective MSF 105 134 DO jn = 1, nptr ! by sub-basins 106 z4d1(1,:,:,jn) = p tr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )! zonal cumulative effective transport excluding closed seas107 DO jk = jpkm1, 1, -1 135 z4d1(1,:,:,jn) = pvtr_int(:,:,jp_vtr,jn) ! zonal cumulative effective transport excluding closed seas 136 DO jk = jpkm1, 1, -1 108 137 z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn) ! effective j-Stream-Function (MSF) 109 138 END DO … … 114 143 CALL iom_put( 'zomsf', z4d1 * rc_sv ) 115 144 ENDIF 116 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. &117 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN118 ! define fields multiplied by scalar119 zmask(:,:,:) = 0._wp120 zts(:,:,:,:) = 0._wp121 DO_3D( 1, 0, 1, 1, 1, jpkm1 )122 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm)123 zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc124 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 grid125 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc126 END_3D127 ENDIF128 145 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 129 146 DO jn = 1, nptr 130 sjk(:,:,jn) = p tr_sjk( zmask(:,:,:), btmsk(:,:,jn))147 sjk(:,:,jn) = pvtr_int(:,:,jp_msk,jn) 131 148 r1_sjk(:,:,jn) = 0._wp 132 149 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 133 150 ! i-mean T and S, j-Stream-Function, basin 134 zt_jk(:,:,jn) = p tr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn)) * r1_sjk(:,:,jn)135 zs_jk(:,:,jn) = p tr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn)) * r1_sjk(:,:,jn)136 v_msf(:,:,jn) = p tr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )151 zt_jk(:,:,jn) = pvtr_int(:,:,jp_tem,jn) * r1_sjk(:,:,jn) 152 zs_jk(:,:,jn) = pvtr_int(:,:,jp_sal,jn) * r1_sjk(:,:,jn) 153 v_msf(:,:,jn) = pvtr_int(:,:,jp_vtr,jn) 137 154 hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 138 155 hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) … … 158 175 ! Calculate barotropic heat and salt transport here 159 176 DO jn = 1, nptr 160 sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn))177 sjk(:,1,jn) = SUM( pvtr_int(:,:,jp_msk,jn), 2 ) 161 178 r1_sjk(:,1,jn) = 0._wp 162 179 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 163 180 ! 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))181 zvsum(:) = SUM( pvtr_int(:,:,jp_vtr,jn), 2 ) 182 ztsum(:) = SUM( pvtr_int(:,:,jp_tem,jn), 2 ) 183 zssum(:) = SUM( pvtr_int(:,:,jp_sal,jn), 2 ) 167 184 hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 168 185 hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) … … 185 202 ENDIF 186 203 ! 204 hstr_ove(:,:,:) = 0._wp ! Zero before next timestep 205 hstr_btr(:,:,:) = 0._wp 206 pvtr_int(:,:,:,:) = 0._wp 187 207 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 192 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 193 zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) 194 zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc 195 zts(ji,jj,jk,jp_tem) = ts(ji,jj,jk,jp_tem,Kmm) * zsfc 196 zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc 197 END_3D 208 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface 198 209 ! 199 210 DO jn = 1, nptr 200 zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 201 z4d1(:,:,:,jn) = zmask(:,:,:) 211 z4d1(1,:,:,jn) = pzon_int(:,:,jp_msk,jn) 212 DO ji = 2, jpi 213 z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) 214 ENDDO 202 215 ENDDO 203 216 CALL iom_put( 'zosrf', z4d1 ) 204 217 ! 205 218 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 219 z4d2(1,:,:,jn) = pzon_int(:,:,jp_tem,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) 220 DO ji = 2, jpi 209 221 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 210 222 ENDDO … … 213 225 ! 214 226 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 227 z4d2(1,:,:,jn) = pzon_int(:,:,jp_sal,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) 228 DO ji = 2, jpi 218 229 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 219 230 ENDDO … … 279 290 ! 280 291 IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 281 zts(:,:,:,:) = 0._wp282 DO_3D( 1, 0, 1, 1, 1, jpkm1 )283 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm)284 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 grid285 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc286 END_3D287 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) )288 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) )289 292 DO jn = 1, nptr 290 293 z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) … … 303 306 ENDIF 304 307 ! 308 ! TEMP: Possibly not necessary if using XIOS (if cumulative axis operations are possible) 309 ! TODO: NOT TESTED- hangs on iom_get_var 305 310 IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN 311 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Use full domain 306 312 CALL iom_get_var( 'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml 307 313 z2d(:,:) = ptr_ci_2d( z2d(:,:) ) 308 314 CALL iom_put( 'uocetr_vsum_cumul', z2d ) 309 ENDIF 310 ! 315 IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = nijtile ) ! Revert to tile domain 316 ENDIF 317 ! 318 hstr_adv(:,:,:) = 0._wp ! Zero before next timestep 319 hstr_ldf(:,:,:) = 0._wp 320 hstr_eiv(:,:,:) = 0._wp 321 hstr_vtr(:,:,:) = 0._wp 322 pzon_int(:,:,:,:) = 0._wp 311 323 ENDIF 312 ! 313 IF( ln_timing ) CALL timing_stop('dia_ptr') 314 ! 315 END SUBROUTINE dia_ptr 324 END SUBROUTINE dia_ptr_iom 325 326 327 SUBROUTINE dia_ptr_zint( Kmm, pvtr ) 328 !!---------------------------------------------------------------------- 329 !! *** ROUTINE dia_ptr_zint *** 330 !!---------------------------------------------------------------------- 331 !! ** Purpose : i and i-k sum operations on arrays 332 !! 333 !! ** Method : - Call ptr_sjk (i sum) or ptr_sj (i-k sum) to perform the sum operation 334 !! - Call ptr_sum to add this result to the sum over tiles 335 !! 336 !! ** Action : pvtr_int - terms for volume streamfunction, heat/salt transport barotropic/overturning terms 337 !! pzon_int - terms for i mean temperature/salinity 338 !!---------------------------------------------------------------------- 339 INTEGER , INTENT(in) :: Kmm ! time level index 340 REAL(wp), DIMENSION(ST_2D(nn_hls),jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport 341 REAL(wp), DIMENSION(ST_2D(nn_hls),jpk) :: zmask ! 3D workspace 342 REAL(wp), DIMENSION(ST_2D(nn_hls),jpk,jpts) :: zts ! 4D workspace 343 REAL(wp), DIMENSION(ST_1Dj(nn_hls),jpk,nptr) :: sjk, v_msf ! Zonal sum: i-k surface area, j-effective transport 344 REAL(wp), DIMENSION(ST_1Dj(nn_hls),jpk,nptr) :: zt_jk, zs_jk ! Zonal sum: i-k surface area * (T, S) 345 REAL(wp) :: zsfc, zvfc ! i-k surface area 346 INTEGER :: ji, jj, jk, jn ! dummy loop indices 347 !!---------------------------------------------------------------------- 348 349 IF( PRESENT( pvtr ) ) THEN 350 ! i sum of effective j transport excluding closed seas 351 IF( iom_use( 'zomsf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 352 DO jn = 1, nptr 353 v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) 354 ENDDO 355 356 CALL ptr_sum( pvtr_int(:,:,jp_vtr,:), v_msf(:,:,:) ) 357 ENDIF 358 359 ! i sum of j surface area, j surface area - temperature/salinity product on V grid 360 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 361 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 362 zmask(:,:,:) = 0._wp 363 zts(:,:,:,:) = 0._wp 364 365 DO_3D( 1, 0, 1, 1, 1, jpkm1 ) 366 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 367 zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc 368 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 369 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 370 END_3D 371 372 DO jn = 1, nptr 373 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:) , btmsk(:,:,jn) ) 374 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 375 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 376 ENDDO 377 378 CALL ptr_sum( pvtr_int(:,:,jp_msk,:), sjk(:,:,:) ) 379 CALL ptr_sum( pvtr_int(:,:,jp_tem,:), zt_jk(:,:,:) ) 380 CALL ptr_sum( pvtr_int(:,:,jp_sal,:), zs_jk(:,:,:) ) 381 ENDIF 382 ELSE 383 ! i sum of j surface area - temperature/salinity product on T grid 384 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN 385 zmask(:,:,:) = 0._wp 386 zts(:,:,:,:) = 0._wp 387 388 DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 389 zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) 390 zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc 391 zts(ji,jj,jk,jp_tem) = ts(ji,jj,jk,jp_tem,Kmm) * zsfc 392 zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc 393 END_3D 394 395 DO jn = 1, nptr 396 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:) , btmsk(:,:,jn) ) 397 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 398 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 399 ENDDO 400 401 CALL ptr_sum( pzon_int(:,:,jp_msk,:), sjk(:,:,:) ) 402 CALL ptr_sum( pzon_int(:,:,jp_tem,:), zt_jk(:,:,:) ) 403 CALL ptr_sum( pzon_int(:,:,jp_sal,:), zs_jk(:,:,:) ) 404 ENDIF 405 406 ! i-k sum of j surface area - temperature/salinity product on V grid 407 IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 408 zts(:,:,:,:) = 0._wp 409 410 DO_3D( 1, 0, 1, 1, 1, jpkm1 ) 411 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 412 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 413 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 414 END_3D 415 416 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 417 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 418 ENDIF 419 ENDIF 420 END SUBROUTINE dia_ptr_zint 316 421 317 422 … … 353 458 IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum 354 459 355 btmsk(:,:,1) = tmask_i(:,:) 460 btmsk(:,:,:) = 0._wp 461 btmsk(:,:,1) = tmask_i(:,:) 356 462 CALL iom_open( 'subbasins', inum, ldstop = .FALSE. ) 357 463 CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin … … 382 488 hstr_btr(:,:,:) = 0._wp ! 383 489 hstr_vtr(:,:,:) = 0._wp ! 490 pvtr_int(:,:,:,:) = 0._wp 491 pzon_int(:,:,:,:) = 0._wp 384 492 ! 385 493 ll_init = .FALSE. … … 399 507 INTEGER , INTENT(in ) :: ktra ! tracer index 400 508 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 509 REAL(wp), DIMENSION(ST_2D(nn_hls),jpk) , INTENT(in) :: pvflx ! 3D input array of advection/diffusion 510 REAL(wp), DIMENSION(ST_1Dj(nn_hls),nptr) :: zsj ! 402 511 INTEGER :: jn ! 403 512 513 DO jn = 1, nptr 514 zsj(:,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 515 ENDDO 404 516 ! 405 517 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 518 IF( ktra == jp_tem ) CALL ptr_sum( hstr_adv(:,jp_tem,:), zsj(:,:) ) 519 IF( ktra == jp_sal ) CALL ptr_sum( hstr_adv(:,jp_sal,:), zsj(:,:) ) 520 ELSE IF( cptr == 'ldf' ) THEN 521 IF( ktra == jp_tem ) CALL ptr_sum( hstr_ldf(:,jp_tem,:), zsj(:,:) ) 522 IF( ktra == jp_sal ) CALL ptr_sum( hstr_ldf(:,jp_sal,:), zsj(:,:) ) 523 ELSE IF( cptr == 'eiv' ) THEN 524 IF( ktra == jp_tem ) CALL ptr_sum( hstr_eiv(:,jp_tem,:), zsj(:,:) ) 525 IF( ktra == jp_sal ) CALL ptr_sum( hstr_eiv(:,jp_sal,:), zsj(:,:) ) 526 ELSE IF( cptr == 'vtr' ) THEN 527 IF( ktra == jp_tem ) CALL ptr_sum( hstr_vtr(:,jp_tem,:), zsj(:,:) ) 528 IF( ktra == jp_sal ) CALL ptr_sum( hstr_vtr(:,jp_sal,:), zsj(:,:) ) 416 529 ENDIF 417 530 ! 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 531 END SUBROUTINE dia_ptr_hst 532 533 534 SUBROUTINE ptr_sum_2d( phstr, pva ) 535 !!---------------------------------------------------------------------- 536 !! *** ROUTINE ptr_sum_2d *** 537 !!---------------------------------------------------------------------- 538 !! ** Purpose : Add two 2D arrays with (j,nptr) dimensions 539 !! 540 !! ** Method : - phstr = phstr + pva 541 !! - Call mpp_sum if the final tile 542 !! 543 !! ** Action : phstr 544 !!---------------------------------------------------------------------- 545 REAL(wp), DIMENSION(jpj,nptr) , INTENT(inout) :: phstr ! 546 REAL(wp), DIMENSION(ST_1Dj(nn_hls),nptr), INTENT(in) :: pva ! 547 INTEGER :: jj 548 #if defined key_mpp_mpi 549 INTEGER, DIMENSION(1) :: ish1d 550 INTEGER, DIMENSION(2) :: ish2d 551 REAL(wp), DIMENSION(jpj*nptr) :: zwork 552 #endif 553 554 DO jj = ntsj, ntej 555 phstr(jj,:) = phstr(jj,:) + pva(jj,:) 556 END DO 557 558 #if defined key_mpp_mpi 559 IF( ntile == 0 .OR. ntile == nijtile ) THEN 560 ish1d(1) = jpj*nptr 561 ish2d(1) = jpj ; ish2d(2) = nptr 562 zwork(:) = RESHAPE( phstr(:,:), ish1d ) 563 CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) 564 phstr(:,:) = RESHAPE( zwork, ish2d ) 429 565 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 566 #endif 567 END SUBROUTINE ptr_sum_2d 568 569 570 SUBROUTINE ptr_sum_3d( phstr, pva ) 571 !!---------------------------------------------------------------------- 572 !! *** ROUTINE ptr_sum_3d *** 573 !!---------------------------------------------------------------------- 574 !! ** Purpose : Add two 3D arrays with (j,k,nptr) dimensions 575 !! 576 !! ** Method : - phstr = phstr + pva 577 !! - Call mpp_sum if the final tile 578 !! 579 !! ** Action : phstr 580 !!---------------------------------------------------------------------- 581 REAL(wp), DIMENSION(jpj,jpk,nptr) , INTENT(inout) :: phstr ! 582 REAL(wp), DIMENSION(ST_1Dj(nn_hls),jpk,nptr), INTENT(in) :: pva ! 583 INTEGER :: jj, jk 584 #if defined key_mpp_mpi 585 INTEGER, DIMENSION(1) :: ish1d 586 INTEGER, DIMENSION(3) :: ish3d 587 REAL(wp), DIMENSION(jpj*jpk*nptr) :: zwork 588 #endif 589 590 DO jk = 1, jpk 591 DO jj = ntsj, ntej 592 phstr(jj,jk,:) = phstr(jj,jk,:) + pva(jj,jk,:) 593 END DO 594 END DO 595 596 #if defined key_mpp_mpi 597 IF( ntile == 0 .OR. ntile == nijtile ) THEN 598 ish1d(1) = jpj*jpk*nptr 599 ish3d(1) = jpj ; ish3d(2) = jpk ; ish3d(3) = nptr 600 zwork(:) = RESHAPE( phstr(:,:,:), ish1d ) 601 CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) 602 phstr(:,:,:) = RESHAPE( zwork, ish3d ) 442 603 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 604 #endif 605 END SUBROUTINE ptr_sum_3d 458 606 459 607 … … 463 611 !!---------------------------------------------------------------------- 464 612 INTEGER :: dia_ptr_alloc ! return value 465 INTEGER, DIMENSION( 3) :: ierr613 INTEGER, DIMENSION(2) :: ierr 466 614 !!---------------------------------------------------------------------- 467 615 ierr(:) = 0 … … 473 621 & hstr_ldf(jpj,jpts,nptr), hstr_vtr(jpj,jpts,nptr), STAT=ierr(1) ) 474 622 ! 475 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 623 ALLOCATE( pvtr_int(jpj,jpk,jpts+2,nptr), & 624 & pzon_int(jpj,jpk,jpts+1,nptr), STAT=ierr(2) ) 476 625 ! 477 626 dia_ptr_alloc = MAXVAL( ierr ) … … 493 642 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 494 643 !!---------------------------------------------------------------------- 495 REAL(wp), INTENT(in), DIMENSION( jpi,jpj,jpk) :: pvflx ! mask flux array at V-point496 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) 644 REAL(wp), INTENT(in), DIMENSION(ST_2D(nn_hls),jpk) :: pvflx ! mask flux array at V-point 645 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 497 646 ! 498 647 INTEGER :: ji, jj, jk ! dummy loop arguments 499 INTEGER :: ijpj ! ??? 500 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 648 REAL(wp), DIMENSION(ST_1Dj(nn_hls)) :: p_fval ! function value 501 649 !!-------------------------------------------------------------------- 502 650 ! 503 p_fval => p_fval1d504 505 ijpj = jpj506 651 p_fval(:) = 0._wp 507 652 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 508 653 p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 509 654 END_3D 510 #if defined key_mpp_mpi511 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl)512 #endif513 !514 655 END FUNCTION ptr_sj_3d 515 656 … … 526 667 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 527 668 !!---------------------------------------------------------------------- 528 REAL(wp) , INTENT(in), DIMENSION( jpi,jpj):: pvflx ! mask flux array at V-point669 REAL(wp) , INTENT(in), DIMENSION(ST_2D(nn_hls)) :: pvflx ! mask flux array at V-point 529 670 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 530 671 ! 531 672 INTEGER :: ji,jj ! dummy loop arguments 532 INTEGER :: ijpj ! ??? 533 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 673 REAL(wp), DIMENSION(ST_1Dj(nn_hls)) :: p_fval ! function value 534 674 !!-------------------------------------------------------------------- 535 ! 536 p_fval => p_fval1d 537 538 ijpj = jpj 675 ! 539 676 p_fval(:) = 0._wp 540 677 DO_2D( 0, 0, 0, 0 ) 541 678 p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) 542 679 END_2D 543 #if defined key_mpp_mpi544 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl )545 #endif546 !547 680 END FUNCTION ptr_sj_2d 548 681 … … 589 722 !! 590 723 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) 724 REAL(wp) , INTENT(in), DIMENSION(ST_2D(nn_hls),jpk) :: pta ! mask flux array at V-point 725 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 593 726 !! 594 727 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 728 REAL(wp), DIMENSION(ST_1Dj(nn_hls),jpk) :: p_fval ! return function value 602 729 !!-------------------------------------------------------------------- 603 730 ! 604 p_fval => p_fval2d605 606 731 p_fval(:,:) = 0._wp 607 732 ! … … 609 734 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 610 735 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 736 END FUNCTION ptr_sjk 621 737
Note: See TracChangeset
for help on using the changeset viewer.
